Theory Stateful_Protocol_Verification

(*  Title:      Stateful_Protocol_Verification.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, University of Exeter
    Author:     Anders Schlichtkrull, DTU
    SPDX-License-Identifier: BSD-3-Clause
*)

section‹Stateful Protocol Verification›
theory Stateful_Protocol_Verification
imports Stateful_Protocol_Model Term_Implication
begin

subsection ‹Fixed-Point Intruder Deduction Lemma›
context stateful_protocol_model
begin

abbreviation pubval_terms::"('fun,'atom,'sets,'lbl) prot_terms" where
  "pubval_terms ≡ {t. ∃f ∈ funs_term t. is_PubConstValue f}"

abbreviation abs_terms::"('fun,'atom,'sets,'lbl) prot_terms" where
  "abs_terms ≡ {t. ∃f ∈ funs_term t. is_Abs f}"

definition intruder_deduct_GSMP::
  "[('fun,'atom,'sets,'lbl) prot_terms,
    ('fun,'atom,'sets,'lbl) prot_terms,
    ('fun,'atom,'sets,'lbl) prot_term]
    ⇒ bool" (‹⟨_;_⟩ ⊢GSMP _› 50)
where
  "⟨M; T⟩ ⊢GSMP t ≡ intruder_deduct_restricted M (λt. t ∈ GSMP T - (pubval_terms ∪ abs_terms)) t"

lemma intruder_deduct_GSMP_induct[consumes 1, case_names AxiomH ComposeH DecomposeH]:
  assumes "⟨M; T⟩ ⊢GSMP t" "⋀t. t ∈ M ⟹ P M t"
          "⋀S f. ⟦length S = arity f; public f;
                  ⋀s. s ∈ set S ⟹ ⟨M; T⟩ ⊢GSMP s;
                  ⋀s. s ∈ set S ⟹ P M s;
                  Fun f S ∈ GSMP T - (pubval_terms ∪ abs_terms)
                  ⟧ ⟹ P M (Fun f S)"
          "⋀t K T' ti. ⟦⟨M; T⟩ ⊢GSMP t; P M t; Ana t = (K, T'); ⋀k. k ∈ set K ⟹ ⟨M; T⟩ ⊢GSMP k;
                        ⋀k. k ∈ set K ⟹ P M k; ti ∈ set T'⟧ ⟹ P M ti"
  shows "P M t"
proof -
  let ?Q = "λt. t ∈ GSMP T - (pubval_terms ∪ abs_terms)"
  show ?thesis
    using intruder_deduct_restricted_induct[of M ?Q t "λM Q t. P M t"] assms
    unfolding intruder_deduct_GSMP_def
    by blast
qed

lemma pubval_terms_subst:
  assumes "t ⋅ θ ∈ pubval_terms" "θ ` fv t ∩ pubval_terms = {}"
  shows "t ∈ pubval_terms"
using assms(1,2)
proof (induction t)
  case (Fun f T)
  let ?P = "λf. is_PubConstValue f"
  from Fun show ?case
  proof (cases "?P f")
    case False
    then obtain t where t: "t ∈ set T" "t ⋅ θ ∈ pubval_terms"
      using Fun.prems by auto
    hence "θ ` fv t ∩ pubval_terms = {}" using Fun.prems(2) by auto
    thus ?thesis using Fun.IH[OF t] t(1) by auto
  qed force
qed simp

lemma abs_terms_subst:
  assumes "t ⋅ θ ∈ abs_terms" "θ ` fv t ∩ abs_terms = {}"
  shows "t ∈ abs_terms"
using assms(1,2)
proof (induction t)
  case (Fun f T)
  let ?P = "λf. is_Abs f"
  from Fun show ?case
  proof (cases "?P f")
    case False
    then obtain t where t: "t ∈ set T" "t ⋅ θ ∈ abs_terms"
      using Fun.prems by auto
    hence "θ ` fv t ∩ abs_terms = {}" using Fun.prems(2) by auto
    thus ?thesis using Fun.IH[OF t] t(1) by auto
  qed force
qed simp

lemma pubval_terms_subst':
  assumes "t ⋅ θ ∈ pubval_terms" "∀n. PubConst Value n ∉ ⋃(funs_term ` (θ ` fv t))"
  shows "t ∈ pubval_terms"
proof -
  have False
    when fs: "f ∈ funs_term s" "s ∈ subtermsset (θ ` fv t)" "is_PubConstValue f"
    for f s
  proof -
    obtain T where T: "Fun f T ∈ subterms s" using funs_term_Fun_subterm[OF fs(1)] by force
    hence "Fun f T ∈ subtermsset (θ ` fv t)" using fs(2) in_subterms_subset_Union by blast
    thus ?thesis
      using assms(2) funs_term_Fun_subterm'[of f T] fs(3)
      unfolding is_PubConstValue_def
      by (cases f) force+
  qed
  thus ?thesis using pubval_terms_subst[OF assms(1)] by auto
qed

lemma abs_terms_subst':
  assumes "t ⋅ θ ∈ abs_terms" "∀n. Abs n ∉ ⋃(funs_term ` (θ ` fv t))"
  shows "t ∈ abs_terms"
proof -
  have "¬is_Abs f" when fs: "f ∈ funs_term s" "s ∈ subtermsset (θ ` fv t)" for f s
  proof -
    obtain T where T: "Fun f T ∈ subterms s" using funs_term_Fun_subterm[OF fs(1)] by force  
    hence "Fun f T ∈ subtermsset (θ ` fv t)" using fs(2) in_subterms_subset_Union by blast
    thus ?thesis using assms(2) funs_term_Fun_subterm'[of f T] by (cases f) auto
  qed
  thus ?thesis using abs_terms_subst[OF assms(1)] by force
qed

lemma pubval_terms_subst_range_disj:
  "subst_range θ ∩ pubval_terms = {} ⟹ θ ` fv t ∩ pubval_terms = {}"
proof (induction t)
  case (Var x) thus ?case by (cases "x ∈ subst_domain θ") auto
qed auto

lemma abs_terms_subst_range_disj:
  "subst_range θ ∩ abs_terms = {} ⟹ θ ` fv t ∩ abs_terms = {}"
proof (induction t)
  case (Var x) thus ?case by (cases "x ∈ subst_domain θ") auto
qed auto

lemma pubval_terms_subst_range_comp:
  assumes "subst_range θ ∩ pubval_terms = {}" "subst_range δ ∩ pubval_terms = {}"
  shows "subst_range (θ ∘s δ) ∩ pubval_terms = {}"
proof -
  { fix t f assume t:
      "t ∈ subst_range (θ ∘s δ)" "f ∈ funs_term t" "is_PubConstValue f"
    then obtain x where x: "(θ ∘s δ) x = t" by auto
    have "θ x ∉ pubval_terms" using assms(1) by (cases "θ x ∈ subst_range θ") force+
    hence "(θ ∘s δ) x ∉ pubval_terms"
      using assms(2) pubval_terms_subst[of "θ x" δ] pubval_terms_subst_range_disj
      by (metis (mono_tags, lifting) subst_compose_def)
    hence False using t(2,3) x by blast
  } thus ?thesis by fast
qed

lemma pubval_terms_subst_range_comp':
  assumes "(θ ` X) ∩ pubval_terms = {}" "(δ ` fvset (θ ` X)) ∩ pubval_terms = {}"
  shows "((θ ∘s δ) ` X) ∩ pubval_terms = {}"
proof -
  { fix t f assume t:
      "t ∈ (θ ∘s δ) ` X" "f ∈ funs_term t" "is_PubConstValue f"
    then obtain x where x: "(θ ∘s δ) x = t" "x ∈ X" by auto
    have "θ x ∉ pubval_terms" using assms(1) x(2) by force
    moreover have "fv (θ x) ⊆ fvset (θ ` X)" using x(2) by (auto simp add: fv_subset)
    hence "δ ` fv (θ x) ∩ pubval_terms = {}" using assms(2) by auto
    ultimately have "(θ ∘s δ) x ∉ pubval_terms"
      using pubval_terms_subst[of "θ x" δ]
      by (metis (mono_tags, lifting) subst_compose_def)
    hence False using t(2,3) x by blast
  } thus ?thesis by fast
qed

lemma abs_terms_subst_range_comp:
  assumes "subst_range θ ∩ abs_terms = {}" "subst_range δ ∩ abs_terms = {}"
  shows "subst_range (θ ∘s δ) ∩ abs_terms = {}"
proof -
  { fix t f assume t: "t ∈ subst_range (θ ∘s δ)" "f ∈ funs_term t" "is_Abs f"
    then obtain x where x: "(θ ∘s δ) x = t" by auto
    have "θ x ∉ abs_terms" using assms(1) by (cases "θ x ∈ subst_range θ") force+
    hence "(θ ∘s δ) x ∉ abs_terms"
      using assms(2) abs_terms_subst[of "θ x" δ] abs_terms_subst_range_disj
      by (metis (mono_tags, lifting) subst_compose_def)
    hence False using t(2,3) x by blast
  } thus ?thesis by fast
qed

lemma abs_terms_subst_range_comp':
  assumes "(θ ` X) ∩ abs_terms = {}" "(δ ` fvset (θ ` X)) ∩ abs_terms = {}"
  shows "((θ ∘s δ) ` X) ∩ abs_terms = {}"
proof -
  { fix t f assume t:
      "t ∈ (θ ∘s δ) ` X" "f ∈ funs_term t" "is_Abs f"
    then obtain x where x: "(θ ∘s δ) x = t" "x ∈ X" by auto
    have "θ x ∉ abs_terms" using assms(1) x(2) by force
    moreover have "fv (θ x) ⊆ fvset (θ ` X)" using x(2) by (auto simp add: fv_subset)
    hence "δ ` fv (θ x) ∩ abs_terms = {}" using assms(2) by auto
    ultimately have "(θ ∘s δ) x ∉ abs_terms"
      using abs_terms_subst[of "θ x" δ]
      by (metis (mono_tags, lifting) subst_compose_def)
    hence False using t(2,3) x by blast
  } thus ?thesis by fast
qed

context
begin
private lemma Ana_abs_aux1:
  fixes δ::"(('fun,'atom,'sets,'lbl) prot_fun, nat, ('fun,'atom,'sets,'lbl) prot_var) gsubst"
    and α::"nat ⇒ 'sets set"
  assumes "Anaf f = (K,T)"
  shows "(K ⋅list δ) ⋅αlist α = K ⋅list (λn. δ n ⋅α α)"
proof -
  { fix k assume "k ∈ set K"
    hence "k ∈ subtermsset (set K)" by force
    hence "k ⋅ δ ⋅α α = k ⋅ (λn. δ n ⋅α α)"
    proof (induction k)
      case (Fun g S)
      have "⋀s. s ∈ set S ⟹ s ⋅ δ ⋅α α = s ⋅ (λn. δ n ⋅α α)"
        using Fun.IH in_subterms_subset_Union[OF Fun.prems] Fun_param_in_subterms[of _ S g]
        by (meson contra_subsetD)
      thus ?case using Anaf_assm1_alt[OF assms Fun.prems] by (cases g) auto
    qed simp
  } thus ?thesis unfolding abs_apply_list_def by force
qed

private lemma Ana_abs_aux2:
  fixes α::"nat ⇒ 'sets set"
    and K::"(('fun,'atom,'sets,'lbl) prot_fun, nat) term list"
    and M::"nat list"
    and T::"('fun,'atom,'sets,'lbl) prot_term list"
  assumes "∀i ∈ fvset (set K) ∪ set M. i < length T"
    and "(K ⋅list (!) T) ⋅αlist α = K ⋅list (λn. T ! n ⋅α α)"
  shows "(K ⋅list (!) T) ⋅αlist α = K ⋅list (!) (map (λs. s ⋅α α) T)" (is "?A1 = ?A2")
    and "(map ((!) T) M) ⋅αlist α = map ((!) (map (λs. s ⋅α α) T)) M" (is "?B1 = ?B2")
proof -
  have "T ! i ⋅α α = (map (λs. s ⋅α α) T) ! i" when "i ∈ fvset (set K)" for i
    using that assms(1) by auto
  hence "k ⋅ (λi. T ! i ⋅α α) = k ⋅ (λi. (map (λs. s ⋅α α) T) ! i)" when "k ∈ set K" for k
    using that term_subst_eq_conv[of k "λi. T ! i ⋅α α" "λi. (map (λs. s ⋅α α) T) ! i"]
    by auto
  thus "?A1 = ?A2" using assms(2) by (force simp add: abs_apply_terms_def)

  have "T ! i ⋅α α = map (λs. s ⋅α α) T ! i" when "i ∈ set M" for i
    using that assms(1) by auto
  thus "?B1 = ?B2" by (force simp add: abs_apply_list_def)
qed

private lemma Ana_abs_aux1_set:
  fixes δ::"(('fun,'atom,'sets,'lbl) prot_fun, nat, ('fun,'atom,'sets,'lbl) prot_var) gsubst"
    and α::"nat ⇒ 'sets set"
  assumes "Anaf f = (K,T)"
  shows "(set K ⋅set δ) ⋅αset α = set K ⋅set (λn. δ n ⋅α α)"
proof -
  { fix k assume "k ∈ set K"
    hence "k ∈ subtermsset (set K)" by force
    hence "k ⋅ δ ⋅α α = k ⋅ (λn. δ n ⋅α α)"
    proof (induction k)
      case (Fun g S)
      have "⋀s. s ∈ set S ⟹ s ⋅ δ ⋅α α = s ⋅ (λn. δ n ⋅α α)"
        using Fun.IH in_subterms_subset_Union[OF Fun.prems] Fun_param_in_subterms[of _ S g]
        by (meson contra_subsetD)
      thus ?case using Anaf_assm1_alt[OF assms Fun.prems] by (cases g) auto
    qed simp
  } thus ?thesis unfolding abs_apply_terms_def by force
qed

private lemma Ana_abs_aux2_set:
  fixes α::"nat ⇒ 'sets set"
    and K::"(('fun,'atom,'sets,'lbl) prot_fun, nat) terms"
    and M::"nat set"
    and T::"('fun,'atom,'sets,'lbl) prot_term list"
  assumes "∀i ∈ fvset K ∪ M. i < length T"
    and "(K ⋅set (!) T) ⋅αset α = K ⋅set (λn. T ! n ⋅α α)"
  shows "(K ⋅set (!) T) ⋅αset α = K ⋅set (!) (map (λs. s ⋅α α) T)" (is "?A1 = ?A2")
    and "((!) T ` M) ⋅αset α = (!) (map (λs. s ⋅α α) T) ` M" (is "?B1 = ?B2")
proof -
  have "T ! i ⋅α α = (map (λs. s ⋅α α) T) ! i" when "i ∈ fvset K" for i
    using that assms(1) by auto
  hence "k ⋅ (λi. T ! i ⋅α α) = k ⋅ (λi. (map (λs. s ⋅α α) T) ! i)" when "k ∈ K" for k
    using that term_subst_eq_conv[of k "λi. T ! i ⋅α α" "λi. (map (λs. s ⋅α α) T) ! i"]
    by auto
  thus "?A1 = ?A2" using assms(2) by (force simp add: abs_apply_terms_def)

  have "T ! i ⋅α α = map (λs. s ⋅α α) T ! i" when "i ∈ M" for i
    using that assms(1) by auto
  thus "?B1 = ?B2" by (force simp add: abs_apply_terms_def)
qed

lemma Ana_abs:
  fixes t::"('fun,'atom,'sets,'lbl) prot_term"
  assumes "Ana t = (K, T)"
  shows "Ana (t ⋅α α) = (K ⋅αlist α, T ⋅αlist α)"
  using assms
proof (induction t rule: Ana.induct)
  case (1 f S)
  obtain K' T' where *: "Anaf f = (K',T')" by force
  show ?case using 1
  proof (cases "arityf f = length S ∧ arityf f > 0")
    case True
    hence "K = K' ⋅list (!) S" "T = map ((!) S) T'"
        and **: "arityf f = length (map (λs. s ⋅α α) S)" "arityf f > 0"
      using 1 * by auto
    hence "K ⋅αlist α = K' ⋅list (!) (map (λs. s ⋅α α) S)"
          "T ⋅αlist α = map ((!) (map (λs. s ⋅α α) S)) T'"
      using Anaf_assm2_alt[OF *] Ana_abs_aux2[OF _ Ana_abs_aux1[OF *], of T' S α]
      unfolding abs_apply_list_def
      by auto
    moreover have "Fun (Fu f) S ⋅α α = Fun (Fu f) (map (λs. s ⋅α α) S)" by simp
    ultimately show ?thesis using Ana_Fu_intro[OF ** *] by metis
  qed (auto simp add: abs_apply_list_def)
qed (simp_all add: abs_apply_list_def)
end

lemma deduct_FP_if_deduct:
  fixes M IK FP::"('fun,'atom,'sets,'lbl) prot_terms"
  assumes IK: "IK ⊆ GSMP M - (pubval_terms ∪ abs_terms)" "∀t ∈ IK ⋅αset α. FP ⊢c t"
    and t: "IK ⊢ t" "t ∈ GSMP M - (pubval_terms ∪ abs_terms)"
  shows "FP ⊢ t ⋅α α"
proof -
  let ?P = "λf. ¬is_PubConstValue f"
  let ?GSMP = "GSMP M - (pubval_terms ∪ abs_terms)"

  have 1: "∀m ∈ IK. m ∈ ?GSMP"
    using IK(1) by blast

  have 2: "∀t t'. t ∈ ?GSMP ⟶ t' ⊑ t ⟶ t' ∈ ?GSMP"
  proof (intro allI impI)
    fix t t' assume t: "t ∈ ?GSMP" "t' ⊑ t"
    hence "t' ∈ GSMP M" using ground_subterm unfolding GSMP_def by auto
    moreover have "¬is_PubConstValue f"
      when "f ∈ funs_term t" for f
      using t(1) that by auto
    hence "¬is_PubConstValue f"
      when "f ∈ funs_term t'" for f
      using that subtermeq_imp_funs_term_subset[OF t(2)] by auto
    moreover have "¬is_Abs f" when "f ∈ funs_term t" for f using t(1) that by auto
    hence "¬is_Abs f" when "f ∈ funs_term t'" for f
      using that subtermeq_imp_funs_term_subset[OF t(2)] by auto
    ultimately show "t' ∈ ?GSMP" by simp
  qed

  have 3: "∀t K T k. t ∈ ?GSMP ⟶ Ana t = (K, T) ⟶ k ∈ set K ⟶ k ∈ ?GSMP"
  proof (intro allI impI)
    fix t K T k assume t: "t ∈ ?GSMP" "Ana t = (K, T)" "k ∈ set K"
    hence "k ∈ GSMP M" using GSMP_Ana_key by blast
    moreover have "∀f ∈ funs_term t. ?P f" using t(1) by auto
    with t(2,3) have "∀f ∈ funs_term k. ?P f"
    proof (induction t arbitrary: k rule: Ana.induct)
      case 1 thus ?case by (metis Ana_Fu_keys_not_pubval_terms surj_pair)
    qed auto
    moreover have "∀f ∈ funs_term t. ¬is_Abs f" using t(1) by auto
    with t(2,3) have "∀f ∈ funs_term k. ¬is_Abs f"
    proof (induction t arbitrary: k rule: Ana.induct)
      case 1 thus ?case by (metis Ana_Fu_keys_not_abs_terms surj_pair)
    qed auto
    ultimately show "k ∈ ?GSMP" by simp
  qed

  have "⟨IK; M⟩ ⊢GSMP t"
    unfolding intruder_deduct_GSMP_def
    by (rule restricted_deduct_if_deduct'[OF 1 2 3 t])
  thus ?thesis
  proof (induction t rule: intruder_deduct_GSMP_induct)
    case (AxiomH t)
    show ?case using IK(2) abs_in[OF AxiomH.hyps] by force
  next
    case (ComposeH T f)
    have *: "Fun f T ⋅α α = Fun f (map (λt. t ⋅α α) T)"
      using ComposeH.hyps(2,4)
      by (cases f) auto

    have **: "length (map (λt. t ⋅α α) T) = arity f"
      using ComposeH.hyps(1)
      by auto

    show ?case
      using intruder_deduct.Compose[OF ** ComposeH.hyps(2)] ComposeH.IH(1) *
      by auto
  next
    case (DecomposeH t K T' ti)
    have *: "Ana (t ⋅α α) = (K ⋅αlist α, T' ⋅αlist α)"
      using Ana_abs[OF DecomposeH.hyps(2)]
      by metis

    have **: "ti ⋅α α ∈ set (T' ⋅αlist α)"
      using DecomposeH.hyps(4) abs_in abs_list_set_is_set_abs_set[of T']
      by auto

    have ***: "FP ⊢ k"
      when k: "k ∈ set (K ⋅αlist α)" for k
    proof -
      obtain k' where k': "k' ∈ set K" "k = k' ⋅α α"
        by (metis (no_types) k abs_apply_terms_def imageE abs_list_set_is_set_abs_set)

      show "FP ⊢ k"
        using DecomposeH.IH k' by blast
    qed

    show ?case
      using intruder_deduct.Decompose[OF _ * _ **]
            DecomposeH.IH(1) ***(1)
      by blast
  qed
qed

end


subsection ‹Computing and Checking Term Implications and Messages›
context stateful_protocol_model
begin

abbreviation (input) "absc s ≡ (Fun (Abs s) []::('fun,'atom,'sets,'lbl) prot_term)"

fun absdbupd where
  "absdbupd [] _ a = a"
| "absdbupd (insert⟨Var y, Fun (Set s) T⟩#D) x a = (
    if x = y then absdbupd D x (insert s a) else absdbupd D x a)"
| "absdbupd (delete⟨Var y, Fun (Set s) T⟩#D) x a = (
    if x = y then absdbupd D x (a - {s}) else absdbupd D x a)"
| "absdbupd (_#D) x a = absdbupd D x a"

lemma absdbupd_cons_cases:
  "absdbupd (insert⟨Var x, Fun (Set s) T⟩#D) x d = absdbupd D x (insert s d)"
  "absdbupd (delete⟨Var x, Fun (Set s) T⟩#D) x d = absdbupd D x (d - {s})"
  "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T) ⟹ absdbupd (insert⟨t,u⟩#D) x d = absdbupd D x d"
  "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T) ⟹ absdbupd (delete⟨t,u⟩#D) x d = absdbupd D x d"
proof -
  assume *: "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T)"
  let ?P = "absdbupd (insert⟨t,u⟩#D) x d = absdbupd D x d"
  let ?Q = "absdbupd (delete⟨t,u⟩#D) x d = absdbupd D x d"
  { fix y f T assume "t = Fun f T ∨ u = Var y" hence ?P ?Q by auto
  } moreover {
    fix y f T assume "t = Var y" "u = Fun f T" hence ?P using * by (cases f) auto
  } moreover {
    fix y f T assume "t = Var y" "u = Fun f T" hence ?Q using * by (cases f) auto
  } ultimately show ?P ?Q by (metis term.exhaust)+
qed simp_all

lemma absdbupd_filter: "absdbupd S x d = absdbupd (filter is_Update S) x d"
by (induction S x d rule: absdbupd.induct) simp_all

lemma absdbupd_append:
  "absdbupd (A@B) x d = absdbupd B x (absdbupd A x d)"
proof (induction A arbitrary: d)
  case (Cons a A) thus ?case
  proof (cases a)
    case (Insert t u) thus ?thesis
    proof (cases "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T)")
      case False
      then obtain s T where "t = Var x" "u = Fun (Set s) T" by force
      thus ?thesis by (simp add: Insert Cons.IH absdbupd_cons_cases(1))
    qed (simp_all add: Cons.IH absdbupd_cons_cases(3))
  next
    case (Delete t u) thus ?thesis
    proof (cases "t ≠ Var x ∨ (∄s T. u = Fun (Set s) T)")
      case False
      then obtain s T where "t = Var x" "u = Fun (Set s) T" by force
      thus ?thesis by (simp add: Delete Cons.IH absdbupd_cons_cases(2))
    qed (simp_all add: Cons.IH absdbupd_cons_cases(4))
  qed simp_all
qed simp

lemma absdbupd_wellformed_transaction:
  assumes T: "wellformed_transaction T"
  shows "absdbupd (unlabel (transaction_strand T)) = absdbupd (unlabel (transaction_updates T))"
proof -
  define S0 where "S0 ≡ unlabel (transaction_strand T)"
  define S1 where "S1 ≡ unlabel (transaction_receive T)"
  define S2 where "S2 ≡ unlabel (transaction_checks T)"
  define S3 where "S3 ≡ unlabel (transaction_updates T)"
  define S4 where "S4 ≡ unlabel (transaction_send T)"

  note S_defs = S0_def S1_def S2_def S3_def S4_def

  have 0: "list_all is_Receive S1"
          "list_all is_Check_or_Assignment S2"
          "list_all is_Update S3"
          "list_all is_Send S4"
    using T unfolding wellformed_transaction_def S_defs by metis+

  have "filter is_Update S1 = []"
       "filter is_Update S2 = []"
       "filter is_Update S3 = S3"
       "filter is_Update S4 = []"
    using list_all_filter_nil[OF 0(1), of is_Update]
          list_all_filter_nil[OF 0(2), of is_Update]
          list_all_filter_eq[OF 0(3)]
          list_all_filter_nil[OF 0(4), of is_Update]
    by blast+
  moreover have "S0 = S1@S2@S3@S4"
    unfolding S_defs transaction_strand_def unlabel_def by auto
  ultimately have "filter is_Update S0 = S3"
    using filter_append[of is_Update] list_all_append[of is_Update]
    by simp
  thus ?thesis
    using absdbupd_filter[of S0]
    unfolding S_defs by presburger
qed

fun abs_substs_set::
  "[('fun,'atom,'sets,'lbl) prot_var list,
    'sets set list,
    ('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set,
    ('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set,
    ('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set ⇒ bool]
  ⇒ ((('fun,'atom,'sets,'lbl) prot_var × 'sets set) list) list"
where
  "abs_substs_set [] _ _ _ _ = [[]]"
| "abs_substs_set (x#xs) as posconstrs negconstrs msgconstrs = (
    let bs = filter (λa. posconstrs x ⊆ a ∧ a ∩ negconstrs x = {} ∧ msgconstrs x a) as;
        Δ = abs_substs_set xs as posconstrs negconstrs msgconstrs
    in concat (map (λb. map (λδ. (x, b)#δ) Δ) bs))"

definition abs_substs_fun::
  "[(('fun,'atom,'sets,'lbl) prot_var × 'sets set) list,
    ('fun,'atom,'sets,'lbl) prot_var]
  ⇒ 'sets set"
where
  "abs_substs_fun δ x = (case find (λb. fst b = x) δ of Some (_,a) ⇒ a | None ⇒ {})"

lemmas abs_substs_set_induct = abs_substs_set.induct[case_names Nil Cons]

fun transaction_poschecks_comp::
  "(('fun,'atom,'sets,'lbl) prot_fun, ('fun,'atom,'sets,'lbl) prot_var) stateful_strand
  ⇒ (('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set)"
where
  "transaction_poschecks_comp [] = (λ_. {})"
| "transaction_poschecks_comp (⟨_: Var x ∈ Fun (Set s) []⟩#T) = (
    let f = transaction_poschecks_comp T in f(x := insert s (f x)))"
| "transaction_poschecks_comp (_#T) = transaction_poschecks_comp T"

fun transaction_negchecks_comp::
  "(('fun,'atom,'sets,'lbl) prot_fun, ('fun,'atom,'sets,'lbl) prot_var) stateful_strand
  ⇒ (('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set)"
where
  "transaction_negchecks_comp [] = (λ_. {})"
| "transaction_negchecks_comp (⟨Var x not in Fun (Set s) []⟩#T) = (
    let f = transaction_negchecks_comp T in f(x := insert s (f x)))"
| "transaction_negchecks_comp (_#T) = transaction_negchecks_comp T"

definition transaction_check_pre where
  "transaction_check_pre FPT T δ ≡
    let (FP, _, TI) = FPT;
        C = set (unlabel (transaction_checks T));
        xs = fv_listsst (unlabel (transaction_strand T));
        θ = λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x
    in (∀x ∈ set (transaction_fresh T). δ x = {}) ∧
       (∀t ∈ trmslsst (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ δ)) ∧
       (∀u ∈ C.
          (is_InSet u ⟶ (
            let x = the_elem_term u; s = the_set_term u
            in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∈ δ (the_Var x))) ∧
          ((is_NegChecks u ∧ bvarssstp u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1) ⟶ (
            let x = fst (hd (the_ins u)); s = snd (hd (the_ins u))
            in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∉ δ (the_Var x))))"

definition transaction_check_post where
  "transaction_check_post FPT T δ ≡
    let (FP, _, TI) = FPT;
        xs = fv_listsst (unlabel (transaction_strand T));
        θ = λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x;
        u = λδ x. absdbupd (unlabel (transaction_updates T)) x (δ x)
    in (∀x ∈ set xs - set (transaction_fresh T). δ x ≠ u δ x ⟶ List.member TI (δ x, u δ x)) ∧
       (∀t ∈ trmslsst (transaction_send T). intruder_synth_mod_timpls FP TI (t ⋅ θ (u δ)))"

definition fun_point_inter where "fun_point_inter f g ≡ λx. f x ∩ g x"
definition fun_point_union where "fun_point_union f g ≡ λx. f x ∪ g x"
definition fun_point_Inter where "fun_point_Inter fs ≡ λx. ⋂f ∈ fs. f x"
definition fun_point_Union where "fun_point_Union fs ≡ λx. ⋃f ∈ fs. f x"
definition fun_point_Inter_list where "fun_point_Inter_list fs ≡ λx. ⋂(set (map (λf. f x) fs))"
definition fun_point_Union_list where "fun_point_Union_list fs ≡ λx. ⋃(set (map (λf. f x) fs))"
definition ticl_abs where "ticl_abs TI a ≡ set (a#map snd (filter (λp. fst p = a) TI))"
definition ticl_abss where "ticl_abss TI as ≡ ⋃a ∈ as. ticl_abs TI a"

lemma fun_point_Inter_set_eq:
  "fun_point_Inter (set fs) = fun_point_Inter_list fs"
unfolding fun_point_Inter_def fun_point_Inter_list_def by simp

lemma fun_point_Union_set_eq:
  "fun_point_Union (set fs) = fun_point_Union_list fs"
unfolding fun_point_Union_def fun_point_Union_list_def by simp

lemma ticl_abs_refl_in: "x ∈ ticl_abs TI x"
unfolding ticl_abs_def by simp

lemma ticl_abs_iff:
  assumes TI: "set TI = {(a,b) ∈ (set TI)+. a ≠ b}"
  shows "ticl_abs TI a = {b. (a,b) ∈ (set TI)*}"  
proof (intro order_antisym subsetI)
  fix x assume x: "x ∈ {b. (a, b) ∈ (set TI)*}"
  hence "x = a ∨ (x ≠ a ∧ (a,x) ∈ (set TI)+)" by (metis mem_Collect_eq rtranclD)
  moreover have "ticl_abs TI a = {a} ∪ {b. (a,b) ∈ set TI}" unfolding ticl_abs_def by force
  ultimately show "x ∈ ticl_abs TI a" using TI by blast
qed (fastforce simp add: ticl_abs_def)

lemma ticl_abs_Inter:
  assumes xs: "⋂(ticl_abs TI ` xs) ≠ {}"
    and TI: "set TI = {(a,b) ∈ (set TI)+. a ≠ b}"
  shows "⋂(ticl_abs TI ` ⋂(ticl_abs TI ` xs)) ⊆ ⋂(ticl_abs TI ` xs)"
proof
  fix x assume x: "x ∈ ⋂(ticl_abs TI ` ⋂(ticl_abs TI ` xs))"
  have *: "⋂(ticl_abs TI ` xs) = {b. ∀a ∈ xs. (a,b) ∈ (set TI)*}"
    unfolding ticl_abs_iff[OF TI] by blast

  have "(b,x) ∈ (set TI)*" when b: "∀a ∈ xs. (a,b) ∈ (set TI)*" for b
    using x b unfolding ticl_abs_iff[OF TI] by blast
  hence "(a,x) ∈ (set TI)*" when "a ∈ xs" for a
    using that xs rtrancl.rtrancl_into_rtrancl[of a _ "(set TI)*" x]
    unfolding * rtrancl_idemp[of "set TI"] by blast
  thus "x ∈ ⋂(ticl_abs TI ` xs)" unfolding * by blast
qed

function (sequential) match_abss'
::"(('a,'b,'c,'d) prot_fun, 'e) term ⇒
   (('a,'b,'c,'d) prot_fun, 'e) term ⇒
   ('e ⇒ 'c set set) option"
where
  "match_abss' (Var x) (Fun (Abs a) _) = Some ((λ_. {})(x := {a}))"
| "match_abss' (Fun f ts) (Fun g ss) = (
    if f = g ∧ length ts = length ss
    then map_option fun_point_Union_list (those (map2 match_abss' ts ss))
    else None)"
| "match_abss' _ _ = None"
by pat_completeness auto
termination
proof -
  let ?m = "measures [size ∘ fst]"

  have 0: "wf ?m" by simp

  show ?thesis
    apply (standard, use 0 in fast)
    by (metis (no_types) comp_def fst_conv measures_less Fun_zip_size_lt(1))
qed

definition match_abss where
  "match_abss OCC TI t s ≡ (
    let xs = fv t;
        OCC' = set OCC;
        f = λδ x. if x ∈ xs then δ x else OCC';
        g = λδ x. ⋂(ticl_abs TI ` δ x)
    in case match_abss' t s of
      Some δ ⇒
        let δ' = g δ
        in if ∀x ∈ xs. δ' x ≠ {} then Some (f δ') else None
    | None ⇒ None)"

lemma match_abss'_Var_inv:
  assumes δ: "match_abss' (Var x) t = Some δ"
  shows "∃a ts. t = Fun (Abs a) ts ∧ δ = (λ_. {})(x := {a})"
proof -
  obtain f ts where t: "t = Fun f ts" using δ by (cases t) auto
  then obtain a where a: "f = Abs a" using δ by (cases f) auto
  show ?thesis using δ unfolding t a by simp 
qed

lemma match_abss'_Fun_inv:
  assumes "match_abss' (Fun f ts) (Fun g ss) = Some δ"
  shows "f = g" (is ?A)
    and "length ts = length ss" (is ?B)
    and "∃θ. Some θ = those (map2 match_abss' ts ss) ∧ δ = fun_point_Union_list θ" (is ?C)
    and "∀(t,s) ∈ set (zip ts ss). ∃σ. match_abss' t s = Some σ" (is ?D)
proof -
  note 0 = assms match_abss'.simps(2)[of f ts g ss] option.distinct(1)
  show ?A by (metis 0)
  show ?B by (metis 0)
  show ?C by (metis (no_types, opaque_lifting) 0 map_option_eq_Some)
  thus ?D using map2_those_Some_case[of match_abss' ts ss] by fastforce
qed

lemma match_abss'_FunI:
  assumes Δ: "⋀i. i < length T ⟹ match_abss' (U ! i) (T ! i) = Some (Δ i)"
    and T: "length T = length U"
  shows "match_abss' (Fun f U) (Fun f T) = Some (fun_point_Union_list (map Δ [0..<length T]))"
proof -
  have "match_abss' (Fun f U) (Fun f T) =
          map_option fun_point_Union_list (those (map2 match_abss' U T))"
    using T match_abss'.simps(2)[of f U f T] by presburger
  moreover have "those (map2 match_abss' U T) = Some (map Δ [0..<length T])"
    using Δ T those_map2_SomeI by metis
  ultimately show ?thesis by simp
qed

lemma match_abss'_Fun_param_subset:
  assumes "match_abss' (Fun f ts) (Fun g ss)  = Some δ"
    and "(t,s) ∈ set (zip ts ss)"
    and "match_abss' t s = Some σ"
  shows "σ x ⊆ δ x"
proof -
  obtain θ where θ:
      "those (map2 match_abss' ts ss) = Some θ"
      "δ = fun_point_Union_list θ"
    using match_abss'_Fun_inv[OF assms(1)] by metis

  have "σ ∈ set θ" using θ(1) assms(2-) those_Some_iff[of "map2 match_abss' ts ss" θ] by force
  thus ?thesis using θ(2) unfolding fun_point_Union_list_def by auto
qed

lemma match_abss'_fv_is_nonempty:
  assumes "match_abss' t s = Some δ"
    and "x ∈ fv t"
  shows "δ x ≠ {}" (is "?P δ")
using assms
proof (induction t s arbitrary: δ rule: match_abss'.induct)
  case (2 f ts g ss)
  note prems = "2.prems"
  note IH = "2.IH"

  have 0: "∀(t,s) ∈ set (zip ts ss). ∃σ. match_abss' t s = Some σ" "f = g" "length ts = length ss"
    using match_abss'_Fun_inv[OF prems(1)] by simp_all

  obtain t where t: "t ∈ set ts" "x ∈ fv t" using prems(2) by auto
  then obtain s where s: "s ∈ set ss" "(t,s) ∈ set (zip ts ss)"
    by (meson 0(3) in_set_impl_in_set_zip1 in_set_zipE)
  then obtain σ where σ: "match_abss' t s = Some σ" using 0(1) by fast

  show ?case
    using IH[OF conjI[OF 0(2,3)] s(2) _ σ] t(2) match_abss'_Fun_param_subset[OF prems(1) s(2) σ]
    by auto
qed auto

lemma match_abss'_nonempty_is_fv:
  fixes s t::"(('a,'b,'c,'d) prot_fun, 'v) term"
  assumes "match_abss' s t = Some δ"
    and "δ x ≠ {}"
  shows "x ∈ fv s"
using assms
proof (induction s t arbitrary: δ rule: match_abss'.induct)
  case (2 f ts g ss)
  note prems = "2.prems"
  note IH = "2.IH"

  obtain θ where θ: "Some θ = those (map2 match_abss' ts ss)" "δ = fun_point_Union_list θ"
      and fg: "f = g" "length ts = length ss"
    using match_abss'_Fun_inv[OF prems(1)] by fast

  have "∃σ ∈ set θ. σ x ≠ {}"
    using fg(2) prems θ unfolding fun_point_Union_list_def by auto
  then obtain t' s' σ where ts':
      "(t',s') ∈ set (zip ts ss)" "match_abss' t' s' = Some σ" "σ x ≠ {}"
    using those_map2_SomeD[OF θ(1)[symmetric]] by blast

  show ?case
    using ts'(3) IH[OF conjI[OF fg] ts'(1) _ ts'(2)] set_zip_leftD[OF ts'(1)] by force
qed auto

lemma match_abss'_Abs_in_funs_term:
  fixes s t::"(('a,'b,'c,'d) prot_fun, 'v) term"
  assumes "match_abss' s t = Some δ"
    and "a ∈ δ x"
  shows "Abs a ∈ funs_term t"
using assms
proof (induction s t arbitrary: a δ rule: match_abss'.induct)
  case (1 y b ts) show ?case
    using match_abss'_Var_inv[OF "1.prems"(1)]  "1.prems"(2)
    by (cases "x = y") simp_all
next
  case (2 f ts g ss)
  note prems = "2.prems"
  note IH = "2.IH"

  obtain θ where θ: "Some θ = those (map2 match_abss' ts ss)" "δ = fun_point_Union_list θ"
      and fg: "f = g" "length ts = length ss"
    using match_abss'_Fun_inv[OF prems(1)] by fast

  obtain t' s' σ where ts': "(t',s') ∈ set (zip ts ss)" "match_abss' t' s' = Some σ" "a ∈ σ x"
    using fg(2) prems θ those_map2_SomeD[OF θ(1)[symmetric]]
    unfolding fun_point_Union_list_def by fastforce

  show ?case
    using ts'(1) IH[OF conjI[OF fg] ts'(1) _ ts'(2,3)]
    by (meson set_zip_rightD term.set_intros(2))
qed auto

lemma match_abss'_subst_fv_ex_abs:
  assumes "match_abss' s (s ⋅ δ) = Some σ"
    and TI: "set TI = {(a,b) ∈ (set TI)+. a ≠ b}"
  shows "∀x ∈ fv s. ∃a ts. δ x = Fun (Abs a) ts ∧ σ x = {a}" (is "?P s σ")
using assms(1)
proof (induction s "s ⋅ δ" arbitrary: σ rule: match_abss'.induct)
  case (2 f ts g ss)
  note prems = "2.prems"
  note hyps = "2.hyps"

  obtain θ where θ: "Some θ = those (map2 match_abss' ts ss)" "σ = fun_point_Union_list θ"
      and fg: "f = g" "length ts = length ss" "ss = ts ⋅list δ"
      and ts: "∀(t,s) ∈ set (zip ts ss). ∃σ. match_abss' t s = Some σ"
    using match_abss'_Fun_inv[OF prems(1)[unfolded hyps(2)[symmetric]]] hyps(2) by fastforce

  have 0: "those (map (λt. match_abss' t (t ⋅ δ)) ts) = Some θ"
    using θ(1) map2_map_subst unfolding fg(3) by metis

  have 1: "∀t ∈ set ts. ∃σ. match_abss' t (t ⋅ δ) = Some σ"
    using ts zip_map_subst[of ts δ] unfolding fg(3) by simp

  have 2: "σ' ∈ set θ"
    when t: "t ∈ set ts" "match_abss' t (t ⋅ δ) = Some σ'" for t σ'
    using t 0 those_Some_iff[of "map (λt. match_abss' t (t ⋅ δ)) ts" θ] by force

  have 3: "?P t σ'" "σ' x ≠ {}"
    when t: "t ∈ set ts" "x ∈ fv t" "match_abss' t (t ⋅ δ) = Some σ'" for t σ' x
    using t hyps(1)[OF conjI[OF fg(1,2)], of "(t, t ⋅ δ)" t σ'] zip_map_subst[of ts δ]
          match_abss'_fv_is_nonempty[of t "t ⋅ δ" σ' x]
    unfolding fg(3) by auto

  have 4: "σ' x = {}"
    when t: "x ∉ fv t" "match_abss' t (t ⋅ δ) = Some σ'" for t σ' x
    by (meson t match_abss'_nonempty_is_fv)

  show ?case
  proof
    fix x assume "x ∈ fv (Fun f ts)"
    then obtain t σ' where t: "t ∈ set ts" "x ∈ fv t" and σ': "match_abss' t (t ⋅ δ) = Some σ'"
      using 1 by auto
    then obtain a tsa where a: "δ x = Fun (Abs a) tsa"
      using 3[OF t σ'] by fast

    have "σ'' x = {a} ∨ σ'' x = {}"
      when "σ'' ∈ set θ" for σ''
      using that a 0 3[of _ x] 4[of x]
      unfolding those_Some_iff by fastforce
    thus "∃a ts. δ x = Fun (Abs a) ts ∧ σ x = {a}"
      using a 2[OF t(1) σ'] 3[OF t σ'] unfolding θ(2) fun_point_Union_list_def by auto
  qed
qed auto

lemma match_abss'_subst_disj_nonempty:
  assumes TI: "set TI = {(a,b) ∈ (set TI)+. a ≠ b}"
    and "match_abss' s (s ⋅ δ) = Some σ"
    and "x ∈ fv s"
  shows "⋂(ticl_abs TI ` σ x) ≠ {} ∧ (∃a tsa. δ x = Fun (Abs a) tsa ∧ σ x = {a})" (is "?P σ")
using assms(2,3)
proof (induction s "s ⋅ δ" arbitrary: σ rule: match_abss'.induct)
  case (1 x a ts) thus ?case unfolding ticl_abs_def by force
next
  case (2 f ts g ss)
  note prems = "2.prems"
  note hyps = "2.hyps"

  obtain θ where θ: "Some θ = those (map2 match_abss' ts ss)" "σ = fun_point_Union_list θ"
      and fg: "f = g" "length ts = length ss" "ss = ts ⋅list δ"
      and ts: "∀(t,s) ∈ set (zip ts ss). ∃σ. match_abss' t s = Some σ"
    using match_abss'_Fun_inv[OF prems(1)[unfolded hyps(2)[symmetric]]] hyps(2) by fastforce

  define ts' where "ts' ≡ filter (λt. x ∈ fv t) ts"
  define θ' where "θ' ≡ map (λt. (t, the (match_abss' t (t ⋅ δ)))) ts"
  define θ'' where "θ'' ≡ map (λt. the (match_abss' t (t ⋅ δ))) ts'"

  have 0: "those (map (λt. match_abss' t (t ⋅ δ)) ts) = Some θ"
    using θ(1) map2_map_subst unfolding fg(3) by metis

  have 1: "∀t ∈ set ts. ∃σ. match_abss' t (t ⋅ δ) = Some σ"
    using ts zip_map_subst[of ts δ] unfolding fg(3) by simp

  have ts_not_nil: "ts ≠ []"
    using prems(2) by fastforce
  hence "∃t ∈ set ts. x ∈ fv t" using prems(2) by simp
  then obtain a tsa where a: "δ x = Fun (Abs a) tsa" 
    using 1 match_abss'_subst_fv_ex_abs[OF _ TI, of _ δ]
    by metis
  hence a': "σ' x = {a}"
    when "t ∈ set ts" "x ∈ fv t" "match_abss' t (t ⋅ δ) = Some σ'"
    for t σ'
    using that match_abss'_subst_fv_ex_abs[OF _ TI, of _ δ]
    by fastforce

  have "ts' ≠ []" using prems(2) unfolding ts'_def by (simp add: filter_empty_conv) 
  hence θ''_not_nil: "θ'' ≠ []" unfolding θ''_def by simp

  have 2: "σ' ∈ set θ"
    when t: "t ∈ set ts" "match_abss' t (t ⋅ δ) = Some σ'" for t σ'
    using t 0 those_Some_iff[of "map (λt. match_abss' t (t ⋅ δ)) ts" θ] by force

  have 3: "?P σ'" "σ' x ≠ {}"
    when t: "t ∈ set ts'" "match_abss' t (t ⋅ δ) = Some σ'" for t σ'
    using t hyps(1)[OF conjI[OF fg(1,2)], of "(t, t ⋅ δ)" t σ'] zip_map_subst[of ts δ]
          match_abss'_fv_is_nonempty[of t "t ⋅ δ" σ' x]
    unfolding fg(3) ts'_def by (force, force)

  have 4: "σ' x = {}"
    when t: "x ∉ fv t" "match_abss' t (t ⋅ δ) = Some σ'" for t σ'
    by (meson t match_abss'_nonempty_is_fv)

  have 5: "θ = map snd θ'"
    using 0 1 unfolding θ'_def by (induct ts arbitrary: θ) auto

  have "fun_point_Union_list (map snd θ') x =
        fun_point_Union_list (map snd (filter (λ(t,_). x ∈ fv t) θ')) x"
    using 1 4 unfolding θ'_def fun_point_Union_list_def by fastforce
  hence 6: "fun_point_Union_list θ x = fun_point_Union_list θ'' x"
    using 0 1 4 unfolding 5 θ'_def θ''_def fun_point_Union_list_def ts'_def by auto

  have 7: "?P σ'" "σ' x ≠ {}"
    when σ': "σ' ∈ set θ''" for σ'
    using that 1 3 unfolding θ''_def ts'_def by auto

  have "σ' x = {a}"
    when σ': "σ' ∈ set θ''" for σ'
    using σ' a' 1 unfolding θ''_def ts'_def by fastforce
  hence "fun_point_Union_list θ'' x = {b | b σ'. σ' ∈ set θ'' ∧ b ∈ {a}}"
    using θ''_not_nil unfolding fun_point_Union_list_def by auto
  hence 8: "fun_point_Union_list θ'' x = {a}"
    using θ''_not_nil by auto

  show ?case
    using 8 a
    unfolding θ(2) 6 ticl_abs_iff[OF TI] by auto
qed simp_all

lemma match_abssD:
  fixes OCC TI s
  defines "f ≡ (λδ x. if x ∈ fv s then δ x else set OCC)"
    and "g ≡ (λδ x. ⋂(ticl_abs TI ` δ x))"
  assumes δ': "match_abss OCC TI s t = Some δ'" 
  shows "∃δ. match_abss' s t = Some δ ∧ δ' = f (g δ) ∧ (∀x ∈ fv s. δ x ≠ {} ∧ f (g δ) x ≠ {}) ∧
             (set OCC ≠ {} ⟶ (∀x. f (g δ) x ≠ {}))"
proof -
  obtain δ where δ: "match_abss' s t = Some δ"
    using δ' unfolding match_abss_def by force
  hence "Some δ' = (if ∀x ∈ fv s. g δ x ≠ {} then Some (f (g δ)) else None)"
    using δ' unfolding match_abss_def f_def g_def Let_def by simp
  hence "δ' = f (g δ)" "∀x ∈ fv s. δ x ≠ {} ∧ f (g δ) x ≠ {}"
    by (metis (no_types, lifting) option.inject option.distinct(1),
        metis (no_types, lifting) f_def option.distinct(1) match_abss'_fv_is_nonempty[OF δ])
  thus ?thesis using δ unfolding f_def by force
qed

lemma match_abss_ticl_abs_Inter_subset:
  assumes TI: "set TI = {(a,b). (a,b) ∈ (set TI)+ ∧ a ≠ b}"
    and δ: "match_abss OCC TI s t = Some δ"
    and x: "x ∈ fv s"
  shows "⋂(ticl_abs TI ` δ x) ⊆ δ x"
proof -
  let ?h1 = "λδ x. if x ∈ fv s then δ x else set OCC"
  let ?h2 = "λδ x. ⋂(ticl_abs TI ` δ x)"

  obtain δ' where δ':
      "match_abss' s t = Some δ'" "δ = ?h1 (?h2 δ')"
      "∀x ∈ fv s. δ' x ≠ {} ∧ δ x ≠ {}"
    using match_abssD[OF δ] by blast

  have "δ x = ⋂(ticl_abs TI ` δ' x)" "δ' x ≠ {}" "δ x ≠ {}"
    using x δ'(2,3) by auto
  thus ?thesis
    using ticl_abs_Inter TI by simp
qed

lemma match_abss_fv_has_abs:
  assumes "match_abss OCC TI s t = Some δ"
    and "x ∈ fv s"
  shows "δ x ≠ {}"
using assms match_abssD by fast

lemma match_abss_OCC_if_not_fv:
  fixes s t::"(('a,'b,'c,'d) prot_fun, 'v) term"
  assumes δ': "match_abss OCC TI s t = Some δ'"
    and x: "x ∉ fv s"
  shows "δ' x = set OCC"
proof -
  define f where "f ≡ λs::(('a,'b,'c,'d) prot_fun, 'v) term. λδ x. if x ∈ fv s then δ x else set OCC"
  define g where "g ≡ λδ. λx::'v. ⋂(ticl_abs TI ` δ x)"

  obtain δ where δ: "match_abss' s t = Some δ" "δ' = f s (g δ)"
    using match_abssD[OF δ'] unfolding f_def g_def by blast

  show ?thesis
    using x δ(2) unfolding f_def by presburger
qed

inductive synth_abs_substs_constrs_rel for FP OCC TI where
  SolveNil:
    "synth_abs_substs_constrs_rel FP OCC TI [] (λ_. set OCC)"
| SolveCons:
    "ts ≠ [] ⟹ ∀t ∈ set ts. synth_abs_substs_constrs_rel FP OCC TI [t] (θ t)
      ⟹ synth_abs_substs_constrs_rel FP OCC TI ts (fun_point_Inter (θ ` set ts))"
| SolvePubConst:
    "arity c = 0 ⟹ public c
      ⟹ synth_abs_substs_constrs_rel FP OCC TI [Fun c []] (λ_. set OCC)"
| SolvePrivConstIn:
    "arity c = 0 ⟹ ¬public c ⟹ Fun c [] ∈ set FP
      ⟹ synth_abs_substs_constrs_rel FP OCC TI [Fun c []] (λ_. set OCC)"
| SolvePrivConstNotin:
    "arity c = 0 ⟹ ¬public c ⟹ Fun c [] ∉ set FP
      ⟹ synth_abs_substs_constrs_rel FP OCC TI [Fun c []] (λ_. {})"
| SolveValueVar:
    "θ = ((λ_. set OCC)(x := ticl_abss TI {a ∈ set OCC. ⟨a⟩abs ∈ set FP}))
      ⟹ synth_abs_substs_constrs_rel FP OCC TI [Var x] θ"
| SolvePubComposed:
    "arity f > 0 ⟹ public f ⟹ length ts = arity f
      ⟹ ∀δ. δ ∈ Δ ⟷ (∃s ∈ set FP. match_abss OCC TI (Fun f ts) s = Some δ)
      ⟹ θ1 = fun_point_Union Δ
      ⟹ synth_abs_substs_constrs_rel FP OCC TI ts θ2
      ⟹ synth_abs_substs_constrs_rel FP OCC TI [Fun f ts] (fun_point_union θ1 θ2)"
| SolvePrivComposed:
    "arity f > 0 ⟹ ¬public f ⟹ length ts = arity f
      ⟹ ∀δ. δ ∈ Δ ⟷ (∃s ∈ set FP. match_abss OCC TI (Fun f ts) s = Some δ)
      ⟹ θ = fun_point_Union Δ
      ⟹ synth_abs_substs_constrs_rel FP OCC TI [Fun f ts] θ"

fun synth_abs_substs_constrs_aux where
  "synth_abs_substs_constrs_aux FP OCC TI (Var x) = (
    (λ_. set OCC)(x := ticl_abss TI (set (filter (λa. ⟨a⟩abs ∈ set FP) OCC))))"
| "synth_abs_substs_constrs_aux FP OCC TI (Fun f ts) = (
    if ts = []
    then (if ¬public f ∧ Fun f ts ∉ set FP then (λ_. {}) else (λ_. set OCC))
    else (let Δ = map the (filter (λδ. δ ≠ None) (map (match_abss OCC TI (Fun f ts)) FP));
              θ1 = fun_point_Union_list Δ;
              θ2 = fun_point_Inter_list (
                    case ts of t#ts' ⇒ 
                      if ¬is_Var t ∧ args t = [] ∧ ¬public (the_Fun t)
                      then (if t ∉ set FP then [λ_. {}]
                            else (λ_. set OCC)#map (synth_abs_substs_constrs_aux FP OCC TI) ts')
                      else map (synth_abs_substs_constrs_aux FP OCC TI) ts
                   )
          in fun_point_union θ1 θ2))"

lemma synth_abs_substs_constrs_aux_fun_case:
  assumes ts: "ts ≠ []"
  shows "synth_abs_substs_constrs_aux FP OCC TI (Fun f ts) = (
    let Δ = map the (filter (λδ. δ ≠ None) (map (match_abss OCC TI (Fun f ts)) FP));
        θ1 = fun_point_Union_list Δ;
        θ2 = fun_point_Inter_list (map (synth_abs_substs_constrs_aux FP OCC TI) ts)
    in fun_point_union θ1 θ2)"
proof -
  let ?s = "synth_abs_substs_constrs_aux FP OCC TI"
  let ?P = "λt. ¬is_Var t ∧ args t = [] ∧ ¬public (the_Fun t)"

  obtain t ts' where ts': "ts = t#ts'" using ts by (cases ts) auto

  have "fun_point_Inter_list ((λ_. {})#map ?s ts') = fun_point_Inter_list [λ_. {}]"
    unfolding fun_point_Inter_list_def by simp
  thus ?thesis unfolding ts' by (cases "?P t") auto
qed

definition synth_abs_substs_constrs where
  "synth_abs_substs_constrs FPT T ≡
    let (FP,OCC,TI) = FPT;
        ts = trms_listsst (unlabel (transaction_receive T));
        f = fun_point_Inter_list ∘ map (synth_abs_substs_constrs_aux FP OCC TI)
    in if ts = [] then (λ_. set OCC) else f ts"

(* definition synth_abs_substs_constrs where
  "synth_abs_substs_constrs FPT T ≡
    let (FP,OCC,TI) = FPT;
        negsy = Not ∘ intruder_synth_mod_timpls FP TI;
        Θ = λδ x. let as = δ x in if as ≠ {} then as else set OCC;
        C = unlabel (transaction_checks T);
        poss = transaction_poschecks_comp C;
        negs = transaction_negchecks_comp C;
        ts = trms_listsst (unlabel (transaction_receive T));
        f = λt. let Δ = map the (filter (λδ. δ ≠ None) (map (match_abss OCC TI t) FP))
                in fun_point_Union_list (map Θ Δ);
        g = λt. if is_Fun t ∧ args t ≠ []
                then let s = hd (args t)
                in case fv_list s of
                   [] ⇒ if negsy s then Some (f t) else None
                 | [x] ⇒ let bs = filter (λa. poss x ⊆ a ∧ a ∩ negs x = {}) OCC
                          in if list_all (λb. negsy (s ⋅ Var(x := ⟨b⟩abs))) bs
                             then Some (f t) else None
                 | _ ⇒ None
                else None;
        h = λt. case g t of Some d ⇒ d | None ⇒ synth_abs_substs_constrs_aux FP OCC TI t
    in if ts = [] then (λ_. set OCC) else fun_point_Inter_list (map h ts)" *)
(*
poss = transaction_poschecks_comp (C A);
      negs = transaction_negchecks_comp (C A);
      bs = filter (λa. poss PK ⊆ a ∧ a ∩ negs PK = {}) OCC
    in if list_all (Not ∘ sy ∘ s A) bs
       then Some (map the (filter (λδ. δ ≠ None) (map (match_abss OCC TI (t' A)) FP)))
       else None
*)
definition transaction_check_comp::
  "[('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set ⇒ bool,
    ('fun,'atom,'sets,'lbl) prot_term list ×
    'sets set list ×
    ('sets set × 'sets set) list,
    ('fun,'atom,'sets,'lbl) prot_transaction]
  ⇒ ((('fun,'atom,'sets,'lbl) prot_var × 'sets set) list) list"
where
  "transaction_check_comp msgcs FPT T ≡
    let (_, OCC, _) = FPT;
        S = unlabel (transaction_strand T);
        C = unlabel (transaction_checks T);
        xs = filter (λx. x ∉ set (transaction_fresh T) ∧ fst x = TAtom Value) (fv_listsst S);
        posconstrs = transaction_poschecks_comp C;
        negconstrs = transaction_negchecks_comp C;
        pre_check = transaction_check_pre FPT T;
        Δ = abs_substs_set xs OCC posconstrs negconstrs msgcs
    in filter (λδ. pre_check (abs_substs_fun δ)) Δ"

definition transaction_check'::
  "[('fun,'atom,'sets,'lbl) prot_var ⇒ 'sets set ⇒ bool,
    ('fun,'atom,'sets,'lbl) prot_term list ×
    'sets set list ×
    ('sets set × 'sets set) list,
    ('fun,'atom,'sets,'lbl) prot_transaction]
  ⇒ bool"
where
  "transaction_check' msgcs FPT T ≡
    list_all (λδ. transaction_check_post FPT T (abs_substs_fun δ))
             (transaction_check_comp msgcs FPT T)"

definition transaction_check::
  "[('fun,'atom,'sets,'lbl) prot_term list ×
    'sets set list ×
    ('sets set × 'sets set) list,
    ('fun,'atom,'sets,'lbl) prot_transaction]
  ⇒ bool"
where
  "transaction_check ≡ transaction_check' (λ_ _. True)"

definition transaction_check_coverage_rcv::
  "[('fun,'atom,'sets,'lbl) prot_term list ×
    'sets set list ×
    ('sets set × 'sets set) list,
    ('fun,'atom,'sets,'lbl) prot_transaction]
  ⇒ bool"
where
  "transaction_check_coverage_rcv FPT T ≡
    let msgcs = synth_abs_substs_constrs FPT T
    in transaction_check' (λx a. a ∈ msgcs x) FPT T"

lemma abs_subst_fun_cons:
  "abs_substs_fun ((x,b)#δ) = (abs_substs_fun δ)(x := b)"
unfolding abs_substs_fun_def by fastforce

lemma abs_substs_cons:
  assumes "δ ∈ set (abs_substs_set xs as poss negs msgcs)"
          "b ∈ set as" "poss x ⊆ b" "b ∩ negs x = {}" "msgcs x b"
  shows "(x,b)#δ ∈ set (abs_substs_set (x#xs) as poss negs msgcs)"
using assms by auto

lemma abs_substs_cons':
  assumes δ: "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
    and b: "b ∈ set as" "poss x ⊆ b" "b ∩ negs x = {}" "msgcs x b"
  shows "δ(x := b) ∈ abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs msgcs)"
proof -
  obtain θ where θ: "δ = abs_substs_fun θ" "θ ∈ set (abs_substs_set xs as poss negs msgcs)"
    using δ by force
  have "abs_substs_fun ((x, b)#θ) ∈ abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs msgcs)"
    using abs_substs_cons[OF θ(2) b] by blast
  thus ?thesis
    using θ(1) abs_subst_fun_cons[of x b θ] by argo
qed

lemma abs_substs_has_abs:
  assumes "∀x. x ∈ set xs ⟶ δ x ∈ set as"
    and "∀x. x ∈ set xs ⟶ poss x ⊆ δ x"
    and "∀x. x ∈ set xs ⟶ δ x ∩ negs x = {}"
    and "∀x. x ∈ set xs ⟶ msgcs x (δ x)"
    and "∀x. x ∉ set xs ⟶ δ x = {}"
  shows "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
using assms
proof (induction xs arbitrary: δ)
  case (Cons x xs)
  define θ where "θ ≡ λy. if y ∈ set xs then δ y else {}"

  have "θ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
    using Cons.prems Cons.IH by (simp add: θ_def)
  moreover have "δ x ∈ set as" "poss x ⊆ δ x" "δ x ∩ negs x = {}" "msgcs x (δ x)"
    by (simp_all add: Cons.prems(1,2,3,4))
  ultimately have 0: "θ(x := δ x) ∈ abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs msgcs)"
    by (metis abs_substs_cons')

  have "δ = θ(x := δ x)"
  proof
    fix y show "δ y = (θ(x := δ x)) y"
    proof (cases "y ∈ set (x#xs)")
      case False thus ?thesis using Cons.prems(5) by (fastforce simp add: θ_def)
    qed (auto simp add: θ_def)
  qed
  thus ?case by (metis 0)
qed (auto simp add: abs_substs_fun_def)

lemma abs_substs_abss_bounded:
  assumes "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
    and "x ∈ set xs"
  shows "δ x ∈ set as"
    and "poss x ⊆ δ x"
    and "δ x ∩ negs x = {}"
    and "msgcs x (δ x)"
using assms
proof (induct xs as poss negs msgcs arbitrary: δ rule: abs_substs_set_induct)
  case (Cons y xs as poss negs msgcs)
  { case 1 thus ?case using Cons.hyps(1) unfolding abs_substs_fun_def by fastforce }

  { case 2 thus ?case
    proof (cases "x = y")
      case False
      then obtain δ' where δ':
          "δ' ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)" "δ' x = δ x"
        using 2 unfolding abs_substs_fun_def by force
      moreover have "x ∈ set xs" using 2(2) False by simp
      moreover have "∃b. b ∈ set as ∧ poss y ⊆ b ∧ b ∩ negs y = {}"
        using 2 False by auto
      ultimately show ?thesis using Cons.hyps(2) by fastforce
    qed (auto simp add: abs_substs_fun_def)
  }

  { case 3 thus ?case
    proof (cases "x = y")
      case False
      then obtain δ' where δ':
          "δ' ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)" "δ' x = δ x"
        using 3 unfolding abs_substs_fun_def by force
      moreover have "x ∈ set xs" using 3(2) False by simp
      moreover have "∃b. b ∈ set as ∧ poss y ⊆ b ∧ b ∩ negs y = {}"
        using 3 False by auto
      ultimately show ?thesis using Cons.hyps(3) by fastforce
    qed (auto simp add: abs_substs_fun_def)
  }

  { case 4 thus ?case
    proof (cases "x = y")
      case False
      then obtain δ' where δ':
          "δ' ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)" "δ' x = δ x"
        using 4 unfolding abs_substs_fun_def by force
      moreover have "x ∈ set xs" using 4(2) False by simp
      moreover have "∃b. b ∈ set as ∧ poss y ⊆ b ∧ b ∩ negs y = {}"
        using 4 False by auto
      ultimately show ?thesis using Cons.hyps(4) by fastforce
    qed (auto simp add: abs_substs_fun_def)
  }
qed (simp_all add: abs_substs_fun_def)

lemma abs_substs_abss_bounded':
  assumes "δ ∈ abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
    and "x ∉ set xs"
  shows "δ x = {}"
using assms unfolding abs_substs_fun_def
by (induct xs as poss negs msgcs arbitrary: δ rule: abs_substs_set_induct) (force, fastforce)

lemma transaction_poschecks_comp_unfold:
  "transaction_poschecks_comp C x = {s. ∃a. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ set C}"
proof (induction C)
  case (Cons c C) thus ?case
  proof (cases "∃a y s. c = ⟨a: Var y ∈ Fun (Set s) []⟩")
    case True
    then obtain a y s where c: "c = ⟨a: Var y ∈ Fun (Set s) []⟩" by force

    define f where "f ≡ transaction_poschecks_comp C"

    have "transaction_poschecks_comp (c#C) = f(y := insert s (f y))"
      using c by (simp add: f_def Let_def)
    moreover have "f x = {s. ∃a. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ set C}"
      using Cons.IH unfolding f_def by blast
    ultimately show ?thesis using c by auto
  next
    case False
    hence "transaction_poschecks_comp (c#C) = transaction_poschecks_comp C" (is ?P)
      using transaction_poschecks_comp.cases[of "c#C" ?P] by force
    thus ?thesis using False Cons.IH by auto
  qed
qed simp

lemma transaction_poschecks_comp_notin_fv_empty:
  assumes "x ∉ fvsst C"
  shows "transaction_poschecks_comp C x = {}"
using assms transaction_poschecks_comp_unfold[of C x] by fastforce

lemma transaction_negchecks_comp_unfold:
  "transaction_negchecks_comp C x = {s. ⟨Var x not in Fun (Set s) []⟩ ∈ set C}"
proof (induction C)
  case (Cons c C) thus ?case
  proof (cases "∃y s. c = ⟨Var y not in Fun (Set s) []⟩")
    case True
    then obtain y s where c: "c = ⟨Var y not in Fun (Set s) []⟩" by force

    define f where "f ≡ transaction_negchecks_comp C"

    have "transaction_negchecks_comp (c#C) = f(y := insert s (f y))"
      using c by (simp add: f_def Let_def)
    moreover have "f x = {s. ⟨Var x not in Fun (Set s) []⟩ ∈ set C}"
      using Cons.IH unfolding f_def by blast
    ultimately show ?thesis using c by auto
  next
    case False
    hence "transaction_negchecks_comp (c#C) = transaction_negchecks_comp C" (is ?P)
      using transaction_negchecks_comp.cases[of "c#C" ?P] 
      by force
    thus ?thesis using False Cons.IH by fastforce
  qed
qed simp  

lemma transaction_negchecks_comp_notin_fv_empty:
  assumes "x ∉ fvsst C"
  shows "transaction_negchecks_comp C x = {}"
using assms transaction_negchecks_comp_unfold[of C x] by fastforce

lemma transaction_check_preI[intro]:
  fixes T
  defines "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
    and "C ≡ set (unlabel (transaction_checks T))"
  assumes a0: "∀x ∈ set (transaction_fresh T). δ x = {}"
    and a1: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ δ x ∈ set OCC"
    and a2: "∀t ∈ trmslsst (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ δ)"
    and a3: "∀a x s. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ C ⟶ s ∈ δ x"
    and a4: "∀x s. ⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ δ x"
  shows "transaction_check_pre (FP, OCC, TI) T δ"
proof -
  let ?P = "λu. is_InSet u ⟶ (
    let x = the_elem_term u; s = the_set_term u
    in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∈ δ (the_Var x))"

  let ?Q = "λu. (is_NegChecks u ∧ bvarssstp u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1) ⟶ (
    let x = fst (hd (the_ins u)); s = snd (hd (the_ins u))
    in (is_Var x ∧ is_Fun_Set s) ⟶ the_Set (the_Fun s) ∉ δ (the_Var x))"

  have 1: "?P u" when u: "u ∈ C" for u
    apply (unfold Let_def, intro impI, elim conjE)
    using u a3 Fun_Set_InSet_iff[of u] by metis

  have 2: "?Q u" when u: "u ∈ C" for u
    apply (unfold Let_def, intro impI, elim conjE)
    using u a4 Fun_Set_NotInSet_iff[of u] by metis

  show ?thesis
    using a0 a1 a2 1 2 fv_listsst_is_fvsst[of "unlabel (transaction_strand T)"]
    unfolding transaction_check_pre_def θ_def C_def Let_def
    by blast
qed

lemma transaction_check_pre_InSetE:
  assumes T: "transaction_check_pre FPT T δ"
    and u: "u = ⟨a: Var x ∈ Fun (Set s) []⟩"
           "u ∈ set (unlabel (transaction_checks T))"
  shows "s ∈ δ x"
proof -
  have "is_InSet u ⟶ is_Var (the_elem_term u) ∧ is_Fun_Set (the_set_term u) ⟶
        the_Set (the_Fun (the_set_term u)) ∈ δ (the_Var (the_elem_term u))"
    using T u unfolding transaction_check_pre_def Let_def by blast
  thus ?thesis using Fun_Set_InSet_iff[of u a x s] u by argo
qed

lemma transaction_check_pre_NotInSetE:
  assumes T: "transaction_check_pre FPT T δ"
    and u: "u = ⟨Var x not in Fun (Set s) []⟩"
           "u ∈ set (unlabel (transaction_checks T))"
  shows "s ∉ δ x"
proof -
  have "is_NegChecks u ∧ bvarssstp u = [] ∧ the_eqs u = [] ∧ length (the_ins u) = 1 ⟶
         is_Var (fst (hd (the_ins u))) ∧ is_Fun_Set (snd (hd (the_ins u))) ⟶
         the_Set (the_Fun (snd (hd (the_ins u)))) ∉ δ (the_Var (fst (hd (the_ins u))))"
    using T u unfolding transaction_check_pre_def Let_def by blast
  thus ?thesis using Fun_Set_NotInSet_iff[of u  x s] u by argo
qed

lemma transaction_check_pre_ReceiveE:
  defines "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
  assumes T: "transaction_check_pre (FP, OCC, TI) T δ"
    and t: "t ∈ trmslsst (transaction_receive T)"
  shows "intruder_synth_mod_timpls FP TI (t ⋅ θ δ)"
using T t unfolding transaction_check_pre_def Let_def θ_def by blast

lemma transaction_check_compI[intro]:
  assumes T: "transaction_check_pre (FP, OCC, TI) T δ"
    and T_adm: "admissible_transaction' T"
    and x1: "∀x. (x ∈ fv_transaction T - set (transaction_fresh T) ∧ fst x = TAtom Value)
                  ⟶ δ x ∈ set OCC ∧ msgcs x (δ x)"
    and x2: "∀x. (x ∉ fv_transaction T - set (transaction_fresh T) ∨ fst x ≠ TAtom Value)
                  ⟶ δ x = {}"
  shows "δ ∈ abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T)"
proof -
  define S where "S ≡ unlabel (transaction_strand T)"
  define C where "C ≡ unlabel (transaction_checks T)"

  let ?xs = "fv_listsst S"

  define poss where "poss ≡ transaction_poschecks_comp C"
  define negs where "negs ≡ transaction_negchecks_comp C"
  define ys where "ys ≡ filter (λx. x ∉ set (transaction_fresh T) ∧ fst x = TAtom Value) ?xs"

  have ys: "{x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value} = set ys"
    using fv_listsst_is_fvsst[of S]
    unfolding ys_def S_def by force
  
  have "δ x ∈ set OCC" "msgcs x (δ x)"
    when x: "x ∈ set ys" for x
    using x1 x ys by (blast, blast)
  moreover have "δ x = {}"
    when x: "x ∉ set ys" for x
    using x2 x ys by blast
  moreover have "poss x ⊆ δ x" when x: "x ∈ set ys" for x
  proof -
    have "s ∈ δ x" when u: "u = ⟨a: Var x ∈ Fun (Set s) []⟩" "u ∈ set C" for u a s
      using T u transaction_check_pre_InSetE[of "(FP, OCC, TI)" T δ]
      unfolding C_def by blast
    thus ?thesis
      using transaction_poschecks_comp_unfold[of C x]
      unfolding poss_def by blast
  qed
  moreover have "δ x ∩ negs x = {}" when x: "x ∈ set ys" for x
  proof (cases "x ∈ fvsst C")
    case True
    hence "s ∉ δ x" when u: "u = ⟨Var x not in Fun (Set s) []⟩" "u ∈ set C" for u s
      using T u transaction_check_pre_NotInSetE[of "(FP, OCC, TI)" T δ]
      unfolding C_def by blast
    thus ?thesis
      using transaction_negchecks_comp_unfold[of C x]
      unfolding negs_def by blast
  next
    case False
    hence "negs x = {}"
      using x transaction_negchecks_comp_notin_fv_empty
      unfolding negs_def by blast
    thus ?thesis by blast
  qed
  ultimately have "δ ∈ abs_substs_fun ` set (abs_substs_set ys OCC poss negs msgcs)"
    using abs_substs_has_abs[of ys δ OCC poss negs msgcs]
    by fast
  thus ?thesis
    using T
    unfolding transaction_check_comp_def Let_def S_def C_def ys_def poss_def negs_def
    by fastforce
qed

context
begin
private lemma transaction_check_comp_in_aux:
  fixes T
  defines "C ≡ set (unlabel (transaction_checks T))"
  assumes T_adm: "admissible_transaction' T"
    and a1: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
          select⟨Var x, Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x)"
    and a2: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
          ⟨Var x in Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x)"
    and a3: "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
          ⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α x)"
  shows "∀a x s. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x" (is ?A)
    and "∀x s. ⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α x" (is ?B)
proof -
  note * = admissible_transaction_strand_step_cases(2,3)[OF T_adm]

  have 1: "fst x = TAtom Value" "x ∈ fv_transaction T - set (transaction_fresh T)"
    when x: "⟨a: Var x ∈ Fun (Set s) []⟩ ∈ C" for a x s
    using * x unfolding C_def by fast+

  have 2: "fst x = TAtom Value" "x ∈ fv_transaction T - set (transaction_fresh T)"
    when x: "⟨Var x not in Fun (Set s) []⟩ ∈ C" for x s
    using * x unfolding C_def by fast+

  show ?A
  proof (intro allI impI)
    fix a x s assume u: "⟨a: Var x ∈ Fun (Set s) []⟩ ∈ C"
    thus "s ∈ α x" using 1 a1 a2 by (cases a) metis+
  qed

  show ?B
  proof (intro allI impI)
    fix x s assume u: "⟨Var x not in Fun (Set s) []⟩ ∈ C"
    thus "s ∉ α x" using 2 a3 by meson
  qed
qed

lemma transaction_check_comp_in:
  fixes T
  defines "θ ≡ λδ x. if fst x = TAtom Value then (absc ∘ δ) x else Var x"
    and "C ≡ set (unlabel (transaction_checks T))"
  assumes T_adm: "admissible_transaction' T"
    and a1: "∀x ∈ set (transaction_fresh T). α x = {}"
    and a2: "∀t ∈ trmslsst (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ α)"
    and a3: "∀x ∈ fv_transaction T - set (transaction_fresh T). ∀s.
          select⟨Var x, Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x"
    and a4: "∀x ∈ fv_transaction T - set (transaction_fresh T). ∀s.
          ⟨Var x in Fun (Set s) []⟩ ∈ C ⟶ s ∈ α x"
    and a5: "∀x ∈ fv_transaction T - set (transaction_fresh T). ∀s.
          ⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α x"
    and a6: "∀x ∈ fv_transaction T - set (transaction_fresh T).
          fst x = TAtom Value ⟶ α x ∈ set OCC"
    and a7: "∀x ∈ fv_transaction T - set (transaction_fresh T).
          fst x = TAtom Value ⟶ msgcs x (α x)"
  shows "∃δ ∈ abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T).
          ∀x ∈ fv_transaction T. fst x = TAtom Value ⟶ α x = δ x"
proof -
  let ?xs = "fv_listsst (unlabel (transaction_strand T))"
  let ?ys = "filter (λx. x ∉ set (transaction_fresh T)) ?xs"

  define α' where "α' ≡ λx.
    if x ∈ fv_transaction T - set (transaction_fresh T) ∧ fst x = TAtom Value
    then α x
    else {}"

  note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]

  have θα_Fun: "is_Fun (t ⋅ θ α) ⟷ is_Fun (t ⋅ θ α')" for t
    unfolding α'_def θ_def
    by (induct t) auto

  have "∀t ∈ trmslsst (transaction_receive T). intruder_synth_mod_timpls FP TI (t ⋅ θ α')"
  proof (intro ballI impI)
    fix t assume t: "t ∈ trmslsst (transaction_receive T)"

    have 1: "intruder_synth_mod_timpls FP TI (t ⋅ θ α)"
      using t a2
      by auto

    obtain r where r:
        "r ∈ set (unlabel (transaction_receive T))"
        "t ∈ trmssstp r"
      using t by auto
    hence "∃ts. r = receive⟨ts⟩ ∧ t ∈ set ts"
      using wellformed_transaction_unlabel_cases(1)[OF T_wf]
      by fastforce
    hence 2: "fv t ⊆ fvlsst (transaction_receive T)" using r by force

    have "fv t ⊆ fv_transaction T"
      by (metis (no_types, lifting) 2 transaction_strand_def sst_vars_append_subset(1)
                unlabel_append subset_Un_eq sup.bounded_iff)
    moreover have "fv t ∩ set (transaction_fresh T) = {}"
      using 2 T_wf varssst_is_fvsst_bvarssst[of "unlabel (transaction_receive T)"]
      unfolding wellformed_transaction_def
      by fast
    ultimately have "θ α x = θ α' x" when "x ∈ fv t" for x
      using that unfolding α'_def θ_def by fastforce
    hence 3: "t ⋅ θ α = t ⋅ θ α'"
      using term_subst_eq by blast

    show "intruder_synth_mod_timpls FP TI (t ⋅ θ α')" using 1 3 by simp
  qed
  moreover have
      "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
          select⟨Var x, Fun (Set s) []⟩ ∈ C ⟶ s ∈ α' x)"
      "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
          ⟨Var x in Fun (Set s) []⟩ ∈ C ⟶ s ∈ α' x)"
      "∀x ∈ fv_transaction T - set (transaction_fresh T). fst x = TAtom Value ⟶ (∀s.
          ⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α' x)"
    using a3 a4 a5
    unfolding α'_def θ_def C_def
    by meson+
  hence "∀a x s. ⟨a: Var x ∈ Fun (Set s) []⟩ ∈ C ⟶ s ∈ α' x"
        "∀x s. ⟨Var x not in Fun (Set s) []⟩ ∈ C ⟶ s ∉ α' x"
    using transaction_check_comp_in_aux[OF T_adm, of α']
    unfolding C_def
    by (fast, fast)
  ultimately have 4: "transaction_check_pre (FP, OCC, TI) T α'"
    using a6 transaction_check_preI[of T α' OCC FP TI]
    unfolding α'_def θ_def C_def
    by simp

  have 5: "∀x ∈ fv_transaction T. fst x = TAtom Value ⟶ α x = α' x"
    using a1 by (auto simp add: α'_def)

  have 6: "α' ∈ abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T)"
    using transaction_check_compI[OF 4 T_adm, of msgcs] a6 a7
    unfolding α'_def 
    by auto

  show ?thesis using 5 6 by blast
qed
end

lemma transaction_check_trivial_case:
  assumes "transaction_updates T = []"
    and "transaction_send T = []"
  shows "transaction_check FPT T"
using assms
by (simp add: list_all_iff transaction_check_def transaction_check'_def transaction_check_post_def)

end


subsection ‹Soundness of the Occurs-Message Transformation›
context stateful_protocol_model
begin

context
begin

text ‹The occurs-message transformation, ‹add_occurs_msgs›, extends a transaction ‹T› with
additional message-transmission steps such that the following holds:
1. for each fresh variable ‹x› of ‹T› the message ‹occurs (Var x)› now occurs in a send-step,
2. for each of the remaining free variables ‹x› of ‹T› the message ‹occurs (Var x)› now occurs in a
receive-step.›
definition add_occurs_msgs where
  "add_occurs_msgs T ≡
    let frsh = transaction_fresh T;
        xs = filter (λx. x ∉ set frsh) (fv_listsst (unlabel (transaction_strand T)));
        f = map (λx. occurs (Var x));
        g = λC. if xs = [] then C else ⟨⋆, receive⟨f xs⟩⟩#C;
        h = λF. if frsh = [] then F
                else if F ≠ [] ∧ fst (hd F) = ⋆ ∧ is_Send (snd (hd F))
                then ⟨⋆,send⟨f frsh@the_msgs (snd (hd F))⟩⟩#tl F
                else ⟨⋆,send⟨f frsh⟩⟩#F
    in case T of Transaction A B C D E F ⇒ Transaction A B (g C) D E (h F)"

private fun rm_occurs_msgs_constr where
  "rm_occurs_msgs_constr [] = []"
| "rm_occurs_msgs_constr ((l,receive⟨ts⟩)#A) = (
    if ∃t. occurs t ∈ set ts
    then if ∃t ∈ set ts. ∀s. t ≠ occurs s
         then (l,receive⟨filter (λt. ∀s. t ≠ occurs s) ts⟩)#rm_occurs_msgs_constr A
         else rm_occurs_msgs_constr A
    else (l,receive⟨ts⟩)#rm_occurs_msgs_constr A)"
| "rm_occurs_msgs_constr ((l,send⟨ts⟩)#A) = (
    if ∃t. occurs t ∈ set ts
    then if ∃t ∈ set ts. ∀s. t ≠ occurs s
         then (l,send⟨filter (λt. ∀s. t ≠ occurs s) ts⟩)#rm_occurs_msgs_constr A
         else rm_occurs_msgs_constr A
    else (l,send⟨ts⟩)#rm_occurs_msgs_constr A)"
| "rm_occurs_msgs_constr (a#A) = a#rm_occurs_msgs_constr A"

private lemma add_occurs_msgs_cases:
  fixes T C frsh xs f
  defines "T' ≡ add_occurs_msgs T"
    and "frsh ≡ transaction_fresh T"
    and "xs ≡ filter (λx. x ∉ set frsh) (fv_listsst (unlabel (transaction_strand T)))"
    and "xs' ≡ fv_transaction T - set frsh"
    and "f ≡ map (λx. occurs (Var x))"
    and "C' ≡ if xs = [] then C else ⟨⋆, receive⟨f xs⟩⟩#C"
    and "ts' ≡ f frsh"
  assumes T: "T = Transaction A B C D E F"
  shows "F = ⟨⋆,send⟨ts⟩⟩#F' ⟹ T' = Transaction A B C' D E (⟨⋆,send⟨ts'@ts⟩⟩#F')"
    (is "?A ts F' ⟹ ?A' ts F'")
  and "∄ts' F'. F = ⟨⋆,send⟨ts'⟩⟩#F' ⟹ frsh ≠ [] ⟹ T' = Transaction A B C' D E (⟨⋆,send⟨ts'⟩⟩#F)"
    (is "?B ⟹ ?B' ⟹ ?B''")
  and "frsh = [] ⟹ T' = Transaction A B C' D E F" (is "?C ⟹ ?C'")
  and "transaction_decl T' = transaction_decl T"
  and "transaction_fresh T' = transaction_fresh T"
  and "xs = [] ⟹ transaction_receive T' = transaction_receive T"
  and "xs ≠ [] ⟹ transaction_receive T' = ⟨⋆,receive⟨f xs⟩⟩#transaction_receive T"
  and "transaction_checks T' = transaction_checks T"
  and "transaction_updates T' = transaction_updates T"
  and "transaction_send T = ⟨⋆,send⟨ts⟩⟩#F' ⟹
        transaction_send T' = ⟨⋆,send⟨ts'@ts⟩⟩#F'" (is "?D ts F' ⟹ ?D' ts F'")
  and "∄ts' F'. transaction_send T = ⟨⋆,send⟨ts'⟩⟩#F' ⟹ frsh ≠ [] ⟹
        transaction_send T' = ⟨⋆,send⟨ts'⟩⟩#transaction_send T" (is "?E ⟹ ?E' ⟹ ?E''")
  and "frsh = [] ⟹ transaction_send T' = transaction_send T" (is "?F ⟹ ?F'")
  and "(xs' ≠ {} ∧ transaction_receive T' = ⟨⋆, receive⟨f xs⟩⟩#transaction_receive T) ∨
       (xs' = {} ∧ transaction_receive T' = transaction_receive T)" (is ?G)
  and "(frsh ≠ [] ∧ (∃ts F'.
          transaction_send T = ⟨⋆,send⟨ts⟩⟩#F' ∧ transaction_send T' = ⟨⋆,send⟨ts'@ts⟩⟩#F')) ∨
       (frsh ≠ [] ∧ transaction_send T' = ⟨⋆,send⟨ts'⟩⟩#transaction_send T) ∨
       (frsh = [] ∧ transaction_send T' = transaction_send T)" (is ?H)
proof -
  note defs = T'_def T frsh_def xs_def xs'_def f_def C'_def ts'_def add_occurs_msgs_def Let_def

  show 0: "?A ts F' ⟹ ?A' ts F'" for ts F' unfolding defs by simp

  have "F = [] ∨ fst (hd F) ≠ ⋆ ∨ ¬is_Send (snd (hd F))" when ?B
    using that unfolding is_Send_def by (cases F) auto
  thus 1: "?B ⟹ ?B' ⟹ ?B''" unfolding defs by force

  show "?C ⟹ ?C'" unfolding defs by auto

  show "transaction_decl T' = transaction_decl T"
       "transaction_fresh T' = transaction_fresh T"
       "transaction_checks T' = transaction_checks T"
       "transaction_updates T' = transaction_updates T"
    unfolding defs by simp_all

  show "xs = [] ⟹ transaction_receive T' = transaction_receive T"
       "xs ≠ [] ⟹ transaction_receive T' = ⟨⋆, receive⟨f xs⟩⟩#transaction_receive T"
    unfolding defs by simp_all
  moreover have "xs = [] ⟷ xs' = {}"
    using filter_empty_conv[of "λx. x ∉ set frsh"]
          fv_listsst_is_fvsst[of "unlabel (transaction_strand T)"]
    unfolding xs_def xs'_def by blast
  ultimately show ?G by blast

  show 2: "?D ts F' ⟹ ?D' ts F'" for ts F' using 0 unfolding T by simp
  show 3: "?E ⟹ ?E' ⟹ ?E''" using 1 unfolding T by force
  show 4: "?F ⟹ ?F'" unfolding defs by simp

  show ?H
  proof (cases "frsh = []")
    case False thus ?thesis
      using 2 3[OF _ False] by (cases "∃ts F'. transaction_send T = ⟨⋆,send⟨ts⟩⟩#F'") (blast,blast)
  qed (simp add: 4)
qed

private lemma add_occurs_msgs_transaction_strand_set:
  fixes T C frsh xs f
  defines "frsh ≡ transaction_fresh T"
    and "xs ≡ filter (λx. x ∉ set frsh) (fv_listsst (unlabel (transaction_strand T)))"
    and "f ≡ map (λx. occurs (Var x))"
  assumes T: "T = Transaction A B C D E F"
  shows "F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          set (transaction_strand (add_occurs_msgs T)) ⊆
          set (transaction_strand T) ∪ {⟨⋆,receive⟨f xs⟩⟩,⟨⋆,send⟨f frsh@ts⟩⟩}"
    (is "?A ⟹ ?A'")
  and "F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          set (unlabel (transaction_strand (add_occurs_msgs T))) ⊆
          set (unlabel (transaction_strand T)) ∪ {receive⟨f xs⟩,send⟨f frsh@ts⟩}"
    (is "?B ⟹ ?B'")
  and "∄ts' F'. F = ⟨⋆,send⟨ts'⟩⟩#F' ⟹
          set (transaction_strand (add_occurs_msgs T)) ⊆
          set (transaction_strand T) ∪ {⟨⋆,receive⟨f xs⟩⟩,⟨⋆,send⟨f frsh⟩⟩}"
    (is "?C ⟹ ?C'")
  and "∄ts' F'. F = ⟨⋆,send⟨ts'⟩⟩#F' ⟹
          set (unlabel (transaction_strand (add_occurs_msgs T))) ⊆
          set (unlabel (transaction_strand T)) ∪ {receive⟨f xs⟩,send⟨f frsh⟩}"
    (is "?D ⟹ ?D'")
proof -
  note 0 = add_occurs_msgs_cases[
            OF T, unfolded frsh_def[symmetric] xs_def[symmetric] f_def[symmetric]]

  show "?A ⟹ ?A'" using 0(1,3) unfolding T transaction_strand_def by (cases "frsh = []") auto
  thus "?B ⟹ ?B'" unfolding unlabel_def by force

  show "?C ⟹ ?C'" using 0(2,3) unfolding T transaction_strand_def by (cases "frsh = []") auto
  thus "?D ⟹ ?D'" unfolding unlabel_def by auto
qed

private lemma add_occurs_msgs_transaction_strand_cases:
  fixes T T'::"('a,'b,'c,'d) prot_transaction" and C frsh xs f θ
  defines "T' ≡ add_occurs_msgs T"
    and "S ≡ transaction_strand T"
    and "S' ≡ transaction_strand T'"
    and "frsh ≡ transaction_fresh T"
    and "xs ≡ filter (λx. x ∉ set frsh) (fv_listsst (unlabel (transaction_strand T)))"
    and "f ≡ map (λx. occurs (Var x))"
    and "C ≡ transaction_receive T"
    and "D ≡ transaction_checks T"
    and "E ≡ transaction_updates T"
    and "F ≡ transaction_send T"
    and "C' ≡ if xs = [] then C else ⟨⋆,receive⟨f xs⟩⟩#C"
    and "C'' ≡ if xs = [] then duallsst C else ⟨⋆,send⟨f xs⟩⟩#duallsst C"
    and "C''' ≡ if xs = [] then duallsst (C ⋅lsst θ) else ⟨⋆,send⟨f xs ⋅list θ⟩⟩#duallsst (C ⋅lsst θ)"
  shows "frsh = [] ⟹ S' = C'@D@E@F"
      (is "?A ⟹ ?A'")
    and "frsh ≠ [] ⟹ ∄ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ⟹ S' = C'@D@E@(⟨⋆,send⟨f frsh⟩⟩#F)"
      (is "?B ⟹ ?B' ⟹ ?B''")
    and "frsh ≠ [] ⟹ ∃ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          ∃ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ∧ S' = C'@D@E@(⟨⋆,send⟨f frsh@ts⟩⟩#F')"
      (is "?C ⟹ ?C' ⟹ ?C''")
    and "frsh = [] ⟹ duallsst S' = C''@duallsst D@duallsst E@duallsst F"
      (is "?D ⟹ ?D'")
    and "frsh ≠ [] ⟹ ∄ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          duallsst S' = C''@duallsst D@duallsst E@(⟨⋆,receive⟨f frsh⟩⟩#duallsst F)"
      (is "?E ⟹ ?E' ⟹ ?E''")
    and "frsh ≠ [] ⟹ ∃ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          ∃ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ∧
                  duallsst S' = C''@duallsst D@duallsst E@(⟨⋆,receive⟨f frsh@ts⟩⟩#duallsst F')"
      (is "?F ⟹ ?F' ⟹ ?F''")
    and "frsh = [] ⟹
          duallsst (S' ⋅lsst θ) = C'''@duallsst (D ⋅lsst θ)@duallsst (E ⋅lsst θ)@duallsst (F ⋅lsst θ)"
      (is "?G ⟹ ?G'")
    and "frsh ≠ [] ⟹ ∄ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          duallsst (S' ⋅lsst θ) = C'''@duallsst (D ⋅lsst θ)@duallsst (E ⋅lsst θ)@
                               (⟨⋆,receive⟨f frsh ⋅list θ⟩⟩#duallsst (F ⋅lsst θ))"
      (is "?H ⟹ ?H' ⟹ ?H''")
    and "frsh ≠ [] ⟹ ∃ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ⟹
          ∃ts F'. F = ⟨⋆,send⟨ts⟩⟩#F' ∧
                  duallsst (S' ⋅lsst θ) = C'''@duallsst (D ⋅lsst θ)@duallsst (E ⋅lsst θ)@
                                       (⟨⋆,receive⟨f frsh@ts ⋅list θ⟩⟩#duallsst (F' ⋅lsst θ))"
      (is "?I ⟹ ?I' ⟹ ?I''")
proof -
  obtain A' B' CC' D' E' F' where T: "T = Transaction A' B' CC' D' E' F'" by (cases T) simp

  note 0 = add_occurs_msgs_cases[
            OF T, unfolded frsh_def[symmetric] xs_def[symmetric] f_def[symmetric] T'_def[symmetric]]

  note defs = S'_def C_def D_def E_def F_def C'_def C''_def T transaction_strand_def

  show A: "?A ⟹ ?A'" using 0(3) unfolding defs by simp
  show B: "?B ⟹ ?B' ⟹ ?B''" using 0(2) unfolding defs by simp
  show C: "?C ⟹ ?C' ⟹ ?C''" using 0(1) unfolding defs by force

  have 1: "C''' = C'' ⋅lsst θ"
    using subst_lsst_cons[of "⟨⋆, send⟨f xs⟩⟩" "duallsst C" θ] duallsst_subst[of C θ]
    unfolding C'''_def C''_def by (cases "xs = []") auto

  have 2: "(⟨⋆, receive⟨ts⟩⟩#duallsst G) ⋅lsst θ = ⟨⋆, receive⟨ts ⋅list θ⟩⟩#duallsst (G ⋅lsst θ)" 
    for ts and G::"('a,'b,'c,'d) prot_strand"
    using duallsst_subst[of G θ] subst_lsst_cons[of "⟨⋆, receive⟨ts⟩⟩" "duallsst G" θ]
    by simp

  note 3 = subst_lsst_append[of _ _ θ] duallsst_subst[of _ θ]

  show "?D ⟹ ?D'" using A unfolding defs by fastforce
  thus "?G ⟹ ?G'" unfolding 1 by (metis 3)

  show "?E ⟹ ?E' ⟹ ?E''" using B unfolding defs by fastforce
  thus "?H ⟹ ?H' ⟹ ?H''" unfolding 1 by (metis 2 3)

  show "?F ⟹ ?F' ⟹ ?F''" using C unfolding defs by fastforce
  thus "?I ⟹ ?I' ⟹ ?I''" unfolding 1 by (metis 2 3)
qed

private lemma add_occurs_msgs_trms_transaction:
  fixes T::"('a,'b,'c,'d) prot_transaction"
  shows "trms_transaction (add_occurs_msgs T) =
          trms_transaction T ∪ (λx. occurs (Var x))`(fv_transaction T ∪ set (transaction_fresh T))"
    (is "?A = ?B")
proof
  let ?occs = "(λx. occurs (Var x)) ` (fv_transaction T ∪ set (transaction_fresh T))"

  define frsh where "frsh ≡ transaction_fresh T"
  define xs where "xs ≡ filter (λx. x ∉ set frsh) (fv_listsst (unlabel (transaction_strand T)))"
  define f where "f ≡ map (λx. occurs (Var x)::('a,'b,'c,'d) prot_term)"

  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  note 0 = add_occurs_msgs_transaction_strand_set(2,4)[
            OF T, unfolded f_def[symmetric] frsh_def[symmetric] xs_def[symmetric]]

  note 1 = add_occurs_msgs_transaction_strand_cases(1,2,3)[
            of T, unfolded f_def[symmetric] frsh_def[symmetric] xs_def[symmetric]]

  have 2: "set (f xs) ∪ set (f frsh) = ?occs"
  proof -
    define ys where "ys ≡ fv_listsst (unlabel (transaction_strand T))"
    let ?ys' = "fv_transaction T - set frsh"
    define g where "g ≡ filter (λx. x ∉ set frsh)"

    have "set (g ys) = ?ys'"
      using fv_listsst_is_fvsst[of "unlabel (transaction_strand T)"] unfolding ys_def g_def by auto  
    hence "set (f (g ys)) = (λx. occurs (Var x)) ` ?ys'" unfolding f_def by force
    moreover have "set (f frsh) = (λx. occurs (Var x)) ` set frsh" unfolding f_def by force
    ultimately show ?thesis
      unfolding xs_def frsh_def[symmetric] ys_def[symmetric] g_def[symmetric] by blast
  qed

  have 3: "set (f []) = {}" unfolding f_def by blast

  have "trms_transaction (add_occurs_msgs T) ⊆ trms_transaction T ∪ set (f xs) ∪ set (f frsh)"
  proof (cases "∃ts F'. F = ⟨⋆, send⟨ts⟩⟩#F'")
    case True
    then obtain ts F' where F: "F = ⟨⋆, send⟨ts⟩⟩#F'" by blast
    have "set ts ⊆ trms_transaction T" unfolding T F trms_transaction_unfold by auto
    thus ?thesis using 0(1)[OF F] by force
  next
    case False show ?thesis using 0(2)[OF False] by force
  qed
  thus "?A ⊆ ?B" using 2 by blast

  have "trms_transaction T ∪ set (f xs) ∪ set (f frsh) ⊆ trms_transaction (add_occurs_msgs T)"
  proof (cases "frsh = []")
    case True show ?thesis using 1(1)[OF True] 3 unfolding True by (cases xs) (fastforce,force)
  next
    case False
    note * = 1(2-)[OF False]
    show ?thesis
    proof (cases "∃ts F'. transaction_send T = ⟨⋆, send⟨ts⟩⟩#F'")
      case True show ?thesis using *(2)[OF True] 3 by force
    next
      case False show ?thesis using *(1)[OF False] 3 by force
    qed
  qed
  thus "?B ⊆ ?A" using 2 by blast
qed

private lemma add_occurs_msgs_vars_eq:
  fixes T::"('fun,'var,'sets,'lbl) prot_transaction"
  assumes T_adm: "admissible_transaction' T"
  shows "fvlsst (transaction_receive (add_occurs_msgs T)) =
         fvlsst (transaction_receive T) ∪ fvlsst (transaction_checks T)" (is ?A)
    and "fvlsst (transaction_send (add_occurs_msgs T)) =
         fvlsst (transaction_send T) ∪ set (transaction_fresh T)" (is ?B)
    and "fv_transaction (add_occurs_msgs T) = fv_transaction T" (is ?C)
    and "bvars_transaction (add_occurs_msgs T) = bvars_transaction T" (is ?D)
    and "vars_transaction (add_occurs_msgs T) = vars_transaction T" (is ?E)
    and "fvlsst (transaction_strand (add_occurs_msgs T) ⋅lsst θ) =
         fvlsst (transaction_strand T ⋅lsst θ)" (is ?F)
    and "bvarslsst (transaction_strand (add_occurs_msgs T) ⋅lsst θ) =
         bvarslsst (transaction_strand T ⋅lsst θ)" (is ?G)
    and "varslsst (transaction_strand (add_occurs_msgs T) ⋅lsst θ) =
         varslsst (transaction_strand T ⋅lsst θ)" (is ?H)
    and "set (transaction_fresh (add_occurs_msgs T)) = set (transaction_fresh T)" (is ?I)
proof -
  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  have T_fresh: "set (transaction_fresh T) ⊆ fv_transaction T"
    using admissible_transactionE(7)[OF T_adm] unfolding fv_transaction_unfold by blast

  note 0 = add_occurs_msgs_cases[OF T]

  define xs where "xs ≡
    filter (λx. x ∉ set (transaction_fresh T)) (fv_listsst (unlabel (transaction_strand T)))"

  show D: ?D
  proof -
    have "bvarslsst (transaction_receive (add_occurs_msgs T)) = bvarslsst (transaction_receive T)"
      using 0(6,7) by (cases "xs = []") (auto simp add: xs_def)
    moreover have "bvarslsst (transaction_send (add_occurs_msgs T)) = bvarslsst (transaction_send T)"
    proof (cases "∃ts' F'. F = ⟨⋆, send⟨ts'⟩⟩#F'")
      case True thus ?thesis using 0(1) unfolding T by force
    next
      case False show ?thesis using 0(2)[OF False] 0(3) unfolding T by (cases "B = []") auto
    qed
    ultimately show ?thesis using 0(8,9) unfolding bvars_transaction_unfold by argo
  qed

  have T_no_bvars:
      "bvars_transaction T = {}"
      "bvarslsst (transaction_receive T) = {}"
      "bvarslsst (transaction_checks T) = {}"
      "bvarslsst (transaction_send T) = {}"
      "bvars_transaction (add_occurs_msgs T) = {}"
    using admissible_transactionE(4)[OF T_adm] D
    unfolding bvars_transaction_unfold by (blast,blast,blast,blast,blast)

  have T_fv_subst:
      "fvlsst (transaction_strand T ⋅lsst δ) = fvset (δ ` fv_transaction T)" (is ?Q1)
      "fvlsst (transaction_receive T ⋅lsst δ) = fvset (δ ` fvlsst (transaction_receive T))" (is ?Q2)
      "fvlsst (transaction_checks T ⋅lsst δ) = fvset (δ ` fvlsst (transaction_checks T))" (is ?Q3)
      "fvlsst (transaction_send T ⋅lsst δ) = fvset (δ ` fvlsst (transaction_send T))" (is ?Q4)
      "fvlsst (transaction_strand (add_occurs_msgs T) ⋅lsst δ) =
       fvset (δ ` fvlsst (transaction_strand (add_occurs_msgs T)))" (is ?Q5)
      "fvlsst (transaction_receive (add_occurs_msgs T) ⋅lsst δ) =
       fvset (δ ` fvlsst (transaction_receive (add_occurs_msgs T)))" (is ?Q6)
    for δ
  proof -
    note * = fvsst_subst_if_no_bvars

    have **: "bvarslsst (transaction_receive (add_occurs_msgs T)) = {}"
      using T_no_bvars(5) unfolding bvars_transaction_unfold by fast

    show ?Q1 using *[OF T_no_bvars(1)] unfolding unlabel_subst by blast
    show ?Q2 using *[OF T_no_bvars(2)] unfolding unlabel_subst by blast
    show ?Q3 using *[OF T_no_bvars(3)] unfolding unlabel_subst by blast
    show ?Q4 using *[OF T_no_bvars(4)] unfolding unlabel_subst by blast
    show ?Q5 using *[OF T_no_bvars(5)] unfolding unlabel_subst by blast
    show ?Q6 using *[OF **] unfolding unlabel_subst by blast
  qed

  have A: "fvlsst (transaction_receive (add_occurs_msgs T) ⋅lsst δ) =
           fvlsst (transaction_receive T ⋅lsst δ) ∪ fvlsst (transaction_checks T ⋅lsst δ)"
    for δ
  proof -
    define rcv_trms where 
      "rcv_trms ≡ map (λx. occurs (Var x)::('fun,'var,'sets,'lbl) prot_term) xs"

    have "fvset (set rcv_trms) = fv_transaction T - set (transaction_fresh T)"
         "rcv_trms = [] ⟷ xs = []"
      using fv_listsst_is_fvsst[of "unlabel (transaction_strand T)"]
      unfolding rcv_trms_def xs_def by auto
    hence 1: "fvlsst (transaction_receive (add_occurs_msgs T)) =
              (fv_transaction T - set (transaction_fresh T)) ∪ fvlsst (transaction_receive T)"
      using 0(6,7)[unfolded rcv_trms_def[symmetric] xs_def[symmetric]] by (cases "xs = []") auto
  
    have 2: "fvlsst (transaction_receive T) ⊆ fv_transaction T - set (transaction_fresh T)"
      using admissible_transactionE(12)[OF T_adm] unfolding fv_transaction_unfold by fast

    have 3: "fv_transaction T - set (transaction_fresh T) =
             fvlsst (transaction_receive T) ∪ fvlsst (transaction_checks T)"
      using admissible_transactionE(7,10,12,13)[OF T_adm]
      unfolding fv_transaction_unfold by blast
  
    show ?thesis using 1 2 3 T_fv_subst(2,3,6)[of δ] by force
  qed

  show ?A using A[of Var] unfolding subst_lsst_id_subst by blast

  show B: ?B using 0(14) by fastforce

  have B': "fvlsst (transaction_send (add_occurs_msgs T) ⋅lsst δ) =
            fvlsst (transaction_send T ⋅lsst δ) ∪ fvset (δ ` set (transaction_fresh T))"
    for δ
  proof -
    note * = fvsst_subst_if_no_bvars[of _ δ]

    have **: "bvarslsst (transaction_send (add_occurs_msgs T)) = {}"
      using T_no_bvars(5) unfolding bvars_transaction_unfold by fast

    show ?thesis
      using B *[OF T_no_bvars(4)] *[OF **]
      unfolding unlabel_subst by simp
  qed

  show C: ?C
    using A[of Var] B T_fresh
    unfolding fv_transaction_unfold 0(8,9) subst_lsst_id_subst by blast

  show ?E using C D varssst_is_fvsst_bvarssst by metis

  have "fvset (θ ` set (transaction_fresh T)) ⊆ fvlsst (transaction_strand T ⋅lsst θ)"
    using T_fresh
    unfolding fvsst_subst_if_no_bvars[OF T_no_bvars(1), of θ, unfolded unlabel_subst]
    by auto
  thus F: ?F
    using A[of θ] B'[of θ] fvsst_append
          fvsst_subst_if_no_bvars[OF T_no_bvars(1), of θ, unfolded unlabel_subst]
          fvsst_subst_if_no_bvars[OF T_no_bvars(5), of θ, unfolded unlabel_subst C]
    unfolding transaction_strand_def by argo

  show G: ?G using D bvarssst_subst unlabel_subst by metis

  show ?H using F G varssst_is_fvsst_bvarssst by metis

  show ?I using 0(5) by argo
qed

private lemma add_occurs_msgs_trms:
  "trms_transaction (add_occurs_msgs T) =
    trms_transaction T ∪ (λx. occurs (Var x)) ` (set (transaction_fresh T) ∪ fv_transaction T)"
proof -
  let ?f = "λx. occurs (Var x)"
  let ?xs = "filter (λx. x ∉ set (transaction_fresh T))
                    (fv_listsst (unlabel (transaction_strand T)))"

  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  note 0 = add_occurs_msgs_cases[OF T]

  have "set ?xs = fv_transaction T - set (transaction_fresh T)"
    using fv_listsst_is_fvsst[of "unlabel (transaction_strand T)"] by auto
  hence 1: "trmslsst (transaction_receive (add_occurs_msgs T)) =
           trmslsst (transaction_receive T) ∪ ?f ` (fv_transaction T - set (transaction_fresh T))"
    using 0(6,7) by (cases "?xs = []") auto

  have 2: "trmslsst (transaction_send (add_occurs_msgs T)) =
           trmslsst (transaction_send T) ∪ ?f ` set (transaction_fresh T)"
    using 0(10,11,12) by (cases "transaction_fresh T = []") (simp,fastforce)

  have 3: "trmslsst (transaction_receive (add_occurs_msgs T)) ∪
           trmslsst (transaction_send (add_occurs_msgs T)) =
           trmslsst (transaction_receive T) ∪ trmslsst (transaction_send T) ∪
           ?f ` (set (transaction_fresh T) ∪ fv_transaction T)"
    using 1 2 by blast

  show ?thesis using 3 unfolding trms_transaction_unfold 0(8,9) by blast
qed

lemma add_occurs_msgs_admissible_occurs_checks:
  fixes T::"('fun,'atom,'sets,'lbl) prot_transaction"
  assumes T_adm: "admissible_transaction' T"
  shows "admissible_transaction' (add_occurs_msgs T)" (is ?A)
    and "admissible_transaction_occurs_checks (add_occurs_msgs T)" (is ?B)
proof -
  let ?T' = "add_occurs_msgs T"

  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  note defs = T add_occurs_msgs_def Let_def admissible_transaction'_def
              admissible_transaction_occurs_checks_def

  note defs' = admissible_transaction_terms_def wftrms_code[symmetric]

  note 1 = add_occurs_msgs_cases[OF T]
  note 2 = add_occurs_msgs_vars_eq[OF T_adm]
  note 3 = add_occurs_msgs_trms[of T]
  note 4 = add_occurs_msgs_transaction_strand_set[OF T]

  have occurs_wf: "wftrm (occurs (Var x))" for x::"('fun,'atom,'sets,'lbl) prot_var" by fastforce

  have occurs_funs: "funs_term (occurs (Var x)) = {OccursFact, OccursSec}"
    for x::"('fun,'atom,'sets,'lbl) prot_var"
    by force

  have occurs_funs_not_attack: "¬(∃f ∈ ⋃(funs_term ` trmssstp r). is_Attack f)"
    when "r = receive⟨map (λx. occurs (Var x)) xs⟩ ∨ r = send⟨map (λx. occurs (Var x)) ys⟩"
    for r::
      "(('fun,'atom,'sets,'lbl) prot_fun, ('fun,'atom,'sets,'lbl) prot_var) stateful_strand_step"
    and xs ys::"('fun,'atom,'sets,'lbl) prot_var list"
    using that by fastforce

  have occurs_funs_not_attack': "¬(∃f ∈ ⋃(funs_term ` trmssstp r). is_Attack f)"
    when "r = send⟨map (λx. occurs (Var x)) xs@ts⟩"
    and "¬(∃f ∈ ⋃(funs_term ` trmssstp (send⟨ts⟩)). is_Attack f)"
    for r::
      "(('fun,'atom,'sets,'lbl) prot_fun, ('fun,'atom,'sets,'lbl) prot_var) stateful_strand_step"
    and xs::"('fun,'atom,'sets,'lbl) prot_var list"
    and ts
    using that by fastforce

  let ?P1 = "λT. wellformed_transaction T"
  let ?P2 = "λT. transaction_decl T () = []"
  let ?P3 = "λT. list_all (λx. fst x = TAtom Value) (transaction_fresh T)"
  let ?P4 = "λT. ∀x ∈ vars_transaction T. is_Var (fst x) ∧ (the_Var (fst x) = Value)"
  let ?P5 = "λT. bvarslsst (transaction_strand T) = {}"
  let ?P6 = "λT. set (transaction_fresh T) ⊆
                  fvlsst (filter (is_Insert ∘ snd) (transaction_updates T)) ∪
                  fvlsst (transaction_send T)"
  let ?P7 = "λT. ∀x ∈ fv_transaction T - set (transaction_fresh T).
                 ∀y ∈ fv_transaction T - set (transaction_fresh T).
                   x ≠ y ⟶ ⟨Var x != Var y⟩ ∈ set (unlabel (transaction_checks T)) ∨
                             ⟨Var y != Var x⟩ ∈ set (unlabel (transaction_checks T))"
  let ?P8 = "λT. fvlsst (transaction_updates T) ∪ fvlsst (transaction_send T)
                  - set (transaction_fresh T)
                  ⊆ fvlsst (transaction_receive T) ∪ fvlsst (transaction_checks T)"
  let ?P9 = "λT. ∀r ∈ set (unlabel (transaction_checks T)).
                  is_Equality r ⟶ fv (the_rhs r) ⊆ fvlsst (transaction_receive T)"
  let ?P10 = "λT. fvlsst (transaction_checks T) ⊆
                    fvlsst (transaction_receive T) ∪
                    fvlsst (filter (λs. is_InSet (snd s) ∧ the_check (snd s) = Assign)
                                  (transaction_checks T))"
  let ?P11 = "λT. admissible_transaction_checks T"
  let ?P12 = "λT. admissible_transaction_updates T"
  let ?P13 = "λT. admissible_transaction_terms T"
  let ?P14 = "λT. admissible_transaction_send_occurs_form T"
  let ?P15 = "λT. list_all (λa. is_Receive (snd a) ⟶ the_msgs (snd a) ≠ [])
                           (transaction_receive T)"
  let ?P16 = "λT. list_all (λa. is_Send (snd a) ⟶ the_msgs (snd a) ≠ []) (transaction_send T)"

  have T_props:
      "?P1 T" "?P2 T" "?P3 T" "?P4 T" "?P5 T" "?P6 T" "?P7 T" "?P8 T" "?P9 T" "?P10 T" "?P11 T"
      "?P12 T" "?P13 T" "?P14 T" "?P15 T" "?P16 T"
    using T_adm unfolding defs by meson+

  have 5: "wf'sst (X ∪ Y) (unlabel (duallsst (transaction_strand (add_occurs_msgs T))))"
    when X: "X = fst ` set (transaction_decl T ())"
      and Y: "Y = set (transaction_fresh T)"
      and T_wf: "wf'sst (X ∪ Y) (unlabel (duallsst (transaction_strand T)))"
    for X Y
  proof -
    define frsh where "frsh ≡ transaction_fresh T"
    define xs where "xs ≡ fv_listsst (unlabel (transaction_strand T))"
    define ys where "ys ≡ filter (λx. x ∉ set frsh) xs"

    let ?snds = "unlabel (duallsst (transaction_receive T))"
    let ?snds' = "unlabel (duallsst (transaction_receive (add_occurs_msgs T)))"
    let ?chks = "unlabel (duallsst (transaction_checks T))"
    let ?chks' = "unlabel (duallsst (transaction_checks (add_occurs_msgs T)))"
    let ?upds = "unlabel (duallsst (transaction_updates T))"
    let ?upds' = "unlabel (duallsst (transaction_updates (add_occurs_msgs T)))"
    let ?rcvs = "unlabel (duallsst (transaction_send T))"
    let ?rcvs' = "unlabel (duallsst (transaction_send (add_occurs_msgs T)))"

    have p0: "set ?snds ⊆ set ?snds'" using 1(13) by auto

    have p1: "?chks = ?chks'" "?upds = ?upds'" using 1(8,9) by (argo,argo)

    have p2: "wfvarsoccssst ?snds ⊆ wfvarsoccssst ?snds'"
             "wfvarsoccssst (?snds@?chks@?upds) ⊆ wfvarsoccssst (?snds'@?chks'@?upds')"
             "X ∪ Y ∪ wfvarsoccssst (?snds@?chks@?upds) ⊆
              X ∪ Y ∪  wfvarsoccssst (?snds'@?chks'@?upds')"
      using p0 p1 unfolding wfvarsoccssst_def by auto

    have "wf'sst (X ∪ Y ∪ wfvarsoccssst (?snds@?chks@?upds)) ?rcvs"
      using T_wf wfsst_append_exec[of "X ∪ Y" "?snds@?chks@?upds" ?rcvs]
      unfolding transaction_strand_unlabel_dual_unfold by simp
    hence r0: "wf'sst (X ∪ Y ∪ wfvarsoccssst (?snds'@?chks'@?upds')) ?rcvs"
      using wfsst_vars_mono'[OF _ p2(3)] by blast

    have "list_all is_Send (unlabel (transaction_send T))"
      using admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
      unfolding wellformed_transaction_def by blast
    hence "list_all is_Receive ?rcvs" by (metis duallsst_list_all(2))
    hence r1: "wfrestrictedvarssst ?rcvs ⊆ X ∪ Y ∪ wfvarsoccssst (?snds'@?chks'@?upds')"
      using wfrestrictedvarssst_receives_only_eq wfsst_receives_only_fv_subset[OF r0] by blast

    have "fvset ((λx. occurs (Var x)) ` set (transaction_fresh T)) ⊆ Y"
      unfolding Y by auto
    hence r2: "wfrestrictedvarssst ?rcvs' ⊆ X ∪ Y ∪ wfvarsoccssst (?snds'@?chks'@?upds')"
      using 1(14) r1 unfolding wfrestrictedvarssst_def by fastforce (* TODO: find faster proof *)

    have r3: "wf'sst (X ∪ Y) (?snds'@?chks'@?upds')"
    proof -
      have *: "wf'sst (X ∪ Y) (?snds@?chks'@?upds')"
        using T_wf wfsst_prefix[of "X ∪ Y" "?snds@?chks@?upds" ?rcvs] p1
        unfolding transaction_strand_unlabel_dual_unfold by simp

      have "?snds' = ?snds ∨ (∃ts. ?snds' = send⟨ts⟩#?snds)" using 1(13) by auto
      thus ?thesis
      proof
        assume "?snds' = ?snds" thus ?thesis using * by simp
      next
        assume "∃ts. ?snds' = send⟨ts⟩#?snds"
        then obtain ts where "?snds' = send⟨ts⟩#?snds" by blast
        thus ?thesis using wfsst_sends_only_prepend[OF *, of "[send⟨ts⟩]"] by simp
      qed
    qed

    have "wf'sst (X ∪ Y) (?snds'@?chks'@?upds'@?rcvs')"
      using wfsst_append_suffix''[OF r3] r2 by auto
    thus ?thesis
      using unlabel_append duallsst_append
      unfolding transaction_strand_def by auto
  qed

  have T'_props_1: "?P1 ?T'"
    unfolding wellformed_transaction_def
    apply (intro conjI)
    subgoal using 1(13) T_props(1) unfolding wellformed_transaction_def by force
    subgoal using 1(8) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 1(9) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 1(14) T_props(1) unfolding wellformed_transaction_def by force
    subgoal using 1(4) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 1(5) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 1(4,5) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using T_props(1) unfolding 2(1) 1(5) wellformed_transaction_def by blast
    subgoal using 1(5,8) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 1(5) 2(4) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 2(3,4) T_props(1) unfolding wellformed_transaction_def by simp
    subgoal using 1(4,5) 5 T_props(1) unfolding wellformed_transaction_def by simp 
    done

  have T'_props_2_12:
      "?P2 ?T'" "?P3 ?T'" "?P4 ?T'" "?P5 ?T'" "?P6 ?T'" "?P7 ?T'" "?P8 ?T'" "?P9 ?T'" "?P10 ?T'"
      "?P11 ?T'" "?P12 ?T'"
    subgoal using T_props(2) unfolding defs by force
    subgoal using T_props(3) unfolding defs by force
    subgoal using T_props(4) 2(5) by argo
    subgoal using T_props(5) 2(4) by argo
    subgoal using T_props(6) 1(5,8) 2(2) by auto
    subgoal using T_props(7) 1(5,8) 2(3) by presburger
    subgoal using T_props(8) 1(5,9) 2(1,2) by auto
    subgoal using T_props(9) 1(8) 2(1) by auto
    subgoal using T_props(10) 1(8) 2(1) by auto
    subgoal using T_props(11) 1(8) unfolding admissible_transaction_checks_def by argo
    subgoal using T_props(12) 1(9) unfolding admissible_transaction_updates_def by argo
    done

  (* TODO: clean up? *)
  have T'_props_13_aux:
      "transaction_fresh ?T' = []" (is ?Q1)
      "is_Send r" (is ?Q2)
      "length (the_msgs r) = 1" (is ?Q3)
      "is_Fun_Attack (hd (the_msgs r))" (is ?Q4)
    when r: "r ∈ set (unlabel (transaction_strand (add_occurs_msgs T)))"
            "∃f ∈ ⋃(funs_term ` trmssstp r). is_Attack f" (is "?Q' (trmssstp r)")
    for r
  proof -
    note q0 = conjunct2[OF conjunct2[OF T_props(13)[unfolded defs']]]

    let ?Q'' = "λts' F'. F = ⟨⋆, send⟨ts'⟩⟩#F'"
    let ?f = "map (λx. occurs (Var x))"
    let ?frsh = "transaction_fresh T"
    let ?xs = "fv_listsst (unlabel (transaction_strand T))"

    have q1: "r ≠ send⟨?f ?frsh⟩" "r ≠ receive⟨?f (filter (λx. x ∉ set ?frsh) ?xs)⟩"
             "∀f ∈ ⋃(funs_term ` set (?f ?frsh)). ¬is_Attack f"
      using r(2) by (fastforce,fastforce,simp)

    have q2: "send⟨ts'⟩ ∈ set (unlabel (transaction_strand T))"
             "r = send⟨?f ?frsh@ts'⟩ ∨ r ∈ set (unlabel (transaction_strand T))"
      when "?Q'' ts' F'" for ts' F'
      subgoal using that unfolding T transaction_strand_def by force
      subgoal using that r(1) 4(2)[OF that] q1 unfolding T transaction_strand_def by fast
      done

    have q3: "?Q' (set ts')"
      when r': "?Q'' ts' F'" "r ∉ set (unlabel (transaction_strand T))" for ts' F'
    proof -
      have "r = send⟨?f ?frsh@ts'⟩" using q2(2)[OF r'(1)] r'(2) by argo
      thus ?thesis using r(2) by fastforce
    qed
    
    have q4: "r ∈ set (unlabel (transaction_strand T))" when "∄ts' F'. ?Q'' ts' F'"
      using 4(4)[OF that] r(1) q1(1,2) by blast

    have "∃r' ∈ set (unlabel (transaction_strand T)). ?Q' (trmssstp r')"
      when "?Q'' ts' F'" for ts' F'
      apply (cases "r ∈ set (unlabel (transaction_strand T))")
      subgoal using q2(2)[OF that] r(2) by metis
      subgoal using q2(1)[OF that] q3[OF that] trmssstp.simps(1)[of ts'] by metis
      done
    hence "?frsh = []" when "?Q'' ts' F'" for ts' F' using q0 that by blast
    hence "r = send⟨ts'⟩ ∨ r ∈ set (unlabel (transaction_strand T))" when "?Q'' ts' F'" for ts' F'
      using q2(2)[OF that] that by blast
    hence "r ∈ set (unlabel (transaction_strand T))" using q2(1) q4 by fast
    thus ?Q1 ?Q2 ?Q3 ?Q4 using r(2) q0 unfolding 1(5) by auto
  qed

  have T'_props_13: "?P13 ?T'"
    unfolding defs' 3
    apply (intro conjI)
    subgoal using conjunct1[OF T_props(13)[unfolded defs']] occurs_wf by fast
    subgoal using conjunct1[OF conjunct2[OF T_props(13)[unfolded defs']]] occurs_funs by auto
    subgoal using T'_props_13_aux by meson
    done

  have T'_props_14: "?P14 ?T'"
  proof (cases "∃ts' F'. transaction_send T = ⟨⋆,send⟨ts'⟩⟩#F'")
    case True
    then obtain ts' F' where F': "transaction_send T = ⟨⋆,send⟨ts'⟩⟩#F'" by meson
    show ?thesis
      using T_props(14) 1(10)[OF F'] F' 1(5,12)
      unfolding admissible_transaction_send_occurs_form_def Let_def
      by (cases "transaction_fresh T = []") auto
  next
    case False show ?thesis
      using T_props(14) 1(11)[OF False] 1(5,12)
      unfolding admissible_transaction_send_occurs_form_def Let_def
      by (cases "transaction_fresh T = []") auto
  qed

  let ?xs = "fv_listsst (unlabel (transaction_strand T))"

  have T'_props_15: "?P15 ?T'"
    using T_props(15) 1(6,7) unfolding Let_def
    by (cases "filter (λx. x ∉ set (transaction_fresh T)) ?xs = []") (simp,fastforce)

  have T'_props_16: "?P16 ?T'"
  proof (cases "∃ts' F'. transaction_send T = ⟨⋆,send⟨ts'⟩⟩#F'")
    case True
    then obtain ts' F' where F': "transaction_send T = ⟨⋆,send⟨ts'⟩⟩#F'" by meson
    show ?thesis
      using T_props(16) 1(10)[OF F'] F' 1(5,12)
      unfolding Let_def by (cases "transaction_fresh T = []") auto
  next
    case False show ?thesis
      using T_props(16) 1(11)[OF False] 1(5,12)
      unfolding Let_def by (cases "transaction_fresh T = []") auto
  qed

  note T'_props = T'_props_1 T'_props_2_12 T'_props_13 T'_props_14 T'_props_15 T'_props_16

  show ?A using T'_props unfolding admissible_transaction'_def by meson

  have 5: "set (filter (λx. x ∉ set (transaction_fresh T))
                       (fv_listsst (unlabel (transaction_strand T)))) =
           fv_transaction T - set (transaction_fresh T)"
    using fv_listsst_is_fvsst by fastforce

  have "transaction_receive ?T' ≠ []"
    and "is_Receive (hd (unlabel (transaction_receive ?T')))"
    and "∀x ∈ fv_transaction ?T' - set (transaction_fresh ?T'). fst x = TAtom Value ⟶
            occurs (Var x) ∈ set (the_msgs (hd (unlabel (transaction_receive ?T'))))"
    when x: "x ∈ fv_transaction ?T' - set (transaction_fresh ?T')" "fst x = TAtom Value" for x
    using 1(13) 5 x unfolding 1(5) 2(3) by (force,force,force)
  moreover have "transaction_send ?T' ≠ []" (is ?C)
    and "is_Send (hd (unlabel (transaction_send ?T')))" (is ?D)
    and "∀x ∈ set (transaction_fresh ?T').
           occurs (Var x) ∈ set (the_msgs (hd (unlabel (transaction_send ?T'))))" (is ?E)
    when T'_frsh: "transaction_fresh ?T' ≠ []"
    using 1(14) T'_frsh unfolding 1(5) by auto
  ultimately show ?B
    using T'_props_14 unfolding admissible_transaction_occurs_checks_def Let_def by blast
qed

private lemma add_occurs_msgs_in_trms_subst_cases:
  fixes T::"('fun,'atom,'sets,'lbl) prot_transaction"
  assumes T_adm: "admissible_transaction' T"
    and t: "t ∈ trmslsst (transaction_strand (add_occurs_msgs T) ⋅lsst θ)"  
  shows "t ∈ trmslsst (transaction_strand T ⋅lsst θ) ∨
         (∃x ∈ fv_transaction T. t = occurs (θ x))"
proof -
  define frsh where "frsh ≡ transaction_fresh T"
  define xs where "xs ≡ filter (λx. x ∉ set frsh) (fv_listsst (unlabel (transaction_strand T)))"
  define f where "f ≡ map (λx. occurs (Var x)::('fun,'atom,'sets,'lbl) prot_term)"

  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  note T'_adm = add_occurs_msgs_admissible_occurs_checks(1)[OF T_adm]

  have 0: "set (transaction_fresh T) ⊆ fv_transaction T"
    using admissible_transactionE(7)[OF T_adm]
    unfolding fv_transaction_unfold by blast
  hence 00: "set (f xs) ∪ set (f frsh) = (λx. occurs (Var x)) ` fv_transaction T"
    using fv_listsst_is_fvsst[of "unlabel (transaction_strand T)"]
    unfolding f_def xs_def frsh_def by auto

  note 1 = add_occurs_msgs_transaction_strand_set[OF T]

  have 2: "set (transaction_strand (add_occurs_msgs T)) ⊆
           set (transaction_strand T) ∪ {⟨⋆,receive⟨f xs⟩⟩,⟨⋆,send⟨f frsh⟩⟩}"
    when "∄ts F'. F = ⟨⋆,send⟨ts⟩⟩#F'"
    using 1(3,4)[OF that] unfolding f_def[symmetric] frsh_def[symmetric] xs_def[symmetric] by blast

  have 3: "trms_transaction (add_occurs_msgs T) =
           trms_transaction T ∪ (λx. occurs (Var x)) ` fv_transaction T"
    using 0 add_occurs_msgs_trms_transaction[of T] by blast

  have 4: "bvars_transaction T ∩ subst_domain θ = {}"
          "bvars_transaction (add_occurs_msgs T) ∩ subst_domain θ = {}"
    using admissible_transactionE(4)[OF T_adm] admissible_transactionE(4)[OF T'_adm]
    by (blast,blast)

  note 5 = trmssst_subst[OF 4(1), unfolded unlabel_subst]
           trmssst_subst[OF 4(2), unfolded unlabel_subst]

  note 6 = fvsst_is_subterm_trmssst_subst[
            OF _ 4(1), unfolded add_occurs_msgs_admissible_occurs_checks(1)[OF T_adm] unlabel_subst]

  show ?thesis
    using t 6 unfolding 3 5 by fastforce
qed

private lemma add_occurs_msgs_updates_send_filter_iff:
  fixes f
  defines "f ≡ λT. list_ex (λa. is_Send (snd a) ∨ is_Update (snd a)) (transaction_strand T)"
    and "g ≡ λT. transaction_fresh T = [] ⟶ f T"
  shows "map add_occurs_msgs (filter g P) = filter g (map add_occurs_msgs P)"
proof -
  have "g T ⟷ g (add_occurs_msgs T)" for T
  proof -
    obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp_all
    note 0 = add_occurs_msgs_cases[OF T]
    show ?thesis using 0(6,7,12) unfolding g_def f_def transaction_strand_def 0(5,8,9) by fastforce
  qed
  thus ?thesis by (induct P) simp_all
qed

lemma add_occurs_msgs_updates_send_filter_iff':
  fixes f
  defines "f ≡ λT. list_ex (λa. is_Send (snd a) ∨ is_Update (snd a)) (transaction_strand T)"
    and "g ≡ λT. transaction_fresh T = [] ⟶ transaction_updates T ≠ [] ∨ transaction_send T ≠ []"
  shows "map add_occurs_msgs (filter g P) = filter g (map add_occurs_msgs P)"
proof -
  have "g T ⟷ g (add_occurs_msgs T)" for T
  proof -
    obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp_all
    note 0 = add_occurs_msgs_cases[OF T]
    show ?thesis using 0(6,7,12) unfolding g_def f_def transaction_strand_def 0(5,8,9) by argo
  qed
  thus ?thesis by (induct P) simp_all
qed

private lemma rm_occurs_msgs_constr_Cons:
  defines "f ≡ rm_occurs_msgs_constr"
  shows
    "¬is_Receive a ⟹ ¬is_Send a ⟹ f ((l,a)#A) = (l,a)#f A"
    "is_Receive a ⟹ ∄t. occurs t ∈ set (the_msgs a) ⟹ f ((l,a)#A) = (l,a)#f A"
    "is_Receive a ⟹ ∃t. occurs t ∈ set (the_msgs a) ⟹
      ∃t ∈ set (the_msgs a). ∀s. t ≠ occurs s ⟹
      f ((l,a)#A) = (l,receive⟨filter (λt. ∀s. t ≠ occurs s) (the_msgs a)⟩)#f A"
    "is_Receive a ⟹ ∃t. occurs t ∈ set (the_msgs a) ⟹
      ∀t ∈ set (the_msgs a). ∃s. t = occurs s ⟹ f ((l,a)#A) = f A"
    "is_Send a ⟹ ∄t. occurs t ∈ set (the_msgs a) ⟹ f ((l,a)#A) = (l,a)#f A"
    "is_Send a ⟹ ∃t. occurs t ∈ set (the_msgs a) ⟹
      ∃t ∈ set (the_msgs a). ∀s. t ≠ occurs s ⟹
      f ((l,a)#A) = (l,send⟨filter (λt. ∀s. t ≠ occurs s) (the_msgs a)⟩)#f A"
    "is_Send a ⟹ ∃t. occurs t ∈ set (the_msgs a) ⟹
      ∀t ∈ set (the_msgs a). ∃s. t = occurs s ⟹ f ((l,a)#A) = f A"
unfolding f_def by (cases a; auto)+

private lemma rm_occurs_msgs_constr_Cons':
  defines "f ≡ rm_occurs_msgs_constr"
    and "g ≡ filter (λt. ∀s. t ≠ occurs s)"
  assumes a: "is_Receive a ∨ is_Send a"
  shows
    "∄t. occurs t ∈ set (the_msgs a) ⟹ f ((l,a)#A) = (l,a)#f A"
    "∃t. occurs t ∈ set (the_msgs a) ⟹
      ∃t ∈ set (the_msgs a). ∀s. t ≠ occurs s ⟹
      is_Send a ⟹ f ((l,a)#A) = (l,send⟨g (the_msgs a)⟩)#f A"
    "∃t. occurs t ∈ set (the_msgs a) ⟹
      ∃t ∈ set (the_msgs a). ∀s. t ≠ occurs s ⟹
      is_Receive a ⟹ f ((l,a)#A) = (l,receive⟨g (the_msgs a)⟩)#f A"
    "∃t. occurs t ∈ set (the_msgs a) ⟹
      ∀t ∈ set (the_msgs a). ∃s. t = occurs s ⟹ f ((l,a)#A) = f A"
using a unfolding f_def g_def by (cases a; auto)+

private lemma rm_occurs_msgs_constr_Cons'':
  defines "f ≡ rm_occurs_msgs_constr"
    and "g ≡ filter (λt. ∀s. t ≠ occurs s)"
  assumes a: "a = receive⟨ts⟩ ∨ a = send⟨ts⟩"
  shows "f ((l,a)#A) = (l,a)#f A ∨ f ((l,a)#A) = (l,receive⟨g ts⟩)#f A ∨
         f ((l,a)#A) = (l,send⟨g ts⟩)#f A ∨ f ((l,a)#A) = f A"
using rm_occurs_msgs_constr_Cons(2-)[of a l A] a unfolding f_def g_def by (cases a) auto

private lemma rm_occurs_msgs_constr_ik_subset:
  "iklsst (rm_occurs_msgs_constr A) ⊆ iklsst A"
proof (induction A)
  case (Cons a A)
  let ?f = "filter (λt. ∀s. t ≠ occurs s)"

  note IH = Cons.IH

  obtain l b where a: "a = (l,b)" by (metis surj_pair)

  have 0: "set (unlabel A) ⊆ set (unlabel (a#A))" by auto

  note 1 = rm_occurs_msgs_constr_Cons[of b l A]
  note 2 = in_iklsst_iff
  note 3 = iksst_set_subset[OF 0]
  note 4 = iksst_append
  note 5 = 4[of "unlabel [a]" "unlabel A"] 4[of "unlabel [a]" "unlabel (rm_occurs_msgs_constr A)"]

  show ?case
  proof (cases "is_Send b ∨ is_Receive b")
    case True
    note b_cases = this

    define ts where "ts ≡ the_msgs b"

    have ts_cases: "is_Send b ⟹ b = send⟨ts⟩" "is_Receive b ⟹ b = receive⟨ts⟩"
      unfolding ts_def by simp_all

    have 6:
        "is_Send b ⟹ iklsst [(l,b)] = {}"
        "is_Send b ⟹ iklsst [(l,send⟨the_msgs b⟩)] = {}"
        "is_Send b ⟹ iklsst [(l,send⟨?f (the_msgs b)⟩)] = {}"
        "is_Receive b ⟹ iklsst [(l,b)] = set ts"
        "is_Receive b ⟹ iklsst [(l,receive⟨the_msgs b⟩)] = set ts"
        "is_Receive b ⟹ iklsst [(l,receive⟨?f (the_msgs b)⟩)] = set (?f ts)"
      using 2[of _ "[(l, send⟨the_msgs b⟩)]"]
            2[of _ "[(l, send⟨?f (the_msgs b)⟩)]"]
            2[of _ "[(l, receive⟨the_msgs b⟩)]"]
            2[of _ "[(l, receive⟨?f (the_msgs b)⟩)]"]
            b_cases ts_cases
      by auto

    have "iklsst (rm_occurs_msgs_constr (a#A)) = iklsst (rm_occurs_msgs_constr A)"
      when b: "is_Send b"
    proof (cases "∃t. occurs t ∈ set (the_msgs b)")
      case True
      note 7 = 1(6,7)[OF b True]

      show ?thesis
      proof (cases "∃t ∈ set (the_msgs b). ∀s. t ≠ occurs s")
        case True show ?thesis
          using 4[of "unlabel [(l,send⟨?f (the_msgs b)⟩)]"
                     "unlabel (rm_occurs_msgs_constr A)"]
          unfolding a 7(1)[OF True] 6(3)[OF b] by simp
      next
        case False
        hence F: "∀t ∈ set (the_msgs b). ∃s. t = occurs s" by simp
        show ?thesis
          using 4[of "unlabel [(l,send⟨the_msgs b⟩)]" "unlabel (rm_occurs_msgs_constr A)"]
          unfolding a 7(2)[OF F] 6(2)[OF b] by simp
      qed
    next
      case False show ?thesis
        using 4[of "unlabel [(l,b)]" "unlabel (rm_occurs_msgs_constr A)"]
        unfolding a 1(5)[OF b False] 6(1)[OF b] by auto
    qed
    moreover have "iklsst (rm_occurs_msgs_constr (a#A)) ⊆ set ts ∪ iklsst (rm_occurs_msgs_constr A)"
      when b: "is_Receive b"
    proof (cases "∃t. occurs t ∈ set (the_msgs b)")
      case True
      note 8 = 1(3,4)[OF b True]

      show ?thesis
      proof (cases "∃t ∈ set (the_msgs b). ∀s. t ≠ occurs s")
        case True show ?thesis
          using 4[of "unlabel [(l,receive⟨?f (the_msgs b)⟩)]"
                     "unlabel (rm_occurs_msgs_constr A)"]
          unfolding a 8(1)[OF True] 6(6)[OF b] by auto
      next
        case False
        hence F: "∀t ∈ set (the_msgs b). ∃s. t = occurs s" by simp
        show ?thesis
          using 4[of "unlabel [(l,receive⟨the_msgs b⟩)]" "unlabel (rm_occurs_msgs_constr A)"]
          unfolding a 8(2)[OF F] 6(5)[OF b] by simp
      qed
    next
      case False show ?thesis
        using 4[of "unlabel [(l,b)]" "unlabel (rm_occurs_msgs_constr A)"]
        unfolding a 1(2)[OF b False] 6(4)[OF b] by auto
    qed
    moreover have "iklsst (a#A) = set ts ∪ iklsst A" when b: "is_Receive b"
      using iklsst_Cons(2)[of l ts A] unfolding a ts_cases(2)[OF b] by blast
    ultimately show ?thesis using IH 3 b_cases by blast
  qed (use 1(1) IH 5 a in auto)
qed simp

private lemma rm_occurs_msgs_constr_append:
  "rm_occurs_msgs_constr (A@B) = rm_occurs_msgs_constr A@rm_occurs_msgs_constr B"
by (induction A rule: rm_occurs_msgs_constr.induct) auto

private lemma rm_occurs_msgs_constr_duallsst:
  "rm_occurs_msgs_constr (duallsst A) = duallsst (rm_occurs_msgs_constr A)"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  show ?case using Cons.IH unfolding a by (cases b) auto
qed simp

private lemma rm_occurs_msgs_constr_dbupdsst_eq:
  "dbupdsst (unlabel (rm_occurs_msgs_constr A)) I D = dbupdsst (unlabel A) I D"
proof (induction A arbitrary: I D)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  show ?case
  proof (cases "is_Receive b ∨ is_Send b")
    case True
    then obtain ts where b: "b = receive⟨ts⟩ ∨ b = send⟨ts⟩" by (cases b) simp_all
    show ?thesis using rm_occurs_msgs_constr_Cons''[OF b, of l A] Cons.IH b unfolding a by fastforce
  next
    case False thus ?thesis using Cons.IH unfolding a by (cases b) auto
  qed
qed simp

private lemma rm_occurs_msgs_constr_subst:
  fixes A::"('a,'b,'c,'d) prot_strand" and θ::"('a,'b,'c,'d) prot_subst"
  assumes "∀x ∈ fvlsst A. ∄t. θ x = occurs t" "∀x ∈ fvlsst A. θ x ≠ Fun OccursSec []"
  shows "rm_occurs_msgs_constr (A ⋅lsst θ) = (rm_occurs_msgs_constr A) ⋅lsst θ"
    (is "?f (A ⋅lsst θ) = (?f A) ⋅lsst θ")
using assms
proof (induction A)
  case (Cons a A)
  note 0 = rm_occurs_msgs_constr_Cons
  note 1 = rm_occurs_msgs_constr_Cons'

  define f where "f ≡ ?f"
  define not_occ where "not_occ ≡ λt::('a,'b,'c,'d) prot_term. ∀s. t ≠ occurs s"
  define flt where "flt ≡ filter not_occ"

  obtain l b where a: "a = (l,b)" by (metis surj_pair)

  have 2: "∄t. θ x = occurs t" "θ x ≠ Fun OccursSec []"
    when b: "is_Receive b ∨ is_Send b" and t: "t ∈ set (the_msgs b)" and x: "x ∈ fv t" for x t
    using Cons.prems x t b unfolding a by (cases b; auto)+

  have IH: "f (A ⋅lsst θ) = (f A) ⋅lsst θ"
    using Cons.prems Cons.IH unfolding f_def by simp

  show ?case
  proof (cases "is_Receive b ∨ is_Send b")
    case True
    note T = this
    then obtain ts where ts: "b = receive⟨ts⟩ ∨ b = send⟨ts⟩" by (cases b) simp_all
    hence ts': "b ⋅sstp θ = receive⟨ts ⋅list θ⟩ ∨ b ⋅sstp θ = send⟨ts ⋅list θ⟩" by auto

    have the_msgs_b: "the_msgs b = ts" "the_msgs (b ⋅sstp θ) = ts ⋅list θ"
      using ts ts' by auto

    have 4: "is_Receive (b ⋅sstp θ) ∨ is_Send (b ⋅sstp θ)"
      using T by (cases b) simp_all

    note 6 = 1[OF T, of l A, unfolded f_def[symmetric]]
    note 7 = 1[OF 4, of l "A ⋅lsst θ", unfolded f_def[symmetric]]
    note 8 = ts IH subst_lsst_cons[of _ _ θ]

    have 9: "t ⋅ θ ∈ set (the_msgs (b ⋅sstp θ))" "not_occ (t ⋅ θ)"
      when t: "t ∈ set (the_msgs b)" "not_occ t" for t
    proof -
      show "t ⋅ θ ∈ set (the_msgs (b ⋅sstp θ))" using t ts ts' by auto
      moreover have "not_occ (t ⋅ θ)" when "t = Var x" for x
        using 2[OF T t(1)] t(2) unfolding that not_occ_def by simp
      moreover have "not_occ (t ⋅ θ)" when "t = Fun g ss" "g ≠ OccursFact" for g ss
        using 2[OF T t(1)] t(2) that(2) unfolding that(1) not_occ_def by simp
      moreover have "not_occ (t ⋅ θ)"
        when "t = Fun OccursFact ss" "∄s1 s2. ss = [s1,s2]" for ss
        using 2[OF T t(1)] t(2) that(2) unfolding that(1) not_occ_def by auto
      moreover have "not_occ (t ⋅ θ)"
        when "t = Fun OccursFact [s1,s2]" for s1 s2
        using 2[OF T t(1)] t(2) unfolding that not_occ_def by (cases s1) auto
      ultimately show "not_occ (t ⋅ θ)" by (cases t) (metis, metis)
    qed

    have 10: "not_occ t"
      when t: "t ∈ set (the_msgs b)" "not_occ (t ⋅ θ)" for t
    proof -
      have "t ⋅ θ ∈ set (the_msgs (b ⋅sstp θ))" using t ts ts' by auto
      moreover have "not_occ t" when "t = Var x" for x
        using 2[OF T t(1)] t(2) unfolding that not_occ_def by simp
      moreover have "not_occ t" when "t = Fun g ss" "g ≠ OccursFact" for g ss
        using 2[OF T t(1)] t(2) that(2) unfolding that(1) not_occ_def by simp
      moreover have "not_occ t"
        when "t = Fun OccursFact ss" "∄s1 s2. ss = [s1,s2]" for ss
        using 2[OF T t(1)] t(2) that(2) unfolding that(1) not_occ_def by auto
      moreover have "not_occ t"
        when "t = Fun OccursFact [s1,s2]" for s1 s2
        using 2[OF T t(1)] t(2) unfolding that not_occ_def by (cases s1) auto
      ultimately show "not_occ t" unfolding not_occ_def by force
    qed

    have 11: "not_occ (t ⋅ θ) ⟷ not_occ t" when "t ∈ set ts" for t
      using that 9 10 unfolding the_msgs_b by blast

    have 5: "(∃t. occurs t ∈ set ts) ⟷ (∃t. occurs t ∈ set ts ⋅set θ)"
      using 11 image_iff unfolding not_occ_def by fastforce

    have 12: "flt (ts ⋅list θ) = (flt ts) ⋅list θ" using 11 
    proof (induction ts)
      case (Cons t ts)
      hence "not_occ (t ⋅ θ) = not_occ t" "flt (ts ⋅list θ) = (flt ts) ⋅list θ" by auto
      thus ?case unfolding flt_def by auto
    qed (metis flt_def filter.simps(1) map_is_Nil_conv)

    show ?thesis
    proof (cases "∃t. occurs t ∈ set (the_msgs b)")
      case True
      note T1 = this
      hence T2: "∃t. occurs t ∈ set (the_msgs (b ⋅sstp θ))" using 5 unfolding the_msgs_b by simp

      show ?thesis
      proof (cases "∃t ∈ set (the_msgs b). ∀s. t ≠ occurs s")
        case True
        note T1' = this
        have T2': "∃t ∈ set (the_msgs (b ⋅sstp θ)). ∀s. t ≠ occurs s"
          using T1' 11 unfolding the_msgs_b not_occ_def by auto

        show ?thesis using T
        proof
          assume b: "is_Receive b"
          hence bθ: "is_Receive (b ⋅sstp θ)" using ts by fastforce

          show ?thesis
            using 6(3)[OF T1 T1' b] 7(3)[OF T2 T2' bθ] IH 12
            unfolding f_def[symmetric] a flt_def[symmetric] not_occ_def[symmetric] the_msgs_b
            by (simp add: subst_lsst_cons)
        next
          assume b: "is_Send b"
          hence bθ: "is_Send (b ⋅sstp θ)" using ts by fastforce

          show ?thesis
            using 6(2)[OF T1 T1' b] 7(2)[OF T2 T2' bθ] IH 12
            unfolding f_def[symmetric] a flt_def[symmetric] not_occ_def[symmetric] the_msgs_b
            by (simp add: subst_lsst_cons)
        qed
      next
        case False
        hence F: "∀t ∈ set (the_msgs b). ∃s. t = occurs s" by blast
        hence F': "∀t ∈ set (the_msgs (b ⋅sstp θ)). ∃s. t = occurs s" unfolding the_msgs_b by auto

        have *: "∃t. occurs t ∈ set (the_msgs b)" when "the_msgs b ≠ []"
          using that F by (cases "the_msgs b") auto
        hence **: "∃t. occurs t ∈ set (the_msgs (b ⋅sstp θ))" when "the_msgs b ≠ []"
          using that 5 unfolding the_msgs_b by simp

        show ?thesis
        proof (cases "ts = []")
          case True
          hence ***: "∄t. occurs t ∈ set (the_msgs b)" "∄t. occurs t ∈ set (the_msgs (b ⋅sstp θ))"
            unfolding the_msgs_b by simp_all

          show ?thesis
            using IH 6(1)[OF ***(1)] 7(1)[OF ***(2)]
            unfolding a f_def[symmetric] True
            by (simp add: subst_lsst_cons)
        next
          case False thus ?thesis
            using IH 6(4)[OF * F] 7(4)[OF ** F']
            unfolding f_def[symmetric] not_occ_def[symmetric] a the_msgs_b
            by (simp add: subst_lsst_cons)
        qed
      qed
    next
      case False
      note F = this
      have F': "∄t. occurs t ∈ set (the_msgs (b ⋅sstp θ))"
        using F 11 unfolding not_occ_def the_msgs_b by fastforce

      show ?thesis
        using IH 6(1)[OF F] 7(1)[OF F']
        unfolding a f_def[symmetric] True
        by (simp add: subst_lsst_cons)
    qed
  next
    case False
    hence *: "¬is_Receive b" "¬is_Send b" "¬is_Receive (b ⋅sstp θ)" "¬is_Send (b ⋅sstp θ)"
      by (cases b; auto)+

    show ?thesis
      using IH 0(1)[OF *(1,2), of l A] 0(1)[OF *(3,4), of l "A ⋅lsst θ"] subst_lsst_cons[of a _ θ]
      unfolding a f_def by simp
  qed
qed simp

private lemma rm_occurs_msgs_constr_transaction_strand:
  assumes T_adm: "admissible_transaction' T"
  shows "rm_occurs_msgs_constr (transaction_checks T) = transaction_checks T" (is ?A)
    and "rm_occurs_msgs_constr (transaction_updates T) = transaction_updates T" (is ?B)
    and "admissible_transaction_no_occurs_msgs T ⟹
          rm_occurs_msgs_constr (transaction_receive T) = transaction_receive T" (is "?C ⟹ ?C'")
    and "admissible_transaction_no_occurs_msgs T ⟹
          rm_occurs_msgs_constr (transaction_send T) = transaction_send T" (is "?D ⟹ ?D'")
proof -
  note 0 = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
  note 1 = wellformed_transaction_cases[OF 0]

  have 2: "∃ts. b = receive⟨ts⟩ ∧ (∄t. occurs t ∈ set ts)"
    when "admissible_transaction_no_occurs_msgs T" "(l,b) ∈ set (transaction_receive T)" for l b
    using that 1(1)[OF that(2)]
    unfolding admissible_transaction_no_occurs_msgs_def Let_def list_all_iff by fastforce

  have 3: "∃ts. b = send⟨ts⟩ ∧ (∄t. occurs t ∈ set ts)"
    when "admissible_transaction_no_occurs_msgs T" "(l,b) ∈ set (transaction_send T)" for l b
    using that 1(4)[OF that(2)]
    unfolding admissible_transaction_no_occurs_msgs_def Let_def list_all_iff by fastforce

  define A where "A ≡ transaction_receive T"
  define B where "B ≡ transaction_checks T"
  define C where "C ≡ transaction_updates T"
  define D where "D ≡ transaction_send T"

  show ?A using 1(2) unfolding B_def[symmetric]
  proof (induction B)
    case (Cons a A)
    hence IH: "rm_occurs_msgs_constr A = A" by (meson list.set_intros(2))
    obtain l b where a: "a = (l,b)" by (metis surj_pair)
    show ?case using Cons.prems IH unfolding a by (cases b) auto
  qed simp

  show ?B using 1(3) unfolding C_def[symmetric]
  proof (induction C)
    case (Cons a A)
    hence IH: "rm_occurs_msgs_constr A = A" by (meson list.set_intros(2))
    obtain l b where a: "a = (l,b)" by (metis surj_pair)
    show ?case using Cons.prems IH unfolding a by (cases b) auto
  qed simp

  show ?C' when ?C using 2[OF that] unfolding A_def[symmetric]
  proof (induction A)
    case (Cons a A)
    hence IH: "rm_occurs_msgs_constr A = A" by (meson list.set_intros(2))
    obtain l b where a: "a = (l,b)" by (metis surj_pair)
    obtain ts where b: "b = receive⟨ts⟩" using Cons.prems unfolding a by auto
    show ?case using Cons.prems IH unfolding a b by fastforce
  qed simp


  show ?D' when ?D using 3[OF that] unfolding D_def[symmetric]
  proof (induction D)
    case (Cons a A)
    hence IH: "rm_occurs_msgs_constr A = A" by (meson list.set_intros(2))
    obtain l b where a: "a = (l,b)" by (metis surj_pair)
    obtain ts where b: "b = send⟨ts⟩" using Cons.prems unfolding a by auto
    show ?case using Cons.prems IH unfolding a b by fastforce
  qed simp
qed

private lemma rm_occurs_msgs_constr_transaction_strand':
  fixes T::"('fun,'atom,'sets,'lbl) prot_transaction"
  assumes T_adm: "admissible_transaction' T"
    and T_no_occ: "admissible_transaction_no_occurs_msgs T"
  shows "rm_occurs_msgs_constr (transaction_strand (add_occurs_msgs T)) = transaction_strand T"
    (is "?f (?g (?h T)) = ?g T")
proof -
  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  have B: "B = transaction_fresh T" unfolding T by simp
  have F: "F = transaction_send T" unfolding T by simp

  define xs where "xs ≡ filter (λx. x ∉ set B) (fv_listsst (unlabel (transaction_strand T)))"

  note 0 = rm_occurs_msgs_constr_transaction_strand
  note 1 = add_occurs_msgs_admissible_occurs_checks[OF T_adm]
  note 2 = 0(3,4)[OF T_adm T_no_occ]
  note 3 = add_occurs_msgs_cases[OF T]
  note 4 = 0(1,2)[OF 1(1)]

  have 5: "?f (transaction_checks (?h T)) = transaction_checks T"
          "?f (transaction_updates (?h T)) = transaction_updates T"
    using 4 3(8,9) by (argo, argo)

  have 6: "?f (transaction_receive (?h T)) = transaction_receive T"
  proof (cases "xs = []")
    case True show ?thesis using 3(6)[OF True[unfolded xs_def B]] 2(1) by simp
  next
    case False show ?thesis
      using False 3(7)[OF False[unfolded xs_def B]] 2(1)
            rm_occurs_msgs_constr_Cons(4)[
              of "receive⟨map (λx. occurs (Var x)) xs⟩" ⋆ "transaction_receive T"]
      unfolding B[symmetric] xs_def[symmetric] 
      by (cases xs) (blast, auto)
  qed

  have 7: "?f (transaction_send (?h T)) = transaction_send T"
  proof (cases "∃ts' F'. F = ⟨⋆, send⟨ts'⟩⟩#F'")
    case True
    then obtain ts' F' where F': "F = ⟨⋆, send⟨ts'⟩⟩#F'" by blast

    have *: "transaction_send (?h T) = ⟨⋆, send⟨map (λx. occurs (Var x)) B@ts'⟩⟩#F'"
      using 3(1)[OF F'] unfolding T by fastforce

    have **: "ts' ≠ []" using admissible_transactionE(17)[OF T_adm] unfolding T F' by auto

    have ***: "∀s. t ≠ occurs s" when t: "t ∈ set ts'" for t
      using that T_no_occ
      unfolding T F' admissible_transaction_no_occurs_msgs_def Let_def list_all_iff by auto

    let ?ts = "map (λx. occurs (Var x)) B@ts'"

    have "∃t ∈ set ?ts. ∀s. t ≠ occurs s" using ** *** by (cases ts') auto
    moreover have "filter (λt. ∀s. t ≠ occurs s) ?ts = ts'" using *** by simp
    moreover have "∃t. occurs t ∈ set ?ts" when "B ≠ []" using that by (cases B) auto
    moreover have "?f [⟨⋆, send⟨ts'⟩⟩] = [⟨⋆, send⟨ts'⟩⟩]"
      using 2(2) ** *** unfolding F[symmetric] F' by force
    hence "?f F' = F'"
      using 2(2) rm_occurs_msgs_constr_append[of "[⟨⋆, send⟨ts'⟩⟩]" F']
      unfolding F[symmetric] F' by fastforce
    ultimately have "?f (⟨⋆, send⟨?ts⟩⟩#F') = ⟨⋆, send⟨ts'⟩⟩#F'"
      using 2(2) 3(10)[OF F'[unfolded F]] 3(12)
            rm_occurs_msgs_constr.simps(3)[of ⋆ ts' F']
            rm_occurs_msgs_constr_append[of "[⟨⋆, send⟨ts'⟩⟩]" F']
      unfolding F[symmetric] F' B[symmetric] by auto
    thus ?thesis using F * unfolding F' by argo
  next
    case False show ?thesis
      using 3(2)[OF False] 3(3) 2(2)
      unfolding B[symmetric] xs_def[symmetric] F[symmetric]
      by (cases B) auto
  qed

  show ?thesis
    using 5 6 7 rm_occurs_msgs_constr_append
    unfolding transaction_strand_def by metis
qed

private lemma rm_occurs_msgs_constr_transaction_strand'':
  fixes T::"('fun,'atom,'sets,'lbl) prot_transaction"
  assumes T_adm: "admissible_transaction' T"
    and T_no_occ: "admissible_transaction_no_occurs_msgs T"
    and θ: "∀x ∈ fv_transaction (add_occurs_msgs T). ∄t. θ x = occurs t"
           "∀x ∈ fv_transaction (add_occurs_msgs T). θ x ≠ Fun OccursSec []"
  shows "rm_occurs_msgs_constr (duallsst (transaction_strand (add_occurs_msgs T) ⋅lsst θ)) =
         duallsst (transaction_strand T ⋅lsst θ)"
using rm_occurs_msgs_constr_duallsst[of "transaction_strand (add_occurs_msgs T) ⋅lsst θ"]
      rm_occurs_msgs_constr_subst[OF θ] rm_occurs_msgs_constr_transaction_strand'[OF T_adm T_no_occ]
by argo

private lemma rm_occurs_msgs_constr_bvars_subst_eq:
  "bvarslsst (rm_occurs_msgs_constr A ⋅lsst θ) = bvarslsst (A ⋅lsst θ)"
proof -
  have "bvarslsst (rm_occurs_msgs_constr A) = bvarslsst A"
  proof (induction A)
    case (Cons a A)
    obtain l b where a: "a = (l,b)" by (metis surj_pair)
    show ?case using Cons.IH unfolding a by (cases b) auto
  qed simp
  thus ?thesis by (metis bvarssst_subst unlabel_subst)
qed

private lemma rm_occurs_msgs_constr_reachable_constraints_fv_eq:
  assumes P: "∀T ∈ set P. admissible_transaction' T"
             "∀T ∈ set P. admissible_transaction_no_occurs_msgs T"
    and A: "A ∈ reachable_constraints (map add_occurs_msgs P)"
  shows "fvlsst (rm_occurs_msgs_constr A) = fvlsst A"
using A
proof (induction A rule: reachable_constraints.induct)
  case (step 𝒜 T ξ σ α)
  let ?f = rm_occurs_msgs_constr
  let ?B = "duallsst (transaction_strand T ⋅lsst ξ ∘s σ ∘s α)"

  define θ where "θ ≡ ξ ∘s σ ∘s α"

  obtain T' where T': "T' ∈ set P" "T = add_occurs_msgs T'"
    using step.hyps(2) by auto

  have T_adm: "admissible_transaction' T"
    using add_occurs_msgs_admissible_occurs_checks(1) step.hyps(2) P by auto

  have T'_adm: "admissible_transaction' T'"
    and T'_no_occ: "admissible_transaction_no_occurs_msgs T'"
    using T'(1) P by (blast,blast)

  have "?f (duallsst (transaction_strand T ⋅lsst θ)) = duallsst (transaction_strand T' ⋅lsst θ)"
    using rm_occurs_msgs_constr_transaction_strand''[OF T'_adm T'_no_occ, of θ]
          admissible_transaction_decl_fresh_renaming_subst_not_occurs[OF T_adm step.hyps(3,4,5)]
    unfolding T'(2) θ_def[symmetric] by blast
  moreover have "fvlsst (transaction_strand T ⋅lsst θ) = fvlsst (transaction_strand T' ⋅lsst θ)"
    using add_occurs_msgs_vars_eq(6)[OF T'_adm, of θ] unfolding T'(2) by blast
  ultimately have "fvlsst (?f ?B) = fvlsst ?B"
    using fvsst_unlabel_duallsst_eq unfolding T'(2) θ_def[symmetric] by metis
  thus ?case
    using step.IH fvsst_append[of "unlabel 𝒜" "unlabel ?B"]
          rm_occurs_msgs_constr_append[of 𝒜 ?B]
    by force
qed simp

private lemma rm_occurs_msgs_constr_reachable_constraints_vars_eq:
  assumes P: "∀T ∈ set P. admissible_transaction' T"
             "∀T ∈ set P. admissible_transaction_no_occurs_msgs T"
    and A: "A ∈ reachable_constraints (map add_occurs_msgs P)"
  shows "varslsst (rm_occurs_msgs_constr A) = varslsst A"
using rm_occurs_msgs_constr_bvars_subst_eq[of _ Var]
      rm_occurs_msgs_constr_reachable_constraints_fv_eq[OF P A]
by (metis varssst_is_fvsst_bvarssst subst_lsst_id_subst)

private lemma rm_occurs_msgs_constr_reachable_constraints_trms_cases_aux:
  assumes A: "x ∈ fvsst A" "bvarssst A = {}"
    and t: "t = occurs (θ x)"
    and θ: "(∃y. θ x = Var y) ∨ (∃c. θ x = Fun c [])"
  shows "(∃x ∈ fvsst (A ⋅sst θ). t = occurs (Var x)) ∨
         (∃c. Fun c [] ⊑set trmssst (A ⋅sst θ) ∧ t = occurs (Fun c []))"
using A
proof (induction A)
  case (Cons a A)
  have 0: "bvarssst A = {}" "set (bvarssstp a) = {}" "set (bvarssstp a) ∩ subst_domain θ = {}"
    using Cons.prems(2) by auto

  note 1 = fvsst_Cons[of a A] trmssst_cons[of a A] subst_sst_cons[of a A θ]

  show ?case
  proof (cases "x ∈ fvsst A")
    case False
    hence x: "x ∈ fvsstp a" using Cons.prems(1) by simp

    note 2 = x t θ

    have 3: "θ x ⊑set trmssstp (a ⋅sstp θ)"
      using subst_subterms[OF fvsstp_is_subterm_trmssstp[OF x]] trmssstp_subst[OF 0(3)] by auto

    have "Fun c [] ⊑set trmssstp (a ⋅sstp θ)" when "θ x = Fun c []" for c
      using that 3 t by argo
    moreover have "y ∈ fvsstp (a ⋅sstp θ)" when "θ x = Var y" for y
      using that 3 var_subterm_trmssstp_is_varssstp[of y "a ⋅sstp θ"] 0(2) 
      unfolding varssstp_is_fvsstp_bvarssstp bvarssstp_subst by simp
    ultimately have
        "(∃x ∈ fvsstp (a ⋅sstp θ). t = occurs (Var x)) ∨
         (∃c. Fun c [] ⊑set trmssstp (a ⋅sstp θ) ∧ t = occurs (Fun c []))"
      using t θ by fast
    thus ?thesis using 1 by auto
  qed (use Cons.IH[OF _ 0(1)] 1 in force)
qed simp

private lemma rm_occurs_msgs_constr_reachable_constraints_trms_cases:
  assumes P: "∀T ∈ set P. admissible_transaction' T"
             "∀T ∈ set P. admissible_transaction_no_occurs_msgs T"
    and A: "A = rm_occurs_msgs_constr B"
    and B: "B ∈ reachable_constraints (map add_occurs_msgs P)"
    and t: "t ∈ trmslsst B"
  shows "t ∈ trmslsst A ∨ (∃x ∈ fvlsst A. t = occurs (Var x)) ∨
         (∃c. Fun c [] ⊑set (trmslsst A) ∧ t = occurs (Fun c []))"
    (is "?A A ∨ ?B A ∨ ?C A")
proof -
  define rm_occs where
    "rm_occs ≡ λA::('fun,'atom,'sets,'lbl) prot_strand. rm_occurs_msgs_constr A"
  define Q where "Q ≡ λA. ?A A ∨ ?B A ∨ ?C A"

  have 0: "Q B" when "Q A" "set A ⊆ set B" for A B
    using that unfolding Q_def fvsst_def trmssst_def unlabel_def by auto

  have "Q A" using B t unfolding A
  proof (induction rule: reachable_constraints.induct)
    case (step 𝒜 T ξ σ α)
    define θ where "θ ≡ ξ ∘s σ ∘s α"
    define ℬ where "ℬ ≡ duallsst (transaction_strand T ⋅lsst θ)"

    obtain T' where T': "T' ∈ set P" "T = add_occurs_msgs T'"
      using step.hyps(2) by auto

    note T'_adm = bspec[OF P(1) T'(1)] bspec[OF P(2) T'(1)]
    note T_adm = add_occurs_msgs_admissible_occurs_checks[OF T'_adm(1), unfolded T'(2)[symmetric]]

    note 1 = θ_def[symmetric] ℬ_def[symmetric] rm_occs_def[symmetric]
    note 2 = rm_occurs_msgs_constr_append[of 𝒜 ℬ, unfolded rm_occs_def[symmetric]]

    note 3 = admissible_transaction_decl_fresh_renaming_subst_not_occurs[
                OF T_adm(1) step.hyps(3,4,5)]

    have 4: "rm_occs (duallsst (transaction_strand T ⋅lsst θ)) =
             duallsst (transaction_strand T' ⋅lsst θ)"
      using 3 rm_occurs_msgs_constr_transaction_strand''[OF T'_adm]
      unfolding T'(2) 1 by blast 

    have 5: "(∃y. θ x = Var y) ∨ (∃c. θ x = Fun c [])" for x
      using transaction_decl_fresh_renaming_substs_range'(1)[OF step.hyps(3,4,5)]
      unfolding θ_def[symmetric] by blast

    show ?case
    proof (cases "t ∈ trmslsst 𝒜")
      case True show ?thesis using 0[OF step.IH[OF True]] unfolding 1 2 by simp
    next
      case False
      hence "t ∈ trmslsst ℬ" using step.prems unfolding ℬ_def θ_def by simp
      hence "t ∈ trmslsst (transaction_strand T' ⋅lsst θ) ∨
             (∃x ∈ fv_transaction T'. t = occurs (θ x))"
        using add_occurs_msgs_in_trms_subst_cases[OF T'_adm(1), of t θ]
        unfolding ℬ_def trmssst_unlabel_duallsst_eq T'(2) by blast
      moreover have "(∃y. θ x = Var y) ∨ (∃c. θ x = Fun c [])" for x
        using transaction_decl_fresh_renaming_substs_range'(1)[OF step.hyps(3,4,5)]
        unfolding θ_def[symmetric] by blast
      ultimately have "Q (rm_occs ℬ)"
        using rm_occurs_msgs_constr_reachable_constraints_trms_cases_aux[
                of _ "unlabel (transaction_strand T')" t θ]
              admissible_transactionE(4)[OF T'_adm(1)]
        unfolding Q_def ℬ_def 4 trmssst_unlabel_duallsst_eq fvsst_unlabel_duallsst_eq unlabel_subst
        by fast
      thus ?thesis using 0[of "rm_occs ℬ"] unfolding 1 2 by auto
    qed
  qed simp
  thus ?thesis unfolding Q_def by blast
qed

private lemma rm_occurs_msgs_constr_receive_attack_iff:
  fixes A::"('a,'b,'c,'d) prot_strand"
  shows "(∃ts. attack⟨n⟩ ∈ set ts ∧ receive⟨ts⟩ ∈ set (unlabel A)) ⟷
         (∃ts. attack⟨n⟩ ∈ set ts ∧ receive⟨ts⟩ ∈ set (unlabel (rm_occurs_msgs_constr A)))"
  (is "(∃ts. attack⟨n⟩ ∈ set ts ∧ ?A A ts) ⟷ (∃ts. attack⟨n⟩ ∈ set ts ∧ ?B A ts)")
proof
  let ?att = "λts. attack⟨n⟩ ∈ set ts"

  define f where "f ≡ λts::('a,'b,'c,'d) prot_term list. filter (λt. ∀s. t ≠ occurs s) ts"

  have 0: "?att ts ⟷ ?att (f ts)"
          "?att ts ⟹ ∃t. occurs t ∈ set ts ⟹ ∃t ∈ set ts. ∀s. t ≠ occurs s"
          "∄t. occurs t ∈ set ts ⟹ f ts = ts"
    for ts::"('a,'b,'c,'d) prot_term list"
    unfolding f_def
    subgoal by simp
    subgoal by auto
    subgoal by (induct ts) auto
    done

  have "?B A (f ts)" when A: "?A A ts" and ts: "?att ts" for ts using A
  proof (induction A)
    case (Cons a A)
    obtain l b where a: "a = (l,b)" by (metis surj_pair)

    show ?case
    proof (cases "?A A ts")
      case True thus ?thesis using Cons.IH unfolding a by (cases b) simp_all
    next
      case False
      hence b: "b = receive⟨ts⟩" using Cons.prems unfolding a by simp
      show ?thesis using 0(2)[OF ts] 0(3) unfolding a b f_def by simp
    qed
  qed simp
  thus "(∃ts. ?att ts ∧ ?A A ts) ⟹ (∃ts. ?att ts ∧ ?B A ts)" using 0(1) by metis

  have "∃ts'. ts = f ts' ∧ ?A A ts'" when B: "?B A ts" and ts: "?att ts" for ts using B
  proof (induction A)
    case (Cons a A)
    obtain l b where a: "a = (l,b)" by (metis surj_pair)

    note 1 = rm_occurs_msgs_constr_Cons

    have 2: "receive⟨ts⟩ ∈ set (unlabel (rm_occurs_msgs_constr A))"
      when rcv_ts: "receive⟨ts⟩ ∈ set (unlabel (rm_occurs_msgs_constr ((l,send⟨ts'⟩)#A)))"
      for l ts ts' and A::"('a,'b,'c,'d) prot_strand"
    proof -
      have *: "is_Send (send⟨ts'⟩)" by simp

      have "set (unlabel (rm_occurs_msgs_constr [(l, send⟨ts'⟩)])) ⊆ {send⟨ts'⟩, send⟨f ts'⟩}"
        using 1(5-7)[OF *, of l "[]"] unfolding f_def by auto
      thus ?thesis using rcv_ts rm_occurs_msgs_constr_append[of "[(l,send⟨ts'⟩)]" A] by auto
    qed

    show ?case
    proof (cases "?B A ts")
      case True thus ?thesis using Cons.IH by auto
    next
      case False
      hence 3: "receive⟨ts⟩ ∈ set (unlabel (rm_occurs_msgs_constr [a]))"
        using rm_occurs_msgs_constr_append[of "[a]" A] Cons.prems by simp

      obtain ts' where b: "b = receive⟨ts'⟩" and b': "is_Receive b"
        using 2[of ts l _ A] Cons.prems False
        unfolding a by (cases b) auto

      have ts': "the_msgs (receive⟨ts'⟩) = ts'" by simp

      have "∃t ∈ set (the_msgs b). ∀s. t ≠ occurs s" when "∃t. occurs t ∈ set (the_msgs b)"
        using that 3 1(4)[OF b' that, of l "[]"] unfolding a by force
      hence "ts = f ts'"
        using 3 0(3)[of ts'] 1(3)[OF b', of l "[]", unfolded rm_occurs_msgs_constr.simps(1)]
        unfolding a b ts' f_def[symmetric] by fastforce
      thus ?thesis unfolding a b by auto
    qed
  qed simp
  thus "(∃ts. ?att ts ∧ ?B A ts) ⟹ (∃ts. ?att ts ∧ ?A A ts)" using 0 by metis
qed

private lemma add_occurs_msgs_soundness_aux1:
  fixes P::"('fun,'atom,'sets,'lbl) prot"
  defines "wt_attack ≡ λℐ 𝒜 l n. welltyped_constraint_model ℐ (𝒜@[(l, send⟨[attack⟨n⟩]⟩)])"
  assumes P: "∀T ∈ set P. admissible_transaction' T"
    and P_val: "has_initial_value_producing_transaction P"
    and A: "𝒜 ∈ reachable_constraints P" "wt_attack ℐ 𝒜 l n"
  shows "∃ℬ ∈ reachable_constraints P. ∃𝒥.
          wt_attack 𝒥 ℬ l n ∧ (∀x ∈ fvlsst ℬ. ∃n. 𝒥 x = Fun (Val n) [])"
proof -
  let ?f = "λ(T,ξ,σ,α). duallsst (transaction_strand T ⋅lsst ξ ∘s σ ∘s α)"
  let ?g = "concat ∘ map ?f"
  let ?rcv_att = "λA n. receive⟨[attack⟨n⟩]⟩ ∈ set (unlabel A)"
  let ?wt_model = welltyped_constraint_model

  define valconst_cases where "valconst_cases ≡
    λI::('fun,'atom,'sets,'lbl) prot_subst. λx.
      (∃n. I x = Fun (Val n) []) ∨ (∃n. I x = Fun (PubConst Value n) [])"

  define valconsts_only where "valconsts_only ≡
    λX. λI::('fun,'atom,'sets,'lbl) prot_subst. ∀x ∈ X. ∃n. I x = Fun (Val n) []"

  define db_eq where "db_eq ≡
    λA B::('fun,'atom,'sets,'lbl) prot_constr. λs. λupds::('fun,'atom,'sets,'lbl) prot_constr.
      let f = filter is_Update ∘ unlabel;
          g = filter (λa. ∄l t ts. a = (l,insert⟨t,Fun (Set s) ts⟩))
      in (upds = [] ∧ f A = f B) ∨ (upds ≠ [] ∧ f (g A) = f (g B))"

  define db_upds_consts_fresh where "db_upds_consts_fresh ≡
    λA::('fun,'atom,'sets,'lbl) prot_constr. λX. λJ::('fun,'atom,'sets,'lbl) prot_subst. 
      ∀x ∈ X. (∃n. ℐ x = Fun (PubConst Value n) []) ⟶ (∀n s.
        insert⟨Fun (Val n) [],s⟩ ∈ set (unlabel A) ∨
        delete⟨Fun (Val n) [],s⟩ ∈ set (unlabel A) ⟶
          J x ≠ Fun (Val n) [])"

  define subst_eq_on_privvals where "subst_eq_on_privvals ≡ λX 𝒥.
    ∀x ∈ X. (∃n. ℐ x = Fun (Val n) []) ⟶ ℐ x = 𝒥 x"

  define subst_in_ik_if_subst_pubval where "subst_in_ik_if_subst_pubval ≡
    λX 𝒥. λℬ::('fun,'atom,'sets,'lbl) prot_constr.
      ∀x ∈ X. (∃n. ℐ x = Fun (PubConst Value n) []) ⟶ 𝒥 x ∈ iklsst ℬ"

  define subst_eq_iff where "subst_eq_iff ≡ λX. λ𝒥::('fun,'atom,'sets,'lbl) prot_subst.
    ∀x ∈ X. ∀y ∈ X. ℐ x = ℐ y ⟷ 𝒥 x = 𝒥 y"

  obtain x_val T_val T_upds s_val ts_val l1_val l2_val where x_val:
      "T_val ∈ set P" "Var x_val ∈ set ts_val" "Γv x_val = TAtom Value"
      "fvset (set ts_val) = {x_val}" "∀n. ¬(Fun (Val n) [] ⊑set set ts_val)"
      "T_val = Transaction (λ(). []) [x_val] [] [] T_upds [(l1_val,send⟨ts_val⟩)]"
      "T_upds = [] ∨
       (T_upds = [(l2_val,insert⟨Var x_val,⟨s_val⟩s⟩)] ∧
        (∀T ∈ set P. ∀(l,a) ∈ set (transaction_strand T). ∀t.
          a ≠ select⟨t,⟨s_val⟩s⟩ ∧ a ≠ ⟨t in ⟨s_val⟩s⟩ ∧ a ≠ ⟨t not in ⟨s_val⟩s⟩ ∧
          a ≠ delete⟨t,⟨s_val⟩s⟩))"
    using has_initial_value_producing_transactionE[OF P_val P, of thesis]
    by (auto simp add: disj_commute)

  have 0: "∄n. Fun (PubConst Value n) [] ⊑set trmslsst ℬ" when "ℬ ∈ reachable_constraints P" for ℬ
    using reachable_constraints_val_funs_private(1)[OF that P(1)] funs_term_Fun_subterm'
    unfolding is_PubConstValue_def by fastforce

  have I: "?wt_model ℐ 𝒜" "interpretationsubst ℐ" "wftrms (subst_range ℐ)" "wtsubst ℐ"
    using welltyped_constraint_model_prefix[OF A(2)[unfolded wt_attack_def]]
          A(2)[unfolded wt_attack_def welltyped_constraint_model_def constraint_model_def]
    by blast+

  have 1: "∀x ∈ fvlsst 𝒜. valconst_cases ℐ x"
    using reachable_constraints_fv_Value_const_cases[OF P(1) A(1) I(1)]
    unfolding valconst_cases_def by blast

  have 2: "?rcv_att 𝒜 n"
    using A(2) strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" "[send⟨[attack⟨n⟩]⟩]" ℐ]
          reachable_constraints_receive_attack_if_attack'(2)[OF A(1) P(1) I(1)]
    unfolding wt_attack_def welltyped_constraint_model_def constraint_model_def by simp

  note ξ_empty = admissible_transaction_decl_subst_empty[OF bspec[OF P(1)]]

  have lmm:
      "∃ℬ ∈ reachable_constraints P. ∃𝒥.
          ?wt_model 𝒥 ℬ ∧ valconsts_only (fvlsst 𝒜 ∪ X) 𝒥 ∧ (?rcv_att 𝒜 n ⟶ ?rcv_att ℬ n) ∧
          subst_eq_on_privvals (fvlsst 𝒜 ∪ X) 𝒥 ∧
          subst_in_ik_if_subst_pubval (fvlsst 𝒜 ∪ X) 𝒥 ℬ ∧
          subst_eq_iff (fvlsst 𝒜 ∪ X) 𝒥 ∧
          varslsst 𝒜 = varslsst ℬ ∧ fvlsst 𝒜 = fvlsst ℬ ∧
          (∀n ∈ N. ¬(Fun (Val n) [] ⊑set trmslsst ℬ)) ∧
          iklsst 𝒜 ⊆ iklsst ℬ ∧ trmslsst 𝒜 ⊆ trmslsst ℬ ∧
          db_eq 𝒜 ℬ s_val T_upds ∧
          db_upds_consts_fresh 𝒜 (fvlsst 𝒜 ∪ X) 𝒥"
    when "finite N" "∀n ∈ N. ¬(Fun (Val n) [] ⊑set trmslsst 𝒜)" "X ∩ fvlsst 𝒜 = {}"
         "finite X" "∀x ∈ X. valconst_cases ℐ x" "∀x ∈ X. Γv x = TAtom Value"
    for N X
    using A(1) I(1) 1 that
  proof (induction arbitrary: N X rule: reachable_constraints.induct)
    case init
    define pubvals where "pubvals ≡ {n | n x. x ∈ X ∧ ℐ x = Fun (PubConst Value n) []}"
    define X_vals where "X_vals ≡ {n | n x. x ∈ X ∧ ℐ x = Fun (Val n) []}"

    have X_vals_finite: "finite X_vals"
      using finite_surj[OF init.prems(6),
                        of X_vals "λx. THE n. ℐ x = Fun (Val n) []"]
      unfolding X_vals_def by force

    have pubvals_finite: "finite pubvals"
      using finite_surj[OF init.prems(6),
                        of pubvals "λx. THE n. ℐ x = Fun (PubConst Value n) []"]
      unfolding pubvals_def by force

    obtain T_val_fresh_vals and δ::"nat ⇒ nat"
      where T_val_fresh_vals: "T_val_fresh_vals ∩ (N ∪ X_vals) = {}"
        and δ: "inj δ" "δ ` pubvals = T_val_fresh_vals"
      using ex_finite_disj_nat_inj[OF pubvals_finite finite_UnI[OF init.prems(3) X_vals_finite]]
      by blast

    have T_val_fresh_vals_finite: "finite T_val_fresh_vals"
      using pubvals_finite δ(2) by blast

    obtain ℬ::"('fun,'atom,'sets,'lbl) prot_constr"
      where B:
          "ℬ ∈ reachable_constraints P"
          "T_upds = [] ⟹ list_all is_Receive (unlabel ℬ)"
          "T_upds ≠ [] ⟹ list_all (λa. is_Insert a ∨ is_Receive a) (unlabel ℬ)"
          "varslsst ℬ = {}"
          "∀n. Fun (Val n) [] ⊑set trmslsst ℬ ⟶ Fun (Val n) [] ∈ iklsst ℬ"
          "T_val_fresh_vals = {n. Fun (Val n) [] ∈ iklsst ℬ}"
          "∀l a. (l,a) ∈ set ℬ ∧ is_Insert a ⟶
                  (l = l2_val ∧ (∃n. a = insert⟨Fun (Val n) [],⟨s_val⟩s⟩))"
      using reachable_constraints_initial_value_transaction[
              OF P reachable_constraints.init T_val_fresh_vals_finite _ x_val]
      by auto

    define 𝒥 where "𝒥 ≡ λx.
      if x ∈ X ∧ (∃n. ℐ x = Fun (PubConst Value n) [])
      then Fun (Val (δ (THE n. ℐ x = Fun (PubConst Value n) []))) []
      else ℐ x"

    have 0: "iklsst [] ⊆ iklsst ℬ" "trmslsst [] ⊆ trmslsst ℬ" "?rcv_att [] n ⟶ ?rcv_att ℬ n"
            "varslsst [] = varslsst ℬ" "fvlsst [] = fvlsst ℬ"
      using B(4) varssst_is_fvsst_bvarssst[of "unlabel ℬ"] by auto

    have 1: "db_eq [] ℬ s_val T_upds" using B(2,3,7)
    proof (induction ℬ)
      case (Cons a B)
      then obtain l b where a: "a = (l,b)" by (metis surj_pair)

      have IH: "db_eq [] B s_val T_upds" using Cons.prems Cons.IH by auto

      show ?case
      proof (cases "T_upds = []")
        case True
        hence "is_Receive b" using a Cons.prems(1) by simp
        thus ?thesis using IH unfolding a db_eq_def Let_def by auto
      next
        case False
        hence "is_Insert b ∨ is_Receive b" using a Cons.prems(2) by simp
        hence "∃t. a = (l2_val,insert⟨t,⟨s_val⟩s⟩)" when b: "¬is_Receive b"
          using b Cons.prems(3) unfolding a by (metis list.set_intros(1))
        thus ?thesis using IH False unfolding a db_eq_def Let_def by auto
      qed
    qed (simp add: db_eq_def)

    have 2: "?wt_model 𝒥 ℬ"
      unfolding welltyped_constraint_model_def constraint_model_def
    proof (intro conjI)
      show "wtsubst 𝒥" using I(4) init.prems(8) unfolding 𝒥_def wtsubst_def by fastforce

      show "strand_sem_stateful {} {} (unlabel ℬ) 𝒥"
        using B(2,3) strand_sem_stateful_if_no_send_or_check[of "unlabel ℬ" "{}" "{}" 𝒥]
        unfolding list_all_iff by blast

      show "subst_domain 𝒥 = UNIV" "ground (subst_range 𝒥)"
        using I(2) unfolding 𝒥_def subst_domain_def by auto

      show "wftrms (subst_range 𝒥)"
        using I(3) unfolding 𝒥_def by fastforce
    qed

    have 3: "valconsts_only (fvlsst [] ∪ X) 𝒥"
      using init.prems(7) unfolding 𝒥_def valconsts_only_def valconst_cases_def by fastforce

    have 4: "subst_eq_on_privvals (fvlsst [] ∪ X) 𝒥"
      unfolding subst_eq_on_privvals_def 𝒥_def by force

    have 5: "subst_in_ik_if_subst_pubval (fvlsst [] ∪ X) 𝒥 ℬ"
    proof (unfold subst_in_ik_if_subst_pubval_def; intro ballI impI)
      fix x assume x: "x ∈ fvlsst [] ∪ X" and "∃n. ℐ x = Fun (PubConst Value n) []"
      then obtain n where n: "ℐ x = Fun (PubConst Value n) []" by blast 

      have "n ∈ pubvals" using x n unfolding pubvals_def by fastforce
      hence "δ n ∈ T_val_fresh_vals" using δ(2) by fast
      hence "Fun (Val (δ n)) [] ∈ iklsst ℬ" using B(6) by fast
      thus "𝒥 x ∈ iklsst ℬ" using x n unfolding 𝒥_def by simp
    qed

    have 6: "subst_eq_iff (fvlsst [] ∪ X) 𝒥"
    proof (unfold subst_eq_iff_def; intro ballI)
      fix x y assume "x ∈ fvlsst [] ∪ X" "y ∈ fvlsst [] ∪ X"
      hence x: "x ∈ X" and y: "y ∈ X" by auto

      show "ℐ x = ℐ y ⟷ 𝒥 x = 𝒥 y"
      proof
        show "ℐ x = ℐ y ⟹ 𝒥 x = 𝒥 y" using x y unfolding 𝒥_def by presburger
      next
        assume J_eq: "𝒥 x = 𝒥 y" show "ℐ x = ℐ y"
        proof (cases "∃n. ℐ x = Fun (PubConst Value n) []")
          case True
          then obtain n where n: "ℐ x = Fun (PubConst Value n) []" by blast
          hence J_x: "𝒥 x = Fun (Val (δ n)) []" using x unfolding 𝒥_def by simp

          show ?thesis
          proof (cases "∃m. ℐ y = Fun (PubConst Value m) []")
            case True
            then obtain m where m: "ℐ y = Fun (PubConst Value m) []" by blast
            have J_y: "𝒥 y = Fun (Val (δ m)) []" using y m unfolding 𝒥_def by simp
            show ?thesis using J_eq J_x J_y injD[OF δ(1), of n m] n m by auto
          next
            case False
            then obtain m where m: "ℐ y = Fun (Val m) []"
              using init.prems(7) y unfolding valconst_cases_def by blast
            moreover have "δ n ∈ T_val_fresh_vals" using δ(2) x n unfolding pubvals_def by blast
            moreover have "m ∈ X_vals" using y m unfolding X_vals_def by blast
            ultimately have "𝒥 x ≠ ℐ y" using m J_x T_val_fresh_vals by auto
            moreover have "𝒥 y = ℐ y" using m unfolding 𝒥_def by simp
            ultimately show ?thesis using J_eq by argo
          qed
        next
          case False
          then obtain n where n: "ℐ x = Fun (Val n) []"
            using init.prems(7) x unfolding valconst_cases_def by blast
          hence J_x: "𝒥 x = ℐ x" unfolding 𝒥_def by auto

          show ?thesis
          proof (cases "∃m. ℐ y = Fun (PubConst Value m) []")
            case False
            then obtain m where m: "ℐ y = Fun (Val m) []"
              using init.prems(7) y unfolding valconst_cases_def by blast
            have J_y: "𝒥 y = ℐ y" using y m unfolding 𝒥_def by simp
            show ?thesis using J_x J_y J_eq by presburger
          next
            case True
            then obtain m where m: "ℐ y = Fun (PubConst Value m) []" by blast
            hence "𝒥 y = Fun (Val (δ m)) []" using y unfolding 𝒥_def by fastforce
            moreover have "δ m ∈ T_val_fresh_vals" using δ(2) y m unfolding pubvals_def by blast
            moreover have "n ∈ X_vals" using x n unfolding X_vals_def by blast
            ultimately have "𝒥 y ≠ ℐ x" using n J_x T_val_fresh_vals by auto
            thus ?thesis using J_x J_eq by argo
          qed
        qed
      qed
    qed

    have 7: "∀n ∈ N. Fun (Val n) [] ∉ subtermsset (trmslsst ℬ)"
      using B(5,6) T_val_fresh_vals by blast

    have 8: "db_upds_consts_fresh [] (fvlsst [] ∪ X) 𝒥" unfolding db_upds_consts_fresh_def by simp

    show ?case using B(1) 0 1 2 3 4 5 6 7 8 by blast
  next
    case (step 𝒜 T ξ σ α N X')
    define θ where "θ ≡ ξ ∘s σ ∘s α"
    define T' where "T' ≡ duallsst (transaction_strand T ⋅lsst θ)"
    define T'_pubvals where "T'_pubvals ≡ {n. ∃x ∈ fvlsst T'. ℐ x = Fun (PubConst Value n) []}"
    define 𝒜_vals where "𝒜_vals ≡ {n. Fun (Val n) [] ⊑set trmslsst 𝒜}"
    define ℐ_vals where "ℐ_vals ≡ {n. ∃x ∈ fvlsst 𝒜 ∪ X' ∪ fvlsst T'. ℐ x = Fun (Val n) []}"
    define σ_vals where "σ_vals ≡ {n. Fun (Val n) [] ∈ subst_range σ}"

    have 3: "welltyped_constraint_model ℐ 𝒜"
            "∀x ∈ fvlsst 𝒜. valconst_cases ℐ x"
            "∀x ∈ fvlsst T'. valconst_cases ℐ x"
            "strand_sem_stateful (iklsst 𝒜 ⋅set ℐ) (dbupdsst (unlabel 𝒜) ℐ {}) (unlabel T') ℐ"
            "∀x ∈ fvlsst 𝒜 ∪ X'. valconst_cases ℐ x"
      using step.prems(2) welltyped_constraint_model_prefix[OF step.prems(1)]
            step.prems(1)[unfolded welltyped_constraint_model_def constraint_model_def]
            strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" "unlabel T'" ℐ]
            step.prems(7)
      unfolding θ_def[symmetric] T'_def[symmetric] unlabel_append fvsst_append
      by (blast,blast,blast,simp,blast)

    note T_adm = bspec[OF P step.hyps(2)]
    note T_wf = admissible_transaction_is_wellformed_transaction[OF T_adm]
    note ξ_empty = admissible_transaction_decl_subst_empty[OF T_adm step.hyps(3)]

    note 4 = admissible_transaction_sem_iff
    note 5 = iffD1[OF 4[OF T_adm I(2,3), of "iklsst 𝒜 ⋅set ℐ" "dbupdsst (unlabel 𝒜) ℐ {}" θ,
                        unfolded T'_def[symmetric]]
                      3(4)]

    note σ_dom = transaction_fresh_subst_domain[OF step.hyps(4)]

    have σ_ran: "∃n. t = Fun (Val n) []" when t: "t ∈ subst_range σ" for t
    proof -
      obtain x where x: "x ∈ set (transaction_fresh T)" "t = σ x"
        using σ_dom t by auto
      show ?thesis
        using x(1) admissible_transactionE(2)[OF T_adm]
              transaction_fresh_subst_sends_to_val[OF step.hyps(4) x(1)]
        unfolding x(2) by meson
    qed

    have T'_vals_in_σ: "Fun (Val k) [] ∈ subst_range σ"
      when k: "Fun (Val k) [] ⊑set trmslsst T'" for k
    proof -
      have "Fun (Val k) [] ∈ (subtermsset (trms_transaction T)) ⋅set θ"
        using k admissible_transactionE(4)[OF T_adm]
              transaction_decl_fresh_renaming_substs_trms[
                OF step.hyps(3,4,5), of "transaction_strand T"]
        unfolding T'_def θ_def[symmetric] trmssst_unlabel_duallsst_eq by fast
      then obtain t where t: "t ⊑set trms_transaction T" "t ⋅ θ = Fun (Val k) []" by force
      hence "Fun (Val k) [] ∈ subst_range θ"
        using admissible_transactions_no_Value_consts(1)[OF T_adm] by (cases t) force+
      thus ?thesis
        using transaction_decl_fresh_renaming_substs_range'(4)[OF step.hyps(3,4,5)] ξ_empty
        unfolding θ_def[symmetric] by blast
    qed

    have σ_vals_is_T'_vals: "k ∈ σ_vals ⟷ Fun (Val k) [] ⊑set trmslsst T'" for k
    proof
      show "k ∈ σ_vals" when "Fun (Val k) [] ⊑set trmslsst T'"
        using that T'_vals_in_σ unfolding σ_vals_def by blast

      show "Fun (Val k) [] ⊑set trmslsst T'" when k: "k ∈ σ_vals"
      proof -
        have "Fun (Val k) [] ∈ subst_range σ" using k unfolding σ_vals_def by fast
        then obtain x where x: "x ∈ fv_transaction T" "σ x = Fun (Val k) []"
          using admissible_transactionE(7)[OF T_adm]
                transaction_fresh_subst_domain[OF step.hyps(4)]
         unfolding fv_transaction_unfold by fastforce

        have "θ x = Fun (Val k) []" using x(2) unfolding θ_def ξ_empty subst_compose_def by auto
        thus ?thesis
          using fvsst_is_subterm_trmssst_subst[OF x(1), of θ]
                admissible_transactionE(4)[OF T_adm]
          unfolding T'_def trmssst_unlabel_duallsst_eq unlabel_subst by simp
      qed
    qed

    have σ_vals_N_disj: "N ∩ σ_vals = {}"
      using step.prems(4) σ_vals_is_T'_vals
      unfolding θ_def[symmetric] T'_def[symmetric] unlabel_append trmssst_append by blast

    have T'_pubvals_finite: "finite T'_pubvals"
      using finite_surj[OF fvsst_finite[of "unlabel T'"],
                        of T'_pubvals "λx. THE n. ℐ x = Fun (PubConst Value n) []"]
      unfolding T'_pubvals_def by force

    have σ_vals_finite: "finite σ_vals"
    proof -
      have *: "finite (subst_range σ)" using transaction_fresh_subst_domain[OF step.hyps(4)] by simp
      show ?thesis
        using finite_surj[OF *, of σ_vals "λt. THE n. t = Fun (Val n) []"]
        unfolding σ_vals_def by force
    qed

    have 𝒜_vals_finite: "finite 𝒜_vals"
    proof -
      have *: "𝒜_vals ⊆ (λt. THE n. t = Fun (Val n) []) ` subtermsset (trmslsst 𝒜)"
        unfolding 𝒜_vals_def by force
      show ?thesis
        by (rule finite_surj[OF subterms_union_finite[OF trmssst_finite] *])
    qed

    have ℐ_vals_finite: "finite ℐ_vals"
    proof -
      define X where "X ≡ fvlsst 𝒜 ∪ X' ∪ fvlsst T'"
      have *: "finite X" using fvsst_finite step.prems(6) unfolding X_def by blast
      show ?thesis
        using finite_surj[OF *, of ℐ_vals "λx. THE n. ℐ x = Fun (Val n) []"]
        unfolding ℐ_vals_def X_def[symmetric] by force
    qed

    obtain T_val_fresh_vals and δ::"nat ⇒ nat"
      where T_val_fresh_vals: "T_val_fresh_vals ∩ (N ∪ σ_vals ∪ 𝒜_vals ∪ ℐ_vals) = {}"
        and δ: "inj δ" "δ ` T'_pubvals = T_val_fresh_vals"
      using step.prems(3) T'_pubvals_finite σ_vals_finite 𝒜_vals_finite ℐ_vals_finite
      by (metis finite_UnI ex_finite_disj_nat_inj)

    define N' where "N' ≡ N ∪ σ_vals ∪ T_val_fresh_vals"

    have T_val_fresh_vals_finite: "finite T_val_fresh_vals"
      using T'_pubvals_finite δ(2) by blast

    have N'_finite: "finite N'"
      using step.prems(3) T'_pubvals_finite T_val_fresh_vals_finite σ_vals_finite
      unfolding N'_def by auto

    have 𝒜_vals_trms_in: "n ∈ 𝒜_vals" when "Fun (Val n) [] ⊑set trmslsst 𝒜" for n
      using that unfolding 𝒜_vals_def by blast

    have N'_notin_𝒜: "¬(Fun (Val n) [] ⊑set trmslsst 𝒜)" when n: "n ∈ N'" for n
    proof -
      have ?thesis when n': "n ∈ N"
        using n' step.prems(4) unfolding N'_def unlabel_append trmssst_append by blast
      moreover have ?thesis when n': "n ∈ σ_vals"
        using n' step.hyps(4) unfolding σ_vals_def transaction_fresh_subst_def by blast
      moreover have ?thesis when n': "n ∈ T_val_fresh_vals"
        using n' T_val_fresh_vals 𝒜_vals_trms_in by blast
      ultimately show ?thesis using n unfolding N'_def by blast
    qed

    have T'_fv_𝒜_disj: "fvlsst 𝒜 ∩ fvlsst T' = {}"
      using transaction_decl_fresh_renaming_substs_vars_disj(8)[OF step.hyps(3,4,5)]
            transaction_decl_fresh_renaming_substs_vars_subset(4)[OF step.hyps(3,4,5,2)]
      unfolding θ_def[symmetric] T'_def fvsst_unlabel_duallsst_eq by blast

    have X'_disj: "X' ∩ fvlsst 𝒜 = {}" "X' ∩ fvlsst T' = {}"
      using step.prems(5)
      unfolding θ_def[symmetric] T'_def[symmetric] unlabel_append fvsst_append
      by (blast, blast)

    have X'_disj': "(X' ∪ fvlsst T') ∩ fvlsst 𝒜 = {}"
      using X'_disj(1) T'_fv_𝒜_disj by blast

    have X'_finite: "finite (X' ∪ fvlsst T')"
      using step.prems(6) fvsst_finite by blast

    have 𝒜_X'_valconstcases: "∀x ∈ X' ∪ fvlsst T'. valconst_cases ℐ x"
      using 3(3,5) by blast

    have T'_value_vars: "Γv x = TAtom Value" when x: "x ∈ fvlsst T'" for x
      using x reachable_constraints_fv_Value_typed[
                OF P reachable_constraints.step[OF step.hyps]]
      unfolding θ_def[symmetric] T'_def[symmetric] unlabel_append fvsst_append by blast

    have X'_T'_value_vars: "∀x ∈ X' ∪ fvlsst T'. Γv x = TAtom Value"
      using step.prems(8) T'_value_vars by blast

    have N'_not_subterms_𝒜: "∀n ∈ N'. ¬(Fun (Val n) [] ⊑set trmslsst 𝒜)"
      using N'_notin_𝒜 by blast

    obtain ℬ 𝒥 where B:
        "ℬ ∈ reachable_constraints P" "?wt_model 𝒥 ℬ"
        "valconsts_only (fvlsst 𝒜 ∪ X' ∪ fvlsst T') 𝒥" "?rcv_att 𝒜 n ⟶ ?rcv_att ℬ n"
        "subst_eq_on_privvals (fvlsst 𝒜 ∪ X' ∪ fvlsst T') 𝒥"
        "subst_in_ik_if_subst_pubval (fvlsst 𝒜 ∪ X' ∪ fvlsst T') 𝒥 ℬ"
        "subst_eq_iff (fvlsst 𝒜 ∪ X' ∪ fvlsst T') 𝒥"
        "varslsst 𝒜 = varslsst ℬ" "fvlsst 𝒜 = fvlsst ℬ" "iklsst 𝒜 ⊆ iklsst ℬ" "trmslsst 𝒜 ⊆ trmslsst ℬ"
        "∀n ∈ N'. ¬(Fun (Val n) [] ⊑set trmslsst ℬ)"
        "db_eq 𝒜 ℬ s_val T_upds"
        "db_upds_consts_fresh 𝒜 (fvlsst 𝒜 ∪ X' ∪ fvlsst T') 𝒥"
      using step.IH[OF 3(1,2) N'_finite N'_not_subterms_𝒜 X'_disj' X'_finite
                       𝒜_X'_valconstcases X'_T'_value_vars]
      unfolding Un_assoc by fast

    have J:
        "wtsubst 𝒥" "constr_sem_stateful 𝒥 (unlabel ℬ)"
        "interpretationsubst 𝒥" "wftrms (subst_range 𝒥)"
      using B(2) unfolding welltyped_constraint_model_def constraint_model_def by blast+

    have T_val_fresh_vals_notin_ℬ: "¬(Fun (Val n) [] ⊑set trmslsst ℬ)"
        when "n ∈ T_val_fresh_vals" for n
      using that B(12) unfolding N'_def by blast
    hence "∀n ∈ T_val_fresh_vals. ¬(Fun (Val n) [] ⊑set trmslsst ℬ)" by blast
    then obtain T_val_constr::"('fun,'atom,'sets,'lbl) prot_constr"
      where T_val_constr:
          "ℬ@T_val_constr ∈ reachable_constraints P"
          "T_val_constr ∈ reachable_constraints P"
          "T_upds = [] ⟹ list_all is_Receive (unlabel T_val_constr)"
          "T_upds ≠ [] ⟹ list_all (λa. is_Insert a ∨ is_Receive a) (unlabel T_val_constr)"
          "varslsst T_val_constr = {}"
          "∀n. Fun (Val n) [] ⊑set trmslsst ℬ ⟶ Fun (Val n) [] ∉ iklsst T_val_constr"
          "∀n. Fun (Val n) [] ⊑set trmslsst T_val_constr ⟶ Fun (Val n) [] ∈ iklsst T_val_constr"
          "T_val_fresh_vals = {n. Fun (Val n) [] ∈ iklsst T_val_constr}"
          "∀l a. (l,a) ∈ set T_val_constr ∧ is_Insert a ⟶
                  (l = l2_val ∧ (∃n. a = insert⟨Fun (Val n) [],⟨s_val⟩s⟩))"
      using reachable_constraints_initial_value_transaction[
              OF P B(1) T_val_fresh_vals_finite _ x_val]
      by blast

    have T_val_constr_no_upds_if_no_T_upds:
        "filter is_Update (unlabel T_val_constr) = []"
      when "T_upds = []"
      using T_val_constr(3)[OF that] by (induct T_val_constr) auto

    have T_val_fresh_vals_is_T_val_constr_vals:
        "k ∈ T_val_fresh_vals ⟷ Fun (Val k) [] ⊑set trmslsst T_val_constr"
      for k
      using that T_val_constr(7,8) iksst_trmssst_subset by fast

    have T_val_constr_no_fv: "fvlsst T_val_constr = {}"
      using T_val_constr(5) varssst_is_fvsst_bvarssst by fast

    have T_val_σ: "transaction_fresh_subst σ T (trmslsst (ℬ@T_val_constr))"
    proof -
      have "¬(t ⊑set trmslsst (ℬ@T_val_constr))" when t: "t ∈ subst_range σ" for t
      proof -
        obtain k where k: "t = Fun (Val k) []" using t σ_ran by fast
        have "k ∈ σ_vals" using t unfolding k σ_vals_def by blast
        thus ?thesis
          using B(12) T_val_fresh_vals T_val_constr(7,8)
          unfolding N'_def k unlabel_append trmssst_append by blast
      qed
      thus ?thesis using step.hyps(4) unfolding transaction_fresh_subst_def by fast
    qed

    have T_val_α: "transaction_renaming_subst α P (varslsst (ℬ@T_val_constr))"
      using step.hyps B(8) T_val_constr(5) by auto

    define ℬ' where "ℬ' ≡ ℬ@T_val_constr@T'"

    define 𝒦 where "𝒦 ≡ λx.
      if x ∈ fvlsst T'
      then if ∃n. ℐ x = Fun (PubConst Value n) []
           then if ∃y ∈ fvlsst ℬ ∪ X'. ℐ y = ℐ x
                then 𝒥 (SOME y. y ∈ fvlsst ℬ ∪ X' ∧ ℐ y = ℐ x)
                else Fun (Val (δ (THE n. ℐ x = Fun (PubConst Value n) []))) []
           else ℐ x
      else 𝒥 x"

    have σ_ground_ran: "ground (subst_range σ)" "range_vars σ = {}" 
      and ξ_ran_bvars_disj: "range_vars ξ ∩ bvars_transaction T = {}"
      using transaction_fresh_subst_domain[OF step.hyps(4)]
            transaction_fresh_subst_range_vars_empty[OF step.hyps(4)]
            transaction_decl_subst_range_vars_empty[OF step.hyps(3)]
      by (metis range_vars_alt_def, argo, blast)

    have ℬ_T'_fv_disj: "fvlsst ℬ ∩ fvlsst T' = {}"
      using T'_fv_𝒜_disj unfolding B(9) by argo
    hence 𝒥_𝒦_fv_ℬ_eq: "𝒥 x = 𝒦 x" when x: "x ∈ fvlsst ℬ ∪ X'" for x
      using x X'_disj unfolding 𝒦_def by auto

    have B'1: "ℬ' ∈ reachable_constraints P"
      using reachable_constraints.step[OF T_val_constr(1) step.hyps(2,3) T_val_σ T_val_α]
      unfolding ℬ'_def T'_def θ_def by simp

    have "∃n. 𝒦 x = Fun (Val n) []" when x: "x ∈ fvlsst (𝒜@T') ∪ X'" for x
    proof (cases "x ∈ fvlsst T'")
      case True
      note T = this
      show ?thesis
      proof (cases "∃n. ℐ x = Fun (PubConst Value n) []")
        case True thus ?thesis
          using T B(3,9) someI_ex[of "λy. y ∈ fvlsst ℬ ∪ X' ∧ ℐ y = ℐ x"]
          unfolding 𝒦_def valconsts_only_def
          by (cases "∃y ∈ fvlsst ℬ ∪ X'. ℐ y = ℐ x") (meson, auto)
      next
        case False thus ?thesis
          using T 3(3) unfolding 𝒦_def valconst_cases_def by fastforce
      qed
    next
      case False thus ?thesis using x B(3) unfolding 𝒦_def valconsts_only_def by auto
    qed
    hence B'3: "valconsts_only (fvlsst (𝒜@T') ∪ X') 𝒦" unfolding valconsts_only_def by blast

    have B'4: "?rcv_att ℬ' n" when "?rcv_att (𝒜@T') n"
      using that B(4) unfolding ℬ'_def by auto

    have "ℐ x = 𝒦 x" when x: "x ∈ fvlsst (𝒜@T') ∪ X'" "ℐ x = Fun (Val n) []" for x n
    proof -
      have "𝒦 x = 𝒥 x" when "x ∉ fvlsst T'" using that unfolding 𝒦_def by meson
      moreover have "𝒦 x = ℐ x" when "x ∈ fvlsst T'" using that x unfolding 𝒦_def by simp
      ultimately show ?thesis
        using B(5) x
        unfolding subst_eq_on_privvals_def unlabel_append fvsst_append
        by (cases "x ∈ fvlsst T'") auto
    qed
    hence B'5: "subst_eq_on_privvals (fvlsst (𝒜@T') ∪ X') 𝒦"
      unfolding subst_eq_on_privvals_def by blast

    have 𝒜_fv_𝒦_eq_𝒥: "𝒦 x = 𝒥 x" when x: "x ∈ fvlsst 𝒜 ∪ X'" for x
    proof -
      have "x ∉ fvlsst T'" using x T'_fv_𝒜_disj X'_disj by blast
      thus ?thesis unfolding 𝒦_def by argo
    qed

    have T'_fv_ℐ_val_𝒦_eq_𝒥: "𝒦 x = ℐ x" 
      when x: "x ∈ fvlsst T'" "∄n. ℐ x = Fun (PubConst Value n) []" for x
      using x B'5 3(3) unfolding unlabel_append fvsst_append valconst_cases_def 𝒦_def by meson

    have T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val:
        "𝒦 x = Fun (Val (δ n)) []" "δ n ∈ T_val_fresh_vals" 
      when x: "x ∈ fvlsst T'" "ℐ x = Fun (PubConst Value n) []" "∀y ∈ fvlsst ℬ ∪ X'. ℐ y ≠ ℐ x"
      for x n
    proof -
      show "𝒦 x = Fun (Val (δ n)) []" using x unfolding 𝒦_def by auto
      show "δ n ∈ T_val_fresh_vals" using δ(2) x unfolding T'_pubvals_def by blast
    qed

    have T'_fv_ℐ_pubval_𝒦_eq_𝒥_val:
        "∃y ∈ fvlsst ℬ ∪ X'. ∃m. ℐ y = ℐ x ∧ 𝒦 x = 𝒥 y ∧ 𝒦 x = Fun (Val m) []"
      when x: "x ∈ fvlsst T'" "ℐ x = Fun (PubConst Value n) []" "∃y ∈ fvlsst ℬ ∪ X'. ℐ y = ℐ x"
      for x n
    proof -
      have "𝒦 x = 𝒥 (SOME y. y ∈ fvlsst ℬ ∪ X' ∧ ℐ y = ℐ x)" using x unfolding 𝒦_def by meson
      then obtain y where y: "y ∈ fvlsst ℬ ∪ X'" "ℐ y = ℐ x" "𝒦 x = 𝒥 y"
        using x(3) someI_ex[of "λy. y ∈ fvlsst ℬ ∪ X' ∧ ℐ y = ℐ x"] by blast
      thus ?thesis using B(3,9) unfolding valconsts_only_def by auto
    qed

    have T'_fv_ℐ_pubval_𝒦_eq_val: "∃n. 𝒦 x = Fun (Val n) []"
      when x: "x ∈ fvlsst T'" "ℐ x = Fun (PubConst Value n) []" for x n
      using T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val[OF x] T'_fv_ℐ_pubval_𝒦_eq_𝒥_val[OF x] by auto

    have B'6': "𝒦 x ∈ iklsst ℬ"
      when x: "x ∈ fvlsst 𝒜 ∪ X'" "ℐ x = Fun (PubConst Value n) []" for x n
      using x B(6) 𝒜_fv_𝒦_eq_𝒥 x(2) unfolding B(8) subst_in_ik_if_subst_pubval_def by simp

    have B'6'': "𝒦 x ∈ iklsst ℬ ∪ iklsst T_val_constr"
      when x: "x ∈ fvlsst T'" "ℐ x = Fun (PubConst Value n) []" for x n
    proof (cases "∃y ∈ fvlsst ℬ ∪ X'. ℐ y = ℐ x")
      case True thus ?thesis
        using B(6) x(2) T'_fv_ℐ_pubval_𝒦_eq_𝒥_val[OF x True]
        unfolding B(9) subst_in_ik_if_subst_pubval_def by force
    next
      case False thus ?thesis
        using T_val_constr(8) T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val[OF x] by force
    qed

    have "𝒦 x ∈ iklsst ℬ'"
      when x: "x ∈ fvlsst (𝒜@T') ∪ X'" "ℐ x = Fun (PubConst Value n) []" for x n
    proof (cases "x ∈ fvlsst T'")
      case True thus ?thesis using B'6''[OF _ x(2)] unfolding ℬ'_def by auto
    next
      case False
      hence "x ∈ fvlsst 𝒜 ∪ X'"
        using x(1) unfolding unlabel_append fvsst_append by blast
      thus ?thesis using B'6' x(2) unfolding ℬ'_def by simp
    qed
    hence B'6: "subst_in_ik_if_subst_pubval (fvlsst (𝒜@T') ∪ X') 𝒦 ℬ'"
      unfolding subst_in_ik_if_subst_pubval_def by blast

    have B'7: "subst_eq_iff (fvlsst (𝒜@T') ∪ X') 𝒦"
    proof (unfold subst_eq_iff_def; intro ballI)
      fix x y assume xy: "x ∈ fvlsst (𝒜@T') ∪ X'" "y ∈ fvlsst (𝒜@T') ∪ X'"

      let ?Q = "λx y. ℐ x = ℐ y ⟷ 𝒦 x = 𝒦 y"

      have *: "?Q x y"
        when xy: "x ∈ fvlsst 𝒜 ∪ X'" "x ∉ fvlsst T'" "y ∈ fvlsst 𝒜 ∪ X'" "y ∉ fvlsst T'" for x y
        using B(7) xy unfolding 𝒦_def subst_eq_iff_def by force

      have **: "?Q x y" when x: "x ∈ fvlsst 𝒜 ∪ X'" and y: "y ∈ fvlsst T'" for x y
      proof -
        have xy_neq: "x ≠ y" using x y T'_fv_𝒜_disj X'_disj by blast

        have x_eq: "𝒦 x = 𝒥 x"
          using 𝒜_fv_𝒦_eq_𝒥 x by blast

        have x_eq_if_val: "ℐ x = 𝒥 x" when "ℐ x = Fun (Val n) []" for n
          using that x B(5) unfolding subst_eq_on_privvals_def by blast

        have x_neq_if_neq_val: "ℐ x ≠ 𝒥 x" when "ℐ x = Fun (PubConst Value n) []" for n
          by (metis that B(3) x UnI1 prot_fun.distinct(37) term.inject(2) valconsts_only_def)

        have y_eq_if_val: "ℐ y = 𝒦 y" when "ℐ y = Fun (Val n) []" for n
          using that y B'5 unfolding subst_eq_on_privvals_def by simp

        have y_eq: "𝒦 y = Fun (Val (δ n)) []"
          when "ℐ y = Fun (PubConst Value n) []" "∀z ∈ fvlsst ℬ ∪ X'. ℐ z ≠ ℐ y" for n
          by (rule T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val(1)[OF y that])

        have y_eq': "∃z ∈ fvlsst ℬ ∪ X'. ∃m. ℐ z = ℐ y ∧ 𝒦 y = 𝒥 z ∧ 𝒦 y = Fun (Val m) []"
          when "ℐ y = Fun (PubConst Value n) []" "∃z ∈ fvlsst ℬ ∪ X'. ℐ z = ℐ y" for n
          by (rule T'_fv_ℐ_pubval_𝒦_eq_𝒥_val[OF y that])

        have K_eq_if_I_eq: "ℐ x = ℐ y ⟹ 𝒦 x = 𝒦 y"
          apply (cases "∃n. ℐ x = Fun (PubConst Value n) []")
          subgoal using B(7,9) unfolding subst_eq_iff_def by (metis UnI1 x x_eq y_eq')
          subgoal by (metis x_eq x T'_fv_ℐ_val_𝒦_eq_𝒥[OF y] 3(5) valconst_cases_def x_eq_if_val)
          done

        have K_neq_if_I_neq_val: "𝒦 x ≠ 𝒦 y"
          when n: "ℐ y = Fun (Val n) []"
            and m: "ℐ x = Fun (PubConst Value m) []"
          for n m
        proof -
          have I_neq: "ℐ x ≠ ℐ y" using n m by simp

          note y_eq'' = y_eq_if_val[OF n]
          note x_neq = x_neq_if_neq_val[OF m]

          have x_ex: "∃z ∈ fvlsst ℬ ∪ X'. ℐ z = ℐ x" using x unfolding B(9) by blast
          have J1: "𝒥 x ∈ iklsst ℬ" using B(6) x m unfolding subst_in_ik_if_subst_pubval_def by fast
          have J2: "ℐ x ≠ 𝒥 x"
            by (metis m B(3) x UnI1 prot_fun.distinct(37) term.inject(2) valconsts_only_def)
          have J3: "ℐ y = 𝒥 y" using B(5) n y unfolding subst_eq_on_privvals_def by blast
          have K_x: "𝒦 x ≠ ℐ x" using J2 x_eq by presburger
          have x_notin: "x ∉ fvlsst T'" using x T'_fv_𝒜_disj X'_disj by blast
          have K_x': "𝒦 x = 𝒥 x" using x_notin unfolding 𝒦_def by argo
          have K_y: "𝒦 y = 𝒥 y" using y_eq'' J3 by argo

          have "𝒥 x ≠ 𝒥 y" using I_neq x y B(7) unfolding subst_eq_iff_def by blast
          thus ?thesis using K_x' K_y by argo
        qed

        show ?thesis
        proof
          show "ℐ x = ℐ y ⟹ 𝒦 x = 𝒦 y" by (rule K_eq_if_I_eq)
        next
          assume xy_eq: "𝒦 x = 𝒦 y" show "ℐ x = ℐ y"
          proof (cases "∃n. ℐ y = Fun (PubConst Value n) []")
            case True
            then obtain n where n: "ℐ y = Fun (PubConst Value n) []" by blast

            show ?thesis
            proof (cases "∃z ∈ fvlsst ℬ ∪ X'. ℐ z = ℐ y")
              case True thus ?thesis
                using B(7,9) unfolding subst_eq_iff_def by (metis xy_eq UnI1 x x_eq y_eq'[OF n])
            next
              case False
              hence F: "∀z ∈ fvlsst ℬ ∪ X'. ℐ z ≠ ℐ y" by blast
              note y_eq'' = y_eq[OF n F]

              have n_in: "δ n ∈ T_val_fresh_vals"
                using  δ(2) x_eq xy_eq T_val_fresh_vals_notin_ℬ y n
                unfolding T'_pubvals_def by blast
              hence y_notin: "¬(𝒦 y ⊑set iklsst ℬ)"
                using T_val_fresh_vals_notin_ℬ y_eq'' iksst_trmssst_subset[of "unlabel ℬ"]
                by auto

              show ?thesis
              proof (cases "∃m. ℐ x = Fun (PubConst Value m) []")
                case True thus ?thesis
                  using y_notin B(6) x xy_eq x_eq
                  unfolding B(9) subst_in_ik_if_subst_pubval_def
                  by fastforce
              next
                case False
                then obtain m where m: "ℐ x = Fun (Val m) []"
                  using 3(5) x unfolding valconst_cases_def by fast
                hence "ℐ x = 𝒥 x" using x B(5) unfolding subst_eq_on_privvals_def by blast
                hence "𝒦 x = Fun (Val m) []" using m x_eq by argo
                moreover have "m ∉ T_val_fresh_vals"
                  using m T_val_fresh_vals x unfolding ℐ_vals_def by blast
                hence "m ≠ δ n" using n_in by blast
                ultimately have False using xy_eq y_eq'' by force
                thus ?thesis by simp
              qed
            qed
          next
            case False
            then obtain n where n: "ℐ y = Fun (Val n) []"
              using 3(3) y unfolding valconst_cases_def by fast

            note y_eq'' = y_eq_if_val[OF n]

            show ?thesis
            proof (cases "∃m. ℐ x = Fun (Val m) []")
              case True thus ?thesis by (metis xy_eq x_eq y_eq'' x_eq_if_val)
            next
              case False 
              then obtain m where m: "ℐ x = Fun (PubConst Value m) []"
                using 3(5) x unfolding valconst_cases_def by blast

              show ?thesis using K_neq_if_I_neq_val[OF n m] xy_eq by blast
            qed
          qed
        qed
      qed

      have ***: "?Q x y" when x: "x ∈ fvlsst T'" and y: "y ∈ fvlsst T'" for x y
      proof
        assume xy_eq: "ℐ x = ℐ y" show "𝒦 x = 𝒦 y"
        proof (cases "∃n. ℐ x = Fun (PubConst Value n) []")
          case True thus ?thesis
            using xy_eq x y B(7) T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val(1) T'_fv_ℐ_pubval_𝒦_eq_𝒥_val
            unfolding B(9) subst_eq_iff_def by (metis (no_types) UnI1)
        qed (metis xy_eq x y T'_fv_ℐ_val_𝒦_eq_𝒥)
      next
        assume xy_eq: "𝒦 x = 𝒦 y"

        have case1: False
          when x': "x ∈ fvlsst T'"
            and y': "y ∈ fvlsst T'"
            and xy_eq': "𝒦 x = 𝒦 y"
            and m: "ℐ x = Fun (PubConst Value m) []"
            and n: "ℐ y = Fun (Val n) []"
          for x y n m
        proof -
          have F: "∄n. ℐ y = Fun (PubConst Value n) []" using n by auto

          note x_eq = T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val[OF x' m]
          note y_eq = T'_fv_ℐ_val_𝒦_eq_𝒥[OF y' F]

          have "∃z ∈ fvlsst ℬ ∪ X'. ℐ z = ℐ x"
          proof (rule ccontr)
            assume no_z: "¬(∃z ∈ fvlsst ℬ ∪ X'. ℐ z = ℐ x)"
            hence "n ≠ δ m" using n y' x_eq(2) T_val_fresh_vals unfolding ℐ_vals_def by blast
            thus False using xy_eq' x_eq y_eq(1) n no_z by auto
          qed
          then obtain z k where z:
              "z ∈ fvlsst ℬ ∪ X'" "ℐ z = ℐ x" "𝒦 x = 𝒥 z" "𝒦 x = Fun (Val k) []"
            using T'_fv_ℐ_pubval_𝒦_eq_𝒥_val[OF x' m] by blast

          have "ℐ y = 𝒥 z" using z(2,3) y_eq xy_eq' by presburger
          hence "ℐ x = ℐ y" using z(1,2) ** B(9) 𝒥_𝒦_fv_ℬ_eq y' y_eq by metis
          thus False using n m by simp
        qed

        have case2: "m = n"
          when x': "x ∈ fvlsst T'"
            and y': "y ∈ fvlsst T'"
            and xy_eq': "𝒦 x = 𝒦 y"
            and m: "ℐ x = Fun (PubConst Value m) []"
            and n: "ℐ y = Fun (PubConst Value n) []"
          for x y n m
        proof (cases "∀z ∈ fvlsst ℬ ∪ X'. ℐ z ≠ ℐ x")
          case True show ?thesis
            apply (cases "∀z ∈ fvlsst ℬ ∪ X'. ℐ z ≠ ℐ y")
            subgoal
              using xy_eq' m n T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val[OF x' m True]
                    T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val[OF y' n] injD[OF δ(1), of m n]
              by fastforce
            subgoal by (metis x' y' xy_eq' ** B(9) True)
            done
        qed (metis x' y' xy_eq' m n ** B(9) prot_fun.inject(6) term.inject(2))

        have case3: "m = n"
          when x': "x ∈ fvlsst T'"
            and y': "y ∈ fvlsst T'"
            and xy_eq': "𝒦 x = 𝒦 y"
            and m: "ℐ x = Fun (Val m) []"
            and n: "ℐ y = Fun (Val n) []"
          for x y n m
          using x' y' xy_eq' m n T'_fv_ℐ_val_𝒦_eq_𝒥 by fastforce

        show "ℐ x = ℐ y"
          using x y xy_eq case1 case2 case3 3(3)
          unfolding valconst_cases_def by metis
      qed

      have ****: "?Q x y" when xy: "x ∈ X'" "x ∉ fvlsst T'" "y ∈ fvlsst T'" for x y
      proof -
        have xy': "y ∉ X'" "y ∉ fvlsst 𝒜" "x ∉ fvlsst 𝒜"
          using xy X'_disj T'_fv_𝒜_disj by (blast, blast, blast)

        have K_x: "𝒦 x = 𝒥 x" using xy(2) unfolding 𝒦_def by argo

        have I_iff_J: "ℐ x = ℐ y ⟷ 𝒥 x = 𝒥 y" using xy B(7) unfolding subst_eq_iff_def by fast

        show ?thesis using K_x I_iff_J K_x injD[OF δ(1)] xy B(7,9) ** by (meson UnCI)
      qed

      show "?Q x y"
        using xy * **[of x y] **[of y x] ***[of x y] ****[of x y] ****[of y x]
        unfolding unlabel_append fvsst_append by (metis Un_iff)
    qed

    have B'8_9: "varslsst (𝒜@T') = varslsst ℬ'" "fvlsst (𝒜@T') = fvlsst ℬ'"
      using B(8,9) T_val_constr(5) varssst_is_fvsst_bvarssst[of "unlabel T_val_constr"]
      unfolding ℬ'_def unlabel_append varssst_append fvsst_append by simp_all

    have I': "∃n. ℐ x = Fun (PubConst Value n) []"
      when x: "x ∈ fvlsst T'" "∄n. ℐ x = Fun (Val n) []" for x
      using x 3(3) unfolding valconst_cases_def by fast

    have B'10_11: "iklsst (𝒜@T') ⊆ iklsst ℬ'" "trmslsst (𝒜@T') ⊆ trmslsst ℬ'"
      using B(10,11) unfolding N'_def ℬ'_def unlabel_append trmssst_append iksst_append
      by (blast, blast)

    have B'12: "∀n ∈ N. ¬(Fun (Val n) [] ⊑set trmslsst ℬ')"
      using B(12) σ_vals_is_T'_vals σ_vals_N_disj T_val_fresh_vals
            T_val_fresh_vals_is_T_val_constr_vals
      unfolding N'_def ℬ'_def unfolding unlabel_append trmssst_append iksst_append by fast

    have B'13: "db_eq (𝒜@T') ℬ' s_val T_upds"
    proof -
      let ?f = "filter is_Update ∘ unlabel"
      let ?g = "filter (λa. ∄l t ts. a = (l, insert⟨t,Fun (Set s_val) ts⟩))"

      have "?f (?g T_val_constr) = []" using T_val_constr(3,4,9)
      proof (induction T_val_constr)
        case (Cons a B)
        then obtain l b where a: "a = (l,b)" by (metis surj_pair)
  
        have IH: "?f (?g B) = []" using Cons.prems Cons.IH by auto

        show ?case
        proof (cases "T_upds = []")
          case True
          hence "is_Receive b" using a Cons.prems(1,2) by simp
          thus ?thesis using IH unfolding a Let_def by auto
        next
          case False
          hence "is_Insert b ∨ is_Receive b" using a Cons.prems(1,2) by simp
          hence "∃t. a = (l2_val, insert⟨t,⟨s_val⟩s⟩)" when b: "¬is_Receive b"
            using b Cons.prems(3) unfolding a by (metis list.set_intros(1))
          thus ?thesis using IH unfolding a Let_def by auto
        qed
      qed simp
      hence "?f (?g (𝒜@T')) = ?f (?g 𝒜)@?f (?g T')"
            "?f (?g (ℬ@T_val_constr@T')) = ?f (?g ℬ)@?f (?g T')"
        when "T_upds ≠ []"
        by simp_all
      moreover have "?f T_val_constr = []" when "T_upds = []"
        using T_val_constr_no_upds_if_no_T_upds[OF that] by force
      hence "?f (𝒜@T') = ?f 𝒜@?f T'"
            "?f (ℬ@T_val_constr@T') = ?f ℬ@?f T'"
        when "T_upds = []"
        using that by auto
      ultimately show ?thesis using B(13) unfolding ℬ'_def db_eq_def Let_def by presburger  
    qed

    have B'14: "db_upds_consts_fresh (𝒜@T') (fvlsst (𝒜@T') ∪ X') 𝒦"
    proof (unfold db_upds_consts_fresh_def; intro ballI allI impI; elim exE)
      fix x s n m
      assume x: "x ∈ fvlsst (𝒜@T') ∪ X'"
        and n: "insert⟨Fun (Val n) [],s⟩ ∈ set (unlabel (𝒜@T')) ∨
                delete⟨Fun (Val n) [],s⟩ ∈ set (unlabel (𝒜@T'))"
              (is "?A (𝒜@T')")
        and m: "ℐ x = Fun (PubConst Value m) []"

      have A_cases: "?A 𝒜 ∨ ?A T'" using n by force

      have n_in_case: "n ∈ σ_vals" when A: "?A T'"
      proof -
        obtain t s' where t:
          "insert⟨t,s'⟩ ∈ set (unlabel (transaction_strand T)) ∨
           delete⟨t,s'⟩ ∈ set (unlabel (transaction_strand T))"
          "Fun (Val n) [] = t ⋅ θ"
        using A duallsst_unlabel_steps_iff(4,5)
              stateful_strand_step_mem_substD(4,5)[of _ _ _ θ]
              subst_lsst_unlabel[of _ θ]
        unfolding T'_def by (metis (no_types, opaque_lifting))

        have "Fun (Val n) [] ∈ subst_range θ"
          using t transaction_inserts_are_Value_vars(1)[OF T_wf(1,3), of t s']
                transaction_deletes_are_Value_vars(1)[OF T_wf(1,3), of t s']
          by force
        hence "Fun (Val n) [] ∈ subst_range σ"
          using transaction_decl_fresh_renaming_substs_range'(4)[
                  OF step.hyps(3,4,5) _ ξ_empty]
          unfolding θ_def by blast
        thus ?thesis unfolding σ_vals_def by fast
      qed

      have in_A_case: "𝒦 x ≠ Fun (Val n) []"
        when y: "y ∈ fvlsst 𝒜 ∪ X'" "ℐ x = ℐ y" "𝒦 x = 𝒥 y" for y
        using A_cases
      proof
        assume "?A 𝒜" thus ?thesis
          using B(14) m y(1,3) unfolding db_upds_consts_fresh_def y(2) by auto
      next
        assume "?A T'"
        hence "n ∈ N'" using n_in_case unfolding N'_def by blast
        moreover have "𝒥 y ∈ trmslsst ℬ"
          using B(6) y(1) m iksst_trmssst_subset
          unfolding y(2) subst_in_ik_if_subst_pubval_def by blast
        ultimately show ?thesis using B(12) y(3) by fastforce
      qed

      show "𝒦 x ≠ Fun (Val n) []"
      proof (cases "x ∈ fvlsst T'")
        case True
        note 0 = T'_fv_ℐ_pubval_𝒦_eq_δ_fresh_val[OF True m, unfolded B(9)[symmetric]]
        note 1 = T'_fv_ℐ_pubval_𝒦_eq_𝒥_val[OF True m, unfolded B(9)[symmetric]]

        show ?thesis
        proof (cases "∀y∈ fvlsst 𝒜 ∪ X'. ℐ y ≠ ℐ x")
          case True show ?thesis
            using A_cases 0[OF True] T_val_fresh_vals n_in_case
            unfolding 𝒜_vals_def by force
        next
          case False
          then obtain y where "y ∈ fvlsst 𝒜 ∪ X'" "ℐ y = ℐ x" "𝒦 x = 𝒥 y" using 1 by blast
          thus ?thesis using in_A_case by auto
        qed
      next
        case False
        hence x_in: "x ∈ fvlsst 𝒜 ∪ X'" using x unfolding unlabel_append fvsst_append by fast
        hence x_eq: "𝒦 x = 𝒥 x" using 𝒜_fv_𝒦_eq_𝒥 by blast

        show ?thesis using in_A_case[OF x_in _ x_eq] by blast
      qed
    qed

    have B'2: "?wt_model 𝒦 ℬ'"
    proof (unfold welltyped_constraint_model_def; intro conjI)
      have "Γ (𝒦 x) = Γv x" for x
      proof -
        have "wtsubst 𝒥" "wtsubst ℐ"
          using B(2) 3(1) unfolding welltyped_constraint_model_def by (blast,blast)
        hence *: "⋀y. Γ (𝒥 y) = Γv y" "⋀y. Γ (ℐ y) = Γv y" unfolding wtsubst_def by auto

        show ?thesis
        proof (cases "x ∈ fvlsst T'")
          case True
          note x = this
          show ?thesis
          proof (cases "∃n. ℐ x = Fun (PubConst Value n) []")
            case True thus ?thesis using T'_fv_ℐ_pubval_𝒦_eq_val[OF x] T'_value_vars[OF x] by force
          next
            case False thus ?thesis using x * unfolding 𝒦_def by presburger
          qed
        next
          case False thus ?thesis using *(1) unfolding 𝒦_def by presburger
        qed
      qed
      thus "wtsubst 𝒦" unfolding 𝒦_def wtsubst_def by force

      show "constraint_model 𝒦 ℬ'"
      proof (unfold constraint_model_def; intro conjI)
        have *: "strand_sem_stateful {} {} (unlabel 𝒜) ℐ"
                "strand_sem_stateful {} {} (unlabel ℬ) 𝒥"
                "interpretationsubst ℐ" "interpretationsubst 𝒥"
                "wftrms (subst_range ℐ)" "wftrms (subst_range 𝒥)"
          using B(2) 3(1) unfolding welltyped_constraint_model_def constraint_model_def by fast+

        show K0: "subst_domain 𝒦 = UNIV"
        proof -
          have "x ∈ subst_domain 𝒦" for x
          proof (cases "x ∈ fvlsst T'")
            case True thus ?thesis
              using T'_fv_ℐ_pubval_𝒦_eq_val[OF True] T'_fv_ℐ_val_𝒦_eq_𝒥[OF True] *(3)
              unfolding subst_domain_def by (cases "∃n. ℐ x = Fun (PubConst Value n) []") auto
          next
            case False thus ?thesis using *(4) unfolding 𝒦_def subst_domain_def by auto
          qed
          thus ?thesis by blast
        qed

        have "fv (𝒦 x) = {}" for x
          using interpretation_grounds_all[OF *(3)]
                interpretation_grounds_all[OF *(4)]
          unfolding 𝒦_def by simp
        thus K1: "ground (subst_range 𝒦)" by simp

        have "wftrm (Fun (Val n) [])" for n by fastforce
        moreover have "wftrm (ℐ x)" "wftrm (𝒥 x)" for x using *(5,6) by (fastforce,fastforce)
        ultimately have "wftrm (𝒦 x)" for x unfolding 𝒦_def by auto
        thus K2: "wftrms (subst_range 𝒦)" by simp

        show "strand_sem_stateful {} {} (unlabel ℬ') 𝒦"
        proof (unfold ℬ'_def unlabel_append strand_sem_append_stateful Un_empty_left; intro conjI)
          let ?sem = "λM D A. strand_sem_stateful M D (unlabel A) 𝒦"
          let ?M1 = "iklsst ℬ ⋅set 𝒦"
          let ?M2 = "?M1 ∪ (iklsst T_val_constr ⋅set 𝒦)"
          let ?D1 = "dbupdsst (unlabel ℬ) 𝒦 {}"
          let ?D2 = "dbupdsst (unlabel T_val_constr) 𝒦 ?D1"

          show "?sem {} {} ℬ"
            using 𝒥_𝒦_fv_ℬ_eq strand_sem_model_swap[OF _ *(2)] by blast

          show "?sem ?M1 ?D1 T_val_constr"
            using T_val_constr(3,4) strand_sem_stateful_if_no_send_or_check
            unfolding list_all_iff by blast

          have D2: "?D2 = ?D1 ∪ {(t ⋅ 𝒦, s ⋅ 𝒦) | t s. insert⟨t,s⟩ ∈ set (unlabel T_val_constr)}"
            using T_val_constr(3,4) dbupdsst_no_deletes
            unfolding list_all_iff by blast

          have K3: "interpretationsubst 𝒦"
            using K0 K1 by argo

          have rcv_θ_is_α: "t ⋅ θ = t ⋅ α"
            when t: "(l,receive⟨ts⟩) ∈ set (transaction_receive T)" "t ∈ set ts" for l ts t
          proof -
            have "fv t ⊆ fvlsst (transaction_receive T)"
              using t(2) stateful_strand_step_fv_subset_cases(2)[OF unlabel_in[OF t(1)]] by auto
            hence "t ⋅ σ = t" using t σ_dom σ_ran admissible_transactionE(12,13)[OF T_adm] by blast
            thus ?thesis unfolding θ_def ξ_empty by simp
          qed
      
          have eq_θ_is_α: "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α"
            when t: "(l,⟨ac: t ≐ s⟩) ∈ set (transaction_checks T)" for l ac t s
          proof -
            have "fv t ∪ fv s ⊆ fvlsst (transaction_checks T)"
              using stateful_strand_step_fv_subset_cases(3)[OF unlabel_in[OF t]] by auto
            hence "t ⋅ σ = t" "s ⋅ σ = s"
              using t σ_dom σ_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
            thus "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α" unfolding θ_def ξ_empty by simp_all
          qed

          have noteq_θ_is_α: "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α"
            when t: "(l,⟨t != s⟩) ∈ set (transaction_checks T)" for l t s
          proof -
            have "fv t ∪ fv s ⊆ fvlsst (transaction_checks T)"
              using stateful_strand_step_fv_subset_cases(8)[OF unlabel_in[OF t]] by auto
            hence "t ⋅ σ = t" "s ⋅ σ = s"
              using t σ_dom σ_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
            thus "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α" unfolding θ_def ξ_empty by simp_all
          qed

          have in_θ_is_α: "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α"
            when t: "(l,⟨ac: t ∈ s⟩) ∈ set (transaction_checks T)" for l ac t s
          proof -
            have "fv t ∪ fv s ⊆ fvlsst (transaction_checks T)"
              using stateful_strand_step_fv_subset_cases(6)[OF unlabel_in[OF t]] by auto
            hence "t ⋅ σ = t" "s ⋅ σ = s"
              using t σ_dom σ_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
            thus "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α" unfolding θ_def ξ_empty by simp_all
          qed

          have notin_θ_is_α: "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α"
            when t: "(l,⟨t not in s⟩) ∈ set (transaction_checks T)" for l t s
          proof -
            have "fv t ∪ fv s ⊆ fvlsst (transaction_checks T)"
              using stateful_strand_step_fv_subset_cases(9)[OF unlabel_in[OF t]] by auto
            hence "t ⋅ σ = t" "s ⋅ σ = s"
              using t σ_dom σ_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
            thus "t ⋅ θ = t ⋅ α" "s ⋅ θ = s ⋅ α" unfolding θ_def ξ_empty by simp_all
          qed

          have T'_trm_no_val: "∄n. s = Fun (Val n) [] ∨ s = Fun (PubConst Value n) []"
            when t: "t ∈ trms_transaction T" "s ⊑ t ⋅ α" for t s
          proof -
            have ?thesis when "s ⊑ t"
              using that t admissible_transactions_no_Value_consts'[OF T_adm]
                    admissible_transactions_no_PubConsts[OF T_adm]
              by blast
            moreover have "Fun k [] ⊑ u" when "Fun k [] ⊑ u ⋅ α" for k u using that
            proof (induction u)
              case (Var x) thus ?case
                using transaction_renaming_subst_is_renaming(2)[OF step.hyps(5), of x] by fastforce
            qed auto
            ultimately show ?thesis using t by blast
          qed

          define flt1 where "flt1 ≡ λA::('fun,'atom,'sets,'lbl) prot_constr.
                                      filter is_Update (unlabel A)"
          define flt2 where "flt2 ≡ λA::('fun,'atom,'sets,'lbl) prot_constr.
                                      filter (λa. ∄l t ts. a = (l, insert⟨t,⟨s_val⟨ts⟩⟩s⟩)) A"
          define flt3 where "flt3 ≡ λA::(('fun,'atom,'sets,'lbl) prot_fun,
                                          ('fun,'atom,'sets,'lbl) prot_var) stateful_strand.
                                      filter (λa. ∄t ts. a = insert⟨t,⟨s_val⟨ts⟩⟩s⟩) A"

          have flt2_subset: "set (unlabel (flt2 A)) ⊆ set (unlabel A)" for A
            unfolding flt2_def unlabel_def by auto

          have flt2_unlabel: "unlabel (flt2 A) = flt3 (unlabel A)" for A
            unfolding flt2_def flt3_def by (induct A) auto

          have flt2_suffix:
              "suffix (filter (λa. ∄t ts. a = insert⟨t,⟨s_val⟨ts⟩⟩s⟩) A) (unlabel (flt2 B))"
            when "suffix A (unlabel B)" for A B
            using that unfolding flt2_def by (induct B arbitrary: A rule: List.rev_induct) auto

          have flt_AB: "flt1 (flt2 𝒜) = flt1 (flt2 ℬ)"
          proof -
            have *: "flt1 (flt2 𝒜) = filter is_Update (flt3 (unlabel 𝒜))"
                    "flt1 (flt2 ℬ) = filter is_Update (flt3 (unlabel ℬ))"
              using flt2_unlabel unfolding flt1_def by presburger+

            have **: "filter is_Update (flt3 C) = flt3 (filter is_Update C)" for C
            proof (induction C)
              case Nil thus ?case unfolding flt3_def by force
            next
              case (Cons c C) thus ?case unfolding flt3_def by (cases c) auto
            qed

            show ?thesis
            proof (cases "T_upds = []")
              case True
              hence "filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
                using B(13) unfolding db_eq_def by fastforce
              thus ?thesis using ** unfolding * by presburger
            next
              case False thus ?thesis
                using B(13) unfolding flt1_def flt2_def db_eq_def Let_def by force
            qed
          qed

          have A_setops_Fun: "∀t s. insert⟨t,s⟩ ∈ set (unlabel 𝒜) ⟶ (∃g ts. s = Fun g ts)"
            using reachable_constraints_setops_form[OF step.hyps(1) P]
            unfolding setopssst_def by fastforce

          have A_insert_delete_not_subterm:
              "ℐ x = 𝒦 x ∨ (¬(ℐ x ⊑ t) ∧ ¬(ℐ x ⊑ s) ∧ ¬(𝒦 x ⊑ t) ∧ ¬(𝒦 x ⊑ s))"
            when x: "x ∈ fvlsst 𝒜 ∪ fvlsst T' ∪ fv t ∪ fv s"
              and x_neq: "ℐ x ≠ 𝒦 x"
              and ts: "insert⟨t,s⟩ ∈ set (unlabel 𝒜) ∨ delete⟨t,s⟩ ∈ set (unlabel 𝒜)"
            for x t s
          proof -
            have x_in: "x ∈ fvlsst 𝒜 ∪ fvlsst T'"
              using ts x stateful_strand_step_fv_subset_cases(4,5) by blast

            note ts' = reachable_constraints_insert_delete_form[OF step.hyps(1) P ts]

            have *: "ℐ x = 𝒦 x" when n: "ℐ x = Fun (Val n) []" for n
              using n B'5 x_in
              unfolding subst_eq_on_privvals_def unlabel_append fvsst_append
              by blast

            have **: "¬(ℐ x ⊑ t)" "¬(ℐ x ⊑ s)" "¬(𝒦 x ⊑ t)" "¬(𝒦 x ⊑ s)"
              when n: "ℐ x = Fun (PubConst Value n) []" for n
            proof -
              show "¬(ℐ x ⊑ s)"
                using ts'(1) x_in 3(2,3) unfolding valconst_cases_def by fastforce

              show "¬(𝒦 x ⊑ s)"
                using ts'(1) x_in B'3
                unfolding valconsts_only_def unlabel_append fvsst_append by force

              show "¬(ℐ x ⊑ t)" using n ts'(3) by fastforce

              from ts'(3) have "𝒦 x ≠ t"
              proof
                assume "∃y. t = Var y" thus ?thesis
                  using B'3 x_in unfolding valconsts_only_def by force
              next
                assume "∃k. t = Fun (Val k) []" thus ?thesis
                  using B'14 n x_in ts unfolding db_upds_consts_fresh_def by auto
              qed
              thus "¬(𝒦 x ⊑ t)" using ts'(3) by auto
            qed

            show ?thesis using * ** 3(2,3) x_in unfolding valconst_cases_def by fast
          qed

          have flt2_insert_in_iff:
              "insert⟨u,v⟩ ∈ set (unlabel A) ⟷ insert⟨u,v⟩ ∈ set (unlabel (flt2 A))"
            (is "?A A ⟷ ?B A")
            when h: "s = ⟨h⟩s" "h ≠ s_val" and t: "(t ⋅ I,s ⋅ I) = (u,v) ⋅p I"
            for t s h u v A and I::"('fun,'atom,'sets,'lbl) prot_subst"
          proof
            show "?B A ⟹ ?A A" using flt2_subset by fast
            show "?A A ⟹ ?B A"
            proof (induction A)
              case (Cons a A)
              obtain l b where a: "a = (l,b)" by (metis surj_pair)
              show ?case
              proof (cases "b = insert⟨u,v⟩")
                case True thus ?thesis using h t unfolding a flt2_def by force
              next
                case False thus ?thesis using Cons.prems Cons.IH unfolding a flt2_def by auto
              qed
            qed simp
          qed

          have flt2_inset_iff:
              "(t ⋅ 𝒦, s ⋅ 𝒦) ∈ dbupdsst (unlabel (flt2 ℬ)) 𝒦 {} ⟷
               (t ⋅ 𝒦, s ⋅ 𝒦) ∈ dbupdsst (unlabel ℬ) 𝒦 {}"
            (is "?A ⟷ ?B")
            when h: "s = ⟨h⟩s" "h ≠ s_val"
            for t s h
          proof
            let ?C1 = "λu v B C. suffix (delete⟨u,v⟩#B) (unlabel C)"
            let ?C2 = "λt s u v. (t,s) = (u,v) ⋅p 𝒦"
            let ?C3 = "λt s C. ∃u v. ?C2 t s u v ∧ insert⟨u,v⟩ ∈ set C"
            let ?D = "λt s C. ∀u v B. ?C1 u v B C ∧ ?C2 t s u v ⟶ ?C3 t s B"

            let ?db = "λC D. dbupdsst C 𝒦 D"

            have "?C3 t s B"
              when "?D t s (flt2 ℬ)" "?C1 u v B ℬ" "?C2 t s u v" for u v B t s
              using that flt2_suffix flt2_subset by fastforce
            thus "?A ⟹ ?B" using flt2_subset unfolding dbupdsst_in_iff by blast

            show ?A when ?B using that
            proof (induction ℬ rule: List.rev_induct)
              case (snoc a A)
              obtain l b where a: "a = (l,b)" by (metis surj_pair)

              have *:
                  "?db (unlabel (A@[a])) {} = ?db [b] (?db (unlabel A) {})"
                  "?db (unlabel (flt2 (A@[a]))) {} =
                   ?db (unlabel (flt2 [a])) (?db (unlabel (flt2 A)) {})"
                using dbupdsst_append[of _ _ 𝒦 "{}"] unfolding a flt2_def by auto

              show ?case
              proof (cases "∃u v. b = insert⟨u,v⟩ ∧ (t ⋅ 𝒦, s ⋅ 𝒦) = (u,v) ⋅p 𝒦")
                case True
                then obtain u v where "b = insert⟨u,v⟩" "(t ⋅ 𝒦, s ⋅ 𝒦) = (u, v) ⋅p 𝒦" by force
                thus ?thesis using h *(2) unfolding a flt2_def by auto
              next
                case False
                hence IH: "(t ⋅ 𝒦, s ⋅ 𝒦) ∈ dbupdsst (unlabel (flt2 A)) 𝒦 {}"
                  using snoc.prems snoc.IH unfolding *(1) by (cases b) auto

                show ?thesis
                proof (cases "is_Delete b")
                  case True
                  then obtain u v where b: "b = delete⟨u,v⟩" by (cases b) auto

                  have b': "unlabel (flt2 [a]) = [b]"
                           "unlabel (flt2 (A@[a])) = unlabel (flt2 A)@[b]"
                    unfolding a flt2_def b by (fastforce,fastforce)

                  have "(t ⋅ 𝒦, s ⋅ 𝒦) ≠ (u,v) ⋅p 𝒦" using *(1) snoc.prems unfolding b' b by simp
                  thus ?thesis using *(2) IH unfolding b' b by simp
                next
                  case False thus ?thesis using *(2) IH unfolding a flt2_def by (cases b) auto
                qed
              qed
            qed simp
          qed

          have inset_model_swap:
              "(t ⋅ ℐ, s ⋅ ℐ) ∈ dbupdsst (unlabel 𝒜) ℐ {} ⟷
               (t ⋅ 𝒦, s ⋅ 𝒦) ∈ dbupdsst (unlabel ℬ) 𝒦 {}"
            (is "?in ℐ (unlabel 𝒜) ⟷ ?in 𝒦 (unlabel ℬ)")
            when h: "s = ⟨h⟩s"
                    "h ≠ s_val ∨ filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
              and t: "t = Var tx"
              and t_s_fv: "fv t ∪ fv s ⊆ fvlsst T'"
              and q: "∀x ∈ fv t ∪ fv s.
                        ℐ x = 𝒦 x ∨ (¬(ℐ x ⊑ t) ∧ ¬(ℐ x ⊑ s) ∧ ¬(𝒦 x ⊑ t) ∧ ¬(𝒦 x ⊑ s))"
                     "∀x ∈ fvlsst 𝒜 ∪ fv t ∪ fv s. ∃c. ℐ x = Fun c []"
                     "∀x ∈ fvlsst 𝒜 ∪ fv t ∪ fv s. ∃c. 𝒦 x = Fun c []"
                     "∀x ∈ fvlsst 𝒜 ∪ fv t ∪ fv s. ∀y ∈ fvlsst 𝒜 ∪ fv t ∪ fv s.
                        ℐ x = ℐ y ⟷ 𝒦 x = 𝒦 y"
            for t s h tx
          proof -
            let ?upds = "λA. filter is_Update (unlabel A)"

            have flt2_fv: "fvlsst (flt2 𝒜) ⊆ fvlsst 𝒜"
              using fvsst_mono[OF flt2_subset[of 𝒜]] by blast

            have upds_fv: "fvsst (?upds 𝒜) ⊆ fvlsst 𝒜" by auto

            have flt2_upds_fv: "fvsst (?upds (flt2 𝒜)) ⊆ fvsst (?upds 𝒜)"
              using flt2_subset[of 𝒜] by auto

            have h_neq: "Set h ≠ (Set s_val::('fun,'atom,'sets,'lbl) prot_fun)"
              when "h ≠ s_val"
              using that by simp

            have *: "⋃(fvpair ` {}) = {}" "{} ⋅pset ℐ = {}" "{} ⋅pset 𝒦 = {}" by blast+

            have "?in ℐ (?upds (flt2 𝒜)) ⟷ ?in 𝒦 (?upds (flt2 𝒜))"
            proof
              let ?X = "fvsst (?upds (flt2 𝒜)) ∪ fv t ∪ fv s ∪
                         ⋃(fvpair ` ({}::(('fun,'atom,'sets,'lbl) prot_term ×
                                          ('fun,'atom,'sets,'lbl) prot_term) set))"

              let ?q0 = "λδ θ.
                    ∀x ∈ ?X.
                      δ x = θ x ∨
                      (¬(δ x ⊑ t) ∧ ¬(δ x ⊑ s) ∧¬(θ x ⊑ t) ∧ ¬(θ x ⊑ s) ∧
                       (∀(u,v) ∈ {}. ¬(δ x ⊑ u) ∧ ¬(δ x ⊑ v) ∧ ¬(θ x ⊑ u) ∧ ¬(θ x ⊑ v)) ∧
                       (∀u v. insert⟨u,v⟩ ∈ set (?upds (flt2 𝒜)) ∨
                              delete⟨u,v⟩ ∈ set (?upds (flt2 𝒜)) ⟶
                                ¬(δ x ⊑ u) ∧ ¬(δ x ⊑ v) ∧ ¬(θ x ⊑ u) ∧ ¬(θ x ⊑ v)))"

              let ?q1 = "λδ. ∀x ∈ ?X. ∃c. δ x = Fun c []"

              let ?q2 = "λδ θ. ∀x ∈ ?X. ∀y ∈ ?X. δ x = δ y ⟷ θ x = θ y"

              have q0: "?q0 ℐ 𝒦" "?q0 𝒦 ℐ"
              proof -
                have upd_ex:
                    "∃u v. x ∈ fv u ∪ fv v ∧
                           (insert⟨u,v⟩ ∈ set (?upds A) ∨ delete⟨u,v⟩ ∈ set (?upds A))"
                  when "x ∈ fvsst (?upds A)" for x and A::"('fun,'atom,'sets,'lbl) prot_constr"
                  using that
                proof (induction A)
                  case (Cons a A)
                  obtain l b where a: "a = (l,b)" by (metis surj_pair)
                  show ?case using Cons.IH Cons.prems unfolding a by (cases b) auto
                qed simp
                
                have "¬(ℐ x ⊑ t)" "¬(ℐ x ⊑ s)" "¬(𝒦 x ⊑ t)" "¬(𝒦 x ⊑ s)"
                  when x: "x ∈ fvsst (?upds (flt2 𝒜)) ∪ fv t ∪ fv s"
                    and x_neq: "ℐ x ≠ 𝒦 x"
                  for x
                proof -
                  have "¬(ℐ x ⊑ t) ∧ ¬(ℐ x ⊑ s) ∧ ¬(𝒦 x ⊑ t) ∧ ¬(𝒦 x ⊑ s)"
                  proof (cases "x ∈ fv t ∪ fv s")
                    case True thus ?thesis using q(1) x_neq by blast
                  next
                    case False
                    hence "x ∈ fvlsst 𝒜" using x flt2_upds_fv upds_fv by blast
                    hence "∃n. 𝒦 x = Fun (Val n) []"
                          "∃n. ℐ x = Fun (Val n) [] ∨ ℐ x = Fun (PubConst Value n) []"
                      using B'3 3(2)
                      unfolding valconst_cases_def valconsts_only_def unlabel_append fvsst_append
                      by (blast, blast)
                    thus ?thesis unfolding t h(1) by auto
                  qed
                  thus "¬(ℐ x ⊑ t)" "¬(ℐ x ⊑ s)" "¬(𝒦 x ⊑ t)" "¬(𝒦 x ⊑ s)" by simp_all
                qed
                moreover have "¬(ℐ x ⊑ u)" "¬(ℐ x ⊑ v)" "¬(𝒦 x ⊑ u)" "¬(𝒦 x ⊑ v)"
                  when x: "x ∈ fvsst (?upds (flt2 𝒜)) ∪ fv t ∪ fv s"
                    and x_neq: "ℐ x ≠ 𝒦 x"
                    and uv: "insert⟨u,v⟩ ∈ set (?upds (flt2 𝒜)) ∨
                             delete⟨u,v⟩ ∈ set (?upds (flt2 𝒜))"
                  for x u v
                proof -
                  have uv': "insert⟨u,v⟩ ∈ set (unlabel 𝒜) ∨ delete⟨u,v⟩ ∈ set (unlabel 𝒜)"
                    using uv flt2_subset by auto

                  have x_in: "x ∈ fvlsst 𝒜 ∪ fvlsst T' ∪ fv u ∪ fv v"
                    using t_s_fv x flt2_upds_fv upds_fv by blast

                  show "¬(ℐ x ⊑ u)" "¬(ℐ x ⊑ v)" "¬(𝒦 x ⊑ u)" "¬(𝒦 x ⊑ v)"
                    using x_neq A_insert_delete_not_subterm[OF x_in x_neq uv'] by simp_all
                qed
                ultimately show "?q0 ℐ 𝒦" unfolding upd_ex unfolding *
                  by (metis (no_types, lifting) empty_iff sup_bot_right)
                thus "?q0 𝒦 ℐ" by (metis (lifting) empty_iff)
              qed

              have q1: "?q1 ℐ" "?q1 𝒦"
                using q(2,3) flt2_upds_fv upds_fv by (blast,blast)

              have q2: "?q2 ℐ 𝒦" "?q2 𝒦 ℐ"
                using q(4) flt2_upds_fv upds_fv unfolding * by (blast,blast)

              show "?in ℐ (?upds (flt2 𝒜)) ⟹ ?in 𝒦 (?upds (flt2 𝒜))"
                using dbupdsst_subst_const_swap[OF _ q0(1) q1(1,2) q2(1)] by force

              show "?in 𝒦 (?upds (flt2 𝒜)) ⟹ ?in ℐ (?upds (flt2 𝒜))"
                using dbupdsst_subst_const_swap[OF _ q0(2) q1(2,1) q2(2)] by force
            qed
            hence flt2_subst_swap: "?in ℐ (unlabel (flt2 𝒜)) ⟷ ?in 𝒦 (unlabel (flt2 𝒜))"
              using dbupdsst_filter by blast

            (* TODO: merge with similar proof above? *)
            have "?in ℐ (?upds 𝒜) ⟷ ?in 𝒦 (?upds 𝒜)"
            proof
              let ?X = "fvsst (?upds 𝒜) ∪ fv t ∪ fv s ∪
                         ⋃(fvpair ` ({}::(('fun,'atom,'sets,'lbl) prot_term ×
                                          ('fun,'atom,'sets,'lbl) prot_term) set))"

              let ?q0 = "λδ θ.
                    ∀x ∈ ?X.
                      δ x = θ x ∨
                      (¬(δ x ⊑ t) ∧ ¬(δ x ⊑ s) ∧¬(θ x ⊑ t) ∧ ¬(θ x ⊑ s) ∧
                       (∀(u,v) ∈ {}. ¬(δ x ⊑ u) ∧ ¬(δ x ⊑ v) ∧ ¬(θ x ⊑ u) ∧ ¬(θ x ⊑ v)) ∧
                       (∀u v. insert⟨u,v⟩ ∈ set (?upds 𝒜) ∨
                              delete⟨u,v⟩ ∈ set (?upds 𝒜) ⟶
                                ¬(δ x ⊑ u) ∧ ¬(δ x ⊑ v) ∧ ¬(θ x ⊑ u) ∧ ¬(θ x ⊑ v)))"

              let ?q1 = "λδ. ∀x ∈ ?X. ∃c. δ x = Fun c []"

              let ?q2 = "λδ θ. ∀x ∈ ?X. ∀y ∈ ?X. δ x = δ y ⟷ θ x = θ y"

              have q0: "?q0 ℐ 𝒦" "?q0 𝒦 ℐ"
              proof -
                have upd_ex:
                    "∃u v. x ∈ fv u ∪ fv v ∧
                           (insert⟨u,v⟩ ∈ set (?upds A) ∨ delete⟨u,v⟩ ∈ set (?upds A))"
                  when "x ∈ fvsst (?upds A)" for x and A::"('fun,'atom,'sets,'lbl) prot_constr"
                  using that
                proof (induction A)
                  case (Cons a A)
                  obtain l b where a: "a = (l,b)" by (metis surj_pair)
                  show ?case using Cons.IH Cons.prems unfolding a by (cases b) auto
                qed simp
                
                have "¬(ℐ x ⊑ t)" "¬(ℐ x ⊑ s)" "¬(𝒦 x ⊑ t)" "¬(𝒦 x ⊑ s)"
                  when x: "x ∈ fvsst (?upds 𝒜) ∪ fv t ∪ fv s"
                    and x_neq: "ℐ x ≠ 𝒦 x"
                  for x
                proof -
                  have "¬(ℐ x ⊑ t) ∧ ¬(ℐ x ⊑ s) ∧ ¬(𝒦 x ⊑ t) ∧ ¬(𝒦 x ⊑ s)"
                  proof (cases "x ∈ fv t ∪ fv s")
                    case True thus ?thesis using q(1) x_neq by blast
                  next
                    case False
                    hence "x ∈ fvlsst 𝒜" using x flt2_upds_fv upds_fv by blast
                    hence "∃n. 𝒦 x = Fun (Val n) []"
                          "∃n. ℐ x = Fun (Val n) [] ∨ ℐ x = Fun (PubConst Value n) []"
                      using B'3 3(2)
                      unfolding valconst_cases_def valconsts_only_def unlabel_append fvsst_append
                      by (blast, blast)
                    thus ?thesis unfolding t h(1) by auto
                  qed
                  thus "¬(ℐ x ⊑ t)" "¬(ℐ x ⊑ s)" "¬(𝒦 x ⊑ t)" "¬(𝒦 x ⊑ s)" by simp_all
                qed
                moreover have "¬(ℐ x ⊑ u)" "¬(ℐ x ⊑ v)" "¬(𝒦 x ⊑ u)" "¬(𝒦 x ⊑ v)"
                  when x: "x ∈ fvsst (?upds 𝒜) ∪ fv t ∪ fv s"
                    and x_neq: "ℐ x ≠ 𝒦 x"
                    and uv: "insert⟨u,v⟩ ∈ set (?upds 𝒜) ∨
                             delete⟨u,v⟩ ∈ set (?upds 𝒜)"
                  for x u v
                proof -
                  have uv': "insert⟨u,v⟩ ∈ set (unlabel 𝒜) ∨ delete⟨u,v⟩ ∈ set (unlabel 𝒜)"
                    using uv flt2_subset by auto

                  have x_in: "x ∈ fvlsst 𝒜 ∪ fvlsst T' ∪ fv u ∪ fv v"
                    using t_s_fv x flt2_upds_fv upds_fv by blast

                  show "¬(ℐ x ⊑ u)" "¬(ℐ x ⊑ v)" "¬(𝒦 x ⊑ u)" "¬(𝒦 x ⊑ v)"
                    using x_neq A_insert_delete_not_subterm[OF x_in x_neq uv'] by simp_all
                qed
                ultimately show "?q0 ℐ 𝒦" unfolding upd_ex unfolding *
                  by (metis (no_types, lifting) empty_iff sup_bot_right)
                thus "?q0 𝒦 ℐ" by (metis (lifting) empty_iff)
              qed

              have q1: "?q1 ℐ" "?q1 𝒦"
                using q(2,3) flt2_upds_fv upds_fv by (blast,blast)

              have q2: "?q2 ℐ 𝒦" "?q2 𝒦 ℐ"
                using q(4) flt2_upds_fv upds_fv unfolding * by (blast,blast)

              show "?in ℐ (?upds 𝒜) ⟹ ?in 𝒦 (?upds 𝒜)"
                using dbupdsst_subst_const_swap[OF _ q0(1) q1(1,2) q2(1)] by force

              show "?in 𝒦 (?upds 𝒜) ⟹ ?in ℐ (?upds 𝒜)"
                using dbupdsst_subst_const_swap[OF _ q0(2) q1(2,1) q2(2)] by force
            qed
            hence db_subst_swap:
                "?in ℐ (unlabel 𝒜) ⟷ ?in 𝒦 (unlabel 𝒜)"
              using dbupdsst_filter by blast

            have "?in 𝒦 (unlabel ℬ)" when A: "?in ℐ (unlabel 𝒜)" using h(2)
            proof
              assume h': "h ≠ s_val"
              have "?in ℐ (unlabel (flt2 𝒜))"
                using A flt2_unlabel dbupdsst_set_term_neq_in_iff[OF h_neq[OF h'] A_setops_Fun]
                unfolding h(1) flt3_def by simp
              hence "?in 𝒦 (unlabel (flt2 𝒜))" using flt2_subst_swap by blast
              hence "?in 𝒦 (flt1 (flt2 𝒜))" using dbupdsst_filter unfolding flt1_def by blast
              hence "?in 𝒦 (flt1 (flt2 ℬ))" using flt_AB by simp
              hence "?in 𝒦 (unlabel (flt2 ℬ))" using dbupdsst_filter unfolding flt1_def by blast
              thus ?thesis using flt2_inset_iff[OF h(1) h'] by fast
            next
              assume h': "filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
              have "?in 𝒦 (unlabel 𝒜)" using A db_subst_swap by blast
              hence "?in 𝒦 (flt1 𝒜)" using dbupdsst_filter unfolding flt1_def by blast
              hence "?in 𝒦 (flt1 ℬ)" using h' unfolding flt1_def by simp
              thus ?thesis using dbupdsst_filter unfolding flt1_def by blast
            qed
            moreover have "¬?in 𝒦 (unlabel ℬ)" when A: "¬?in ℐ (unlabel 𝒜)" using h(2)
            proof
              assume h': "h ≠ s_val"
              have "¬?in ℐ (unlabel (flt2 𝒜))"
                using A flt2_unlabel dbupdsst_set_term_neq_in_iff[OF h_neq[OF h'] A_setops_Fun]
                unfolding h(1) flt3_def by simp
              hence "¬?in 𝒦 (unlabel (flt2 𝒜))" using flt2_subst_swap by blast
              hence "¬?in 𝒦 (flt1 (flt2 𝒜))" using dbupdsst_filter unfolding flt1_def by blast
              hence "¬?in 𝒦 (flt1 (flt2 ℬ))" using flt_AB by simp
              hence "¬?in 𝒦 (unlabel (flt2 ℬ))" using dbupdsst_filter unfolding flt1_def by blast
              thus ?thesis using flt2_inset_iff[OF h(1) h'] by fast
            next
              assume h': "filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
              have "¬?in 𝒦 (unlabel 𝒜)" using A db_subst_swap by blast
              hence "¬?in 𝒦 (flt1 𝒜)" using dbupdsst_filter unfolding flt1_def by blast
              hence "¬?in 𝒦 (flt1 ℬ)" using h' unfolding flt1_def by simp
              thus ?thesis using dbupdsst_filter unfolding flt1_def by blast
            qed
            ultimately show ?thesis by blast
          qed

          have "?M2 ⊢ t ⋅ θ ⋅ 𝒦"
            when ts: "(l, receive⟨ts⟩) ∈ set (transaction_receive T)" "t ∈ set ts" for l t ts
          proof -
            have *: "iklsst 𝒜 ⋅set ℐ ⊢ t ⋅ θ ⋅ ℐ" using 5 ts by blast

            note tθα = rcv_θ_is_α[OF ts]

            have t_T'_trm: "t ∈ trms_transaction T"
              using trmssst_memI(2)[OF unlabel_in[OF ts(1)] ts(2)]
              unfolding trms_transaction_unfold by blast

            have t_T'_trm': "t ⋅ θ ∈ trmslsst T'"
              using trmssst_memI(2)[
                      OF stateful_strand_step_subst_inI(2)[
                          OF unlabel_in[OF ts(1)], unfolded unlabel_subst]]
                    ts(2)
              unfolding T'_def trmssst_unlabel_duallsst_eq trms_transaction_subst_unfold by auto

            note t_no_val = T'_trm_no_val[OF t_T'_trm, unfolded tθα[symmetric]]

            have t_fv_T': "fv (t ⋅ θ) ⊆ fvlsst T'"
              using ts(2) stateful_strand_step_fv_subset_cases(2)[
                      OF stateful_strand_step_subst_inI(2)[OF unlabel_in[OF ts(1)], of θ]]
              unfolding T'_def unlabel_subst fvsst_unlabel_duallsst_eq fv_transaction_subst_unfold
              by auto

            have ik_B_fv_subset: "fvset (iklsst ℬ) ⊆ fvlsst ℬ"
              by (meson UnE fv_iksst_is_fvsst subset_iff)

            let ?fresh_vals = "(λn. Fun (Val n) []) ` T_val_fresh_vals"

            have q0: "iklsst ℬ ⋅set ℐ ⊢ t ⋅ θ ⋅ ℐ" using * B(10) by (blast intro: ideduct_mono)

            have q1: "∀x ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ). valconst_cases ℐ x"
              using 3(2,3) t_fv_T' ik_B_fv_subset unfolding B(9) by blast

            have q2: "∀x ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ). ∃n. 𝒦 x = Fun (Val n) []"
              using B'3 t_fv_T' ik_B_fv_subset
              unfolding valconsts_only_def unlabel_append fvsst_append B(9)
              by blast

            have T_val_constr_ik:
              "∃M. iklsst T_val_constr = M ∪ ?fresh_vals"
              "∃M. iklsst T_val_constr ⋅set 𝒦 = (M ⋅set 𝒦) ∪ ?fresh_vals"
            proof -
              obtain M where M: "iklsst T_val_constr = M ∪ ?fresh_vals"
                using T_val_constr(8) by blast
              have "?fresh_vals ⋅set 𝒦 = ?fresh_vals" by fastforce
              thus "∃M. iklsst T_val_constr = M ∪ ?fresh_vals"
                   "∃M. iklsst T_val_constr ⋅set 𝒦 = (M ⋅set 𝒦) ∪ ?fresh_vals"
                using M by (fastforce, fastforce)
            qed

            have "𝒦 x ∈ iklsst ℬ ∪ iklsst T_val_constr"
              when x: "x ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ)" "ℐ x = Fun (PubConst Value n) []" for x n
              using x(1) B'6'[OF _ x(2)] B'6''[OF _ x(2)] t_fv_T' ik_B_fv_subset
              unfolding B(9) unlabel_append fvsst_append by blast
            hence q3: "∀x ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ).
                        (∃n. ℐ x = Fun (PubConst Value n) []) ⟶ 𝒦 x ∈ iklsst ℬ ∪ ?fresh_vals"
              using T_val_constr_ik(1) T_val_constr(8) q2
              unfolding B(9) ℬ'_def unlabel_append iksst_append fvsst_append
              by (metis (no_types, lifting) UnE UnI1 UnI2 image_iff mem_Collect_eq)

            have q4: "∀x ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ). (∃n. ℐ x = Fun (Val n) []) ⟶ ℐ x = 𝒦 x"
              using B'5 t_fv_T' ik_B_fv_subset
              unfolding subst_eq_on_privvals_def B(9) unlabel_append fvsst_append
              by blast

            have q5: "∀x ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ). ∀y ∈ fvset (iklsst ℬ) ∪ fv (t ⋅ θ).
                        ℐ x = ℐ y ⟷ 𝒦 x = 𝒦 y"
              using B'7 t_fv_T' ik_B_fv_subset
              unfolding subst_eq_iff_def B(9) unlabel_append fvsst_append
              by blast

            have q6: "∀n. ¬(Fun (PubConst Value n) [] ⊑set insert (t ⋅ θ) (iklsst ℬ))"
            proof -
              have "∄n. s = Fun (PubConst Value n) []" when s: "s ⊑set trmslsst ℬ'" for s
              proof -
                have "f ≠ PubConst Value n" when f: "f ∈ funs_term s" for f n
                  using f s reachable_constraints_val_funs_private(1)[OF B'1 P, of f]
                  unfolding is_PubConstValue_def is_PubConst_def the_PubConst_type_def
                  by (metis (mono_tags, lifting) UN_I funs_term_subterms_eq(2) prot_fun.simps(85))
                thus ?thesis by fastforce
              qed
              moreover have "iklsst ℬ ⊆ trmslsst ℬ'"
                using iksst_trmssst_subset unfolding ℬ'_def unlabel_append trmssst_append by blast
              ultimately show ?thesis
                using t_no_val by blast
            qed

            show ?thesis
              using deduct_val_const_swap[OF q0 q1[unfolded valconst_cases_def] q2 q3 q4 q5 q6]
                    T_val_constr_ik(2)
              by (blast intro: ideduct_mono)
          qed
          moreover have "t ⋅ θ ⋅ 𝒦 = s ⋅ θ ⋅ 𝒦"
            when ts: "(l, ⟨ac: t ≐ s⟩) ∈ set (transaction_checks T)" for l ac t s
          proof -
            have q0: "t ⋅ θ ⋅ ℐ = s ⋅ θ ⋅ ℐ" using 5 ts by blast

            have "fvsstp (⟨ac: (t ⋅ θ) ≐ (s ⋅ θ)⟩) ⊆ fvlsst (transaction_checks T ⋅lsst θ)"
              using stateful_strand_step_fv_subset_cases(3)[
                      OF stateful_strand_step_subst_inI(3)[OF unlabel_in[OF ts], of θ]]
              unfolding unlabel_subst by simp
            hence t_s_fv: "fv (t ⋅ θ) ⊆ fvlsst T'" "fv (s ⋅ θ) ⊆ fvlsst T'"
              unfolding T'_def fvsst_unlabel_duallsst_eq fv_transaction_subst_unfold[of T θ]
              by (fastforce, fastforce)

            have "t ∈ trms_transaction T" "s ∈ trms_transaction T"
              using trmssst_memI(3,4)[OF unlabel_in[OF ts]]
              unfolding trms_transaction_unfold by (blast, blast)
            hence "∄n. u = Fun (Val n) [] ∨ u = Fun (PubConst Value n) []"
              when u: "u ⊑ t ⋅ θ ∨ u ⊑ s ⋅ θ" for u
              using u T'_trm_no_val unfolding eq_θ_is_α[OF ts] by blast
            hence "¬(ℐ x ⊑ t ⋅ θ)" "¬(ℐ x ⊑ s ⋅ θ)"
              when x: "x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ)" for x
              using x t_s_fv I' by (fast, fast)
            hence q1:
                "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ℐ x = 𝒦 x ∨ (¬(ℐ x ⊑ t ⋅ θ) ∧ ¬(ℐ x ⊑ s ⋅ θ))"
              by blast

            have q2: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. ℐ x = Fun c []"
              using t_s_fv 3(3) unfolding valconst_cases_def by blast

            have q3: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. 𝒦 x = Fun c []"
              using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fvsst_append by blast

            have q4: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∀y ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                        ℐ x = ℐ y ⟷ 𝒦 x = 𝒦 y"
              using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fvsst_append by blast

            show ?thesis by (rule subst_const_swap_eq'[OF q0 q1 q2 q3 q4])
          qed
          moreover have "t ⋅ θ ⋅ 𝒦 ≠ s ⋅ θ ⋅ 𝒦"
            when ts: "(l, ⟨t != s⟩) ∈ set (transaction_checks T)" for l t s
          proof -
            have q0: "t ⋅ θ ⋅ ℐ ≠ s ⋅ θ ⋅ ℐ" using 5 ts by blast

            have "fvsstp (⟨(t ⋅ θ) != (s ⋅ θ)⟩) ⊆ fvlsst (transaction_checks T ⋅lsst θ)"
              using stateful_strand_step_fv_subset_cases(8)[
                      OF stateful_strand_step_subst_inI(8)[OF unlabel_in[OF ts], of θ]]
              unfolding unlabel_subst by simp
            hence t_s_fv: "fv (t ⋅ θ) ⊆ fvlsst T'" "fv (s ⋅ θ) ⊆ fvlsst T'"
              unfolding T'_def fvsst_unlabel_duallsst_eq fv_transaction_subst_unfold[of T θ]
              by (fastforce, fastforce)

            have "t ∈ trms_transaction T" "s ∈ trms_transaction T"
              using trmssst_memI(9)[OF unlabel_in[OF ts]]
              unfolding trms_transaction_unfold by auto
            hence "∄n. u = Fun (Val n) []" when u: "u ⊑ t ⋅ θ ∨ u ⊑ s ⋅ θ" for u
              using u T'_trm_no_val unfolding noteq_θ_is_α[OF ts] by blast
            hence "¬(𝒦 x ⊑ t ⋅ θ)" "¬(𝒦 x ⊑ s ⋅ θ)"
              when x: "x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ)" for x
              using x t_s_fv B'3
              unfolding valconsts_only_def unlabel_append fvsst_append
              by (fast, fast)
            hence q1: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). 𝒦 x = ℐ x ∨ (¬(𝒦 x ⊑ t ⋅ θ) ∧ ¬(𝒦 x ⊑ s ⋅ θ))"
              by blast

            have q2: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. 𝒦 x = Fun c []"
              using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fvsst_append by blast

            have q3: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. ℐ x = Fun c []"
              using t_s_fv 3(3) unfolding valconst_cases_def by blast

            have q4: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∀y ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                        𝒦 x = 𝒦 y ⟷ ℐ x = ℐ y"
              using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fvsst_append by blast

            show ?thesis using q0 subst_const_swap_eq'[OF _ q1 q2 q3 q4] by fast
          qed
          moreover have "(t ⋅ θ ⋅ 𝒦, s ⋅ θ ⋅ 𝒦) ∈ ?D2"
            when ts: "(l, ⟨ac: t ∈ s⟩) ∈ set (transaction_checks T)" for l ac t s
          proof -
            have s_neq_s_val:
                "s ≠ ⟨s_val⟩s ∨ filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
            proof (cases "T_upds = []")
              case False thus ?thesis
                using step.hyps(2) ts x_val(7)
                unfolding transaction_strand_def
                by (cases ac) fastforce+
            qed (use B(13)[unfolded db_eq_def] in simp)

            have ts': "⟨ac: t ∈ s⟩ ∈ set (unlabel (transaction_strand T))"
              using ts unlabel_in[OF ts] unfolding transaction_strand_def by fastforce

            have "fvsstp (⟨ac: (t ⋅ θ) ∈ (s ⋅ θ)⟩) ⊆ fvlsst (transaction_checks T ⋅lsst θ)"
              using stateful_strand_step_fv_subset_cases(6)[
                      OF stateful_strand_step_subst_inI(6)[OF unlabel_in[OF ts], of θ]]
              unfolding unlabel_subst by simp
            hence t_s_fv: "fv (t ⋅ θ) ⊆ fvlsst T'" "fv (s ⋅ θ) ⊆ fvlsst T'"
              unfolding T'_def fvsst_unlabel_duallsst_eq fv_transaction_subst_unfold[of T θ]
              by (fastforce, fastforce)

            have "t ∈ trms_transaction T" "s ∈ trms_transaction T"
              using ts' unfolding trmssst_def by (force, force)
            hence "∄n. u = Fun (Val n) [] ∨ u = Fun (PubConst Value n) []"
              when u: "u ⊑ t ⋅ θ ∨ u ⊑ s ⋅ θ" for u
              using u T'_trm_no_val unfolding in_θ_is_α[OF ts] by blast
            hence "¬(𝒦 x ⊑ t ⋅ θ)" "¬(𝒦 x ⊑ s ⋅ θ)" "¬(ℐ x ⊑ t ⋅ θ)" "¬(ℐ x ⊑ s ⋅ θ)"
              when x: "x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ)" for x
              using x t_s_fv B'3 I'
              unfolding valconsts_only_def unlabel_append fvsst_append
              by (fast,fast,fast,fast)
            hence q1: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                        ℐ x = 𝒦 x ∨
                        (¬(ℐ x ⊑ t ⋅ θ) ∧ ¬(ℐ x ⊑ s ⋅ θ) ∧ ¬(𝒦 x ⊑ t ⋅ θ) ∧ ¬(𝒦 x ⊑ s ⋅ θ))"
              by blast

            have q2: "∀x ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. ℐ x = Fun c []"
              using t_s_fv 3(2,3) unfolding valconst_cases_def by blast

            have q3: "∀x ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. 𝒦 x = Fun c []"
              using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fvsst_append by blast

            have q4: "∀x ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                      ∀y ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                        ℐ x = ℐ y ⟷ 𝒦 x = 𝒦 y"
              using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fvsst_append by blast

            obtain h tx where s: "s = ⟨h⟩s" and tx: "t = Var tx"
              using ts' transaction_selects_are_Value_vars[OF T_wf(1,2), of t s]
                    transaction_inset_checks_are_Value_vars[OF T_adm, of t s]
              by (cases ac) auto

            have h:
                "s ⋅ θ = ⟨h⟩s"
                "h ≠ s_val ∨ filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
              using s s_neq_s_val by (simp,blast)

            obtain ty where ty: "t ⋅ θ = Var ty"
              using tx transaction_renaming_subst_is_renaming(2)[OF step.hyps(5), of tx]
              unfolding in_θ_is_α[OF ts] by force

            have "(t ⋅ θ ⋅ ℐ, s ⋅ θ ⋅ ℐ) ∈ dbupdsst (unlabel 𝒜) ℐ {}" using 5 ts by blast
            hence "(t ⋅ θ ⋅ 𝒦, s ⋅ θ ⋅ 𝒦) ∈ dbupdsst (unlabel ℬ) 𝒦 {}"
              using inset_model_swap[OF h ty _ q1 q2 q3 q4] t_s_fv by simp
            thus ?thesis unfolding D2 by blast
          qed
          moreover have "(t ⋅ θ ⋅ 𝒦, s ⋅ θ ⋅ 𝒦) ∉ ?D2"
            when ts: "(l, ⟨t not in s⟩) ∈ set (transaction_checks T)" for l t s
          proof -
            have s_neq_s_val:
                "(T_upds ≠ [] ∧ s ≠ ⟨s_val⟩s) ∨
                 (T_upds = [] ∧ filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ))"
            proof (cases "T_upds = []")
              case False thus ?thesis
                using step.hyps(2) ts x_val(7) unfolding transaction_strand_def by force
            qed (use B(13)[unfolded db_eq_def] in simp)

            have ts': "⟨t not in s⟩ ∈ set (unlabel (transaction_strand T))"
              using ts unlabel_in[OF ts] unfolding transaction_strand_def by fastforce

            have "fvsstp (⟨(t ⋅ θ) not in (s ⋅ θ)⟩) ⊆ fvlsst (transaction_checks T ⋅lsst θ)"
              using stateful_strand_step_fv_subset_cases(9)[
                      OF stateful_strand_step_subst_inI(9)[OF unlabel_in[OF ts], of θ]]
              unfolding unlabel_subst by simp
            hence t_s_fv: "fv (t ⋅ θ) ⊆ fvlsst T'" "fv (s ⋅ θ) ⊆ fvlsst T'"
              unfolding T'_def fvsst_unlabel_duallsst_eq fv_transaction_subst_unfold[of T θ]
              by (fastforce, fastforce)

            have "t ∈ trms_transaction T" "s ∈ trms_transaction T"
              using ts' unfolding trmssst_def by (force, force)
            hence "∄n. u = Fun (Val n) [] ∨ u = Fun (PubConst Value n) []"
              when u: "u ⊑ t ⋅ θ ∨ u ⊑ s ⋅ θ" for u
              using u T'_trm_no_val unfolding notin_θ_is_α[OF ts] by blast
            hence "¬(𝒦 x ⊑ t ⋅ θ)" "¬(𝒦 x ⊑ s ⋅ θ)" "¬(ℐ x ⊑ t ⋅ θ)" "¬(ℐ x ⊑ s ⋅ θ)"
              when x: "x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ)" for x
              using x t_s_fv B'3 I'
              unfolding valconsts_only_def unlabel_append fvsst_append
              by (fast,fast,fast,fast)
            hence q1: "∀x ∈ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                        ℐ x = 𝒦 x ∨
                        (¬(ℐ x ⊑ t ⋅ θ) ∧ ¬(ℐ x ⊑ s ⋅ θ) ∧ ¬(𝒦 x ⊑ t ⋅ θ) ∧ ¬(𝒦 x ⊑ s ⋅ θ))"
              by blast

            have q2: "∀x ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. ℐ x = Fun c []"
              using t_s_fv 3(2,3) unfolding valconst_cases_def by blast

            have q3: "∀x ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ). ∃c. 𝒦 x = Fun c []"
              using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fvsst_append by blast

            have q4: "∀x ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                      ∀y ∈ fvlsst 𝒜 ∪ fv (t ⋅ θ) ∪ fv (s ⋅ θ).
                        ℐ x = ℐ y ⟷ 𝒦 x = 𝒦 y"
              using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fvsst_append by blast

            obtain h tx where s: "s = ⟨h⟩s" and tx: "t = Var tx"
              using transaction_notinset_checks_are_Value_vars(1,2)[OF T_adm ts', of t s] by auto

            have h:
                "s ⋅ θ = ⟨h⟩s"
                "h ≠ s_val ∨ filter is_Update (unlabel 𝒜) = filter is_Update (unlabel ℬ)"
                "T_upds ≠ [] ⟹ h ≠ s_val"
              using s s_neq_s_val by (simp,blast,blast)

            obtain ty where ty: "t ⋅ θ = Var ty"
              using tx transaction_renaming_subst_is_renaming(2)[OF step.hyps(5), of tx]
              unfolding notin_θ_is_α[OF ts] by force

            have *: "(t ⋅ θ ⋅ 𝒦, s ⋅ θ ⋅ 𝒦) ≠ (u ⋅ 𝒦, v ⋅ 𝒦)"
              when u: "insert⟨u,v⟩ ∈ set (unlabel T_val_constr)"
                and h': "h ≠ s_val"
              for u v
            proof -
              have "v = ⟨s_val⟩s" using T_val_constr(9) unlabel_mem_has_label[OF u] by force
              thus ?thesis using h(1) h' by simp
            qed

            have "(t ⋅ θ ⋅ ℐ, s ⋅ θ ⋅ ℐ) ∉ dbupdsst (unlabel 𝒜) ℐ {}" using 5 ts by blast
            hence **: "(t ⋅ θ ⋅ 𝒦, s ⋅ θ ⋅ 𝒦) ∉ dbupdsst (unlabel ℬ) 𝒦 {}"
              using inset_model_swap[OF h(1,2) ty _ q1 q2 q3 q4] t_s_fv by simp
            
            show ?thesis
            proof (cases "T_upds = []")
              case True
              have "dbupdsst (unlabel T_val_constr) I D = D" for I D
                using T_val_constr_no_upds_if_no_T_upds[OF True]
                      dbupdsst_filter[of "unlabel T_val_constr"]
                by force
              thus ?thesis using ** by simp 
            next
              case False thus ?thesis
                using ** * h(3) T_val_constr_no_upds_if_no_T_upds unfolding D2 by blast
            qed
          qed
          ultimately show "?sem ?M2 ?D2 T'"
            unfolding T'_def 4[OF T_adm K3 K2] by blast
        qed
      qed
    qed

    show ?case
      using B'1 B'2 B'3 B'4 B'5 B'6 B'7 B'8_9 B'10_11 B'12 B'13 B'14
      unfolding θ_def[symmetric] T'_def[symmetric] by blast
  qed

  obtain ℬ 𝒥 where B:
      "ℬ ∈ reachable_constraints P" "?wt_model 𝒥 ℬ"
      "∀x ∈ fvlsst 𝒜. ∃n. 𝒥 x = Fun (Val n) []" "?rcv_att 𝒜 n ⟶ ?rcv_att ℬ n" "fvlsst 𝒜 = fvlsst ℬ"
    using lmm[OF finite.emptyI _ _ finite.emptyI] unfolding valconsts_only_def by auto
 
  show ?thesis
    using B(1,3) welltyped_constraint_model_attack_if_receive_attack[OF B(2)] B(4) 2
    unfolding wt_attack_def B(5) by (meson list.set_intros(1))
qed

private lemma add_occurs_msgs_soundness_aux2:
  assumes P: "∀T ∈ set P. admissible_transaction T"
    and A: "𝒜 ∈ reachable_constraints P"
  shows "∃ℬ ∈ reachable_constraints (map add_occurs_msgs P). 𝒜 = rm_occurs_msgs_constr ℬ"
using A
proof (induction rule: reachable_constraints.induct)
  case (step 𝒜 T ξ σ α)
  define θ where "θ ≡ ξ ∘s σ ∘s α"

  let ?A' = "duallsst (transaction_strand T ⋅lsst θ)"
  let ?B' = "duallsst (transaction_strand (add_occurs_msgs T) ⋅lsst θ)"

  obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp

  have P': "∀T ∈ set P. admissible_transaction' T"
             "∀T ∈ set P. admissible_transaction_no_occurs_msgs T"
    using P admissible_transactionE'(1,2) by (blast,blast)

  note T_adm' = bspec[OF P step.hyps(2)]
  note T_adm = bspec[OF P'(1) step.hyps(2)]
  note ξ_empty = admissible_transaction_decl_subst_empty[OF T_adm step.hyps(3)]
  note T_fresh_val = admissible_transactionE(2)[OF T_adm]

  note T_no_occ = admissible_transactionE'(2)[OF T_adm']

  obtain ℬ where B:
      "ℬ ∈ reachable_constraints (map add_occurs_msgs P)" "𝒜 = rm_occurs_msgs_constr ℬ"
    using step.IH by blast

  note 0 = add_occurs_msgs_cases[OF T]
  note 1 = add_occurs_msgs_vars_eq[OF bspec[OF P'(1)]]
  note 2 = add_occurs_msgs_trms[of T]
  note 3 = add_occurs_msgs_transaction_strand_set[OF T]

  have 4: "add_occurs_msgs T ∈ set (map add_occurs_msgs P)"
    using step.hyps(2) by simp

  have 5: "transaction_decl_subst ξ (add_occurs_msgs T)"
    using step.hyps(3) 0(4) unfolding transaction_decl_subst_def by argo

  have "t ∉ subtermsset (trmslsst ℬ)"
       "t ∉ subtermsset (trms_transaction (add_occurs_msgs T))"
    when t: "t ∈ subst_range σ" for t
  proof -
    obtain c where c: "t = Fun (Val c) []"
      using t T_fresh_val transaction_fresh_subst_domain[OF step.hyps(4)]
            transaction_fresh_subst_sends_to_val[OF step.hyps(4), of _ thesis]
      by fastforce

    have *: "t ∉ subtermsset (trmslsst 𝒜)" "t ∉ subtermsset (trms_transaction T)"
      using t step.hyps(4) unfolding transaction_fresh_subst_def by (fast,fast)

    have "t ⊑set trmslsst 𝒜 ∨ (∃x ∈ fvlsst 𝒜. t ⊑ occurs (Var x)) ∨
           (∃c. Fun c [] ⊑set trmslsst 𝒜 ∧ t ⊑ occurs (Fun c []))"
      when t: "t ⊑set trmslsst ℬ"
      using t rm_occurs_msgs_constr_reachable_constraints_trms_cases[OF P' B(2,1)] by fast
    thus "t ∉ subtermsset (trmslsst ℬ)"
      using *(1) unfolding c by fastforce

    show "t ∉ subtermsset (trms_transaction (add_occurs_msgs T))"
      using *(2) unfolding 2 c by force
  qed
  hence 6: "transaction_fresh_subst σ (add_occurs_msgs T) (trmslsst ℬ)"
    using step.hyps(4) unfolding transaction_fresh_subst_def 0(5) 2 by fast

  have 7: "transaction_renaming_subst α (map add_occurs_msgs P) (varslsst ℬ)"
    using step.hyps(5) rm_occurs_msgs_constr_reachable_constraints_vars_eq[OF P' B(1)] B(2) 1(5)
    unfolding transaction_renaming_subst_def by simp

  have "?A' = rm_occurs_msgs_constr ?B'"
    using admissible_transaction_decl_fresh_renaming_subst_not_occurs[OF T_adm step.hyps(3,4,5)]
          rm_occurs_msgs_constr_transaction_strand''[OF T_adm T_no_occ]
    unfolding θ_def[symmetric] by metis
  hence 8: "𝒜@?A' = rm_occurs_msgs_constr (ℬ@?B')"
    by (metis rm_occurs_msgs_constr_append B(2))

  show ?case using reachable_constraints.step[OF B(1) 4 5 6 7] 8 unfolding θ_def by blast
qed (metis reachable_constraints.init rm_occurs_msgs_constr.simps(1))

private lemma add_occurs_msgs_soundness_aux3:
  assumes P: "∀T ∈ set P. admissible_transaction T"
    and A: "𝒜 ∈ reachable_constraints (map add_occurs_msgs P)"
           "welltyped_constraint_model ℐ (rm_occurs_msgs_constr 𝒜)"
    and I: "∀x ∈ fvlsst 𝒜. ∃n. ℐ x = Fun (Val n) []" (is "?I 𝒜")
  shows "welltyped_constraint_model ℐ 𝒜" (is "?Q ℐ 𝒜")
using A I
proof (induction 𝒜 rule: reachable_constraints.induct)
  case (step 𝒜 T ξ σ α)
  let ?f = rm_occurs_msgs_constr
  let ?sem = "λB. strand_sem_stateful (iklsst 𝒜 ⋅set ℐ) (dbupdsst (unlabel 𝒜) ℐ {}) (unlabel B) ℐ"

  define θ where "θ ≡ ξ ∘s σ ∘s α"
  define ℬ where "ℬ ≡ duallsst (transaction_strand T ⋅lsst θ)"

  obtain T' where T': "T' ∈ set P" "T = add_occurs_msgs T'"
    using step.hyps(2) by fastforce
  then obtain A' B' C' D' E' F' where T'': "T' = Transaction A' B' C' D' E' F'" 
    using prot_transaction.exhaust by blast

  have P': "∀T ∈ set (map add_occurs_msgs P). admissible_transaction' T"
           "∀T ∈ set (map add_occurs_msgs P). admissible_transaction_occurs_checks T"
           "∀T ∈ set P. admissible_transaction' T"
           "∀T ∈ set P. admissible_transaction_no_occurs_msgs T"
    using P admissible_transactionE' add_occurs_msgs_admissible_occurs_checks
    by (fastforce,fastforce,fastforce,fastforce)

  note T_adm = bspec[OF P'(1) step.hyps(2)]
  note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
  note T'_adm = bspec[OF P'(3) T'(1)]
  note T'_no_occ = bspec[OF P'(4) T'(1)]
  note T'_wf = admissible_transaction_is_wellformed_transaction(1)[OF T'_adm]
  note ξ_empty = admissible_transaction_decl_subst_empty[OF T_adm step.hyps(3)]
  note T_fresh_val = admissible_transactionE(2)[OF T_adm]

  have 0: "?Q ℐ (?f 𝒜)" "?I 𝒜" "?I ℬ"
    by (metis step.prems(1) welltyped_constraint_model_prefix rm_occurs_msgs_constr_append,
        simp_all add: step.prems(2) θ_def ℬ_def)

  note IH = step.IH[OF 0(1,2)]

  have I': "wtsubst ℐ" "interpretationsubst ℐ" "wftrms (subst_range ℐ)"
    using step.prems(1) unfolding welltyped_constraint_model_def constraint_model_def by blast+

  have 1: "∀x ∈ fv_transaction T. ∄t. θ x = occurs t"
          "∀x ∈ fv_transaction T. θ x ≠ Fun OccursSec []"
    using admissible_transaction_decl_fresh_renaming_subst_not_occurs[OF T_adm step.hyps(3,4,5)]
    unfolding θ_def[symmetric] by simp_all

  have "(iklsst (?f 𝒜) ⋅set ℐ) ∪ (iklsst 𝒜 ⋅set ℐ) = iklsst 𝒜 ⋅set ℐ"
    using rm_occurs_msgs_constr_ik_subset by fast
  hence 2: "?sem (?f ℬ)"
    using step.prems(1) strand_sem_append_stateful[of "{}" "{}" "unlabel (?f 𝒜)" "unlabel (?f ℬ)"]
          rm_occurs_msgs_constr_dbupdsst_eq[of 𝒜 ℐ "{}"] rm_occurs_msgs_constr_append[of 𝒜 ℬ]
          strand_sem_ik_mono_stateful[of "iklsst (?f 𝒜) ⋅set ℐ" _ _ _ "iklsst 𝒜 ⋅set ℐ"]
    unfolding welltyped_constraint_model_def constraint_model_def θ_def[symmetric] ℬ_def[symmetric]
    by auto

  note 3 = rm_occurs_msgs_constr_transaction_strand''[
            OF T'_adm T'_no_occ 1[unfolded T'(2)], unfolded ℬ_def[symmetric] T'(2)[symmetric]]

  note 4 = add_occurs_msgs_cases[OF T'', unfolded T'(2)[symmetric]]


  define xs where "xs ≡ fv_listsst (unlabel (transaction_strand T'))"
  define flt where "flt ≡ filter (λx. x ∉ set (transaction_fresh T'))"
  define occs where "occs ≡ map (λx. occurs (Var x)::('fun,'atom,'sets,'lbl) prot_term)"

  note 6 = add_occurs_msgs_transaction_strand_cases(7,8,9)[
            of T' θ, unfolded xs_def[symmetric] flt_def[symmetric] occs_def[symmetric]
                              T'(2)[symmetric]]

  have 7: "x ∈ fv_transaction T - set (transaction_fresh T)"
    when x: "x ∈ set (flt xs)" for x
    using that fv_listsst_is_fvsst add_occurs_msgs_vars_eq(3,9)[OF T'_adm]
    unfolding xs_def flt_def T'(2) by force

  have 9: "∃y. θ x = Var y"
    when x: "x ∈ set (flt xs)" for x
  proof -
    have *: "x ∉ fst ` set (transaction_decl T ())"
      using admissible_transactionE(1)[OF T_adm] by simp

    have **: "x ∉ set (transaction_fresh T)" using 7[OF x] by simp

    show ?thesis
      using transaction_decl_fresh_renaming_substs_range(4)[OF step.hyps(3,4,5) * **]
      unfolding θ_def by blast
  qed

  have 8: "∃y ∈ fvlsst ℬ. θ x = Var y"
    when x: "x ∈ set (flt xs)" for x
  proof -
    note * = 7[OF x]

    obtain y where y: "θ x = Var y" using 9[OF x] by blast

    have "x ∈ fvlsst (duallsst (transaction_strand T))" by (metis * Diff_iff fvsst_unlabel_duallsst_eq)
    have "θ x ∈ θ ` fvlsst (transaction_strand T)" using * by fast
    hence "fv (θ x) ⊆ fvset (θ ` fv_transaction T)" by force
    hence "fv (θ x) ⊆ fvlsst (transaction_strand T ⋅lsst θ)"
      using fvsst_subst_if_no_bvars[OF admissible_transactionE(4)[OF T_adm], of θ]
      by (metis unlabel_subst)
    hence "fv (θ x) ⊆ fvlsst ℬ" by (metis fvsst_unlabel_duallsst_eq ℬ_def)
    thus ?thesis using y by simp
  qed

  have ℬ_var_is_ℐ_val: "∃n. ℐ x = Fun (Val n) []" when x: "x ∈ fvlsst ℬ" for x
    using step.prems(2) x unfolding ℬ_def[symmetric] θ_def[symmetric] by auto

  have T'_var_is_θℐ_val: "∃n. θ x ⋅ ℐ = Fun (Val n) []" when x: "x ∈ set (flt xs)" for x
    using 8[OF x] ℬ_var_is_ℐ_val by force


  (* TODO: extract lemma *)
  have poschecks_has_occ: "occurs (Fun (Val n) []) ∈ iklsst 𝒜"
    when x: "⟨ac: t ∈ s⟩ ∈ set (unlabel ℬ)"
      and n: "t ⋅ ℐ = Fun (Val n) []"
    for ac t s n
  proof -
    have *: "(t ⋅ ℐ, s ⋅ ℐ) ∈ dbupdsst (unlabel 𝒜) ℐ {}"
    proof -
      obtain t' s' where t':
          "⟨ac: t' ∈ s'⟩ ∈ set (unlabel (transaction_checks T'))" "t = t' ⋅ θ" "s = s' ⋅ θ"
        using 4(8) x stateful_strand_step_mem_substD(6)
              wellformed_transaction_strand_unlabel_memberD(10)[OF T_wf(1)]
              duallsst_unlabel_steps_iff(6)
        unfolding ℬ_def by (metis (no_types) unlabel_subst duallsst_subst)

      have "(t' ⋅ θ ⋅ ℐ, s' ⋅ θ ⋅ ℐ) ∈ dbupdsst (unlabel 𝒜) ℐ {}"
        using t'(1) 2
              wellformed_transaction_unlabel_sem_iff[
                OF T'_wf(1) I'(2,3), of "iklsst 𝒜 ⋅set ℐ" "dbupdsst (unlabel 𝒜) ℐ {}" θ]
        unfolding 3 by blast
      thus ?thesis using t'(2,3) by simp
    qed

    have "t' ∈ trmslsst 𝒜"
      when "insert⟨t',s'⟩ ∈ set (unlabel 𝒜)" for t' s'
      using that by force

    have "t ⋅ ℐ ⊑set trmslsst 𝒜"
    proof -
      obtain t' s' where t': "insert⟨t',s'⟩ ∈ set (unlabel 𝒜)" "t ⋅ ℐ = t' ⋅ ℐ" "s ⋅ ℐ = s' ⋅ ℐ"
        using * dbsst_in_cases[of "t ⋅ ℐ" "s ⋅ ℐ" "unlabel 𝒜" ℐ "[]"]
              dbsst_set_is_dbupdsst[of "unlabel 𝒜" ℐ "[]"]
        by auto

      have t'': "t' = t ⋅ ℐ ∨ (∃y ∈ fvlsst 𝒜. t' = Var y ∧ ℐ y = t ⋅ ℐ)"
        using t'(1,2) stateful_strand_step_fv_subset_cases(4)
        unfolding n by (cases t') (force,force)
      thus ?thesis
      proof
        assume "t' = t ⋅ ℐ" thus ?thesis using t'(1) by force
      next
        assume "∃y ∈ fvlsst 𝒜. t' = Var y ∧ ℐ y = t ⋅ ℐ"
        then obtain y where y: "y ∈ fvlsst 𝒜" "ℐ y = t ⋅ ℐ" by blast

        have "Γv y = TAtom Value"
          using y(2) wt_subst_trm''[OF I'(1), of "Var y"] unfolding n by simp
        hence "∃B. prefix B 𝒜 ∧ t ⋅ ℐ ⊑set trmslsst B"
          by (metis y constraint_model_Value_var_in_constr_prefix[OF step.hyps(1) IH P'(1,2)])
        thus ?thesis unfolding prefix_def by auto
      qed
    qed
    thus ?thesis
      using reachable_constraints_occurs_fact_ik_case'[OF step.hyps(1) P'(1,2)]
      unfolding n by blast
  qed

  (* TODO: extract lemma *)
  have snds_has_occ: "occurs (Fun (Val n) []) ∈ iklsst 𝒜"
    when ts: "send⟨ts⟩ ∈ set (unlabel ℬ)"
      and n: "Fun (Val n) [] ⊑set set ts ⋅set ℐ"
    for ts n
  proof -
    have "receive⟨ts⟩ ∈ set (unlabel (transaction_strand T ⋅lsst θ))"
      using ts duallsst_unlabel_steps_iff(2) unfolding ℬ_def by metis
    then obtain ts' where ts':
        "receive⟨ts'⟩ ∈ set (unlabel (transaction_strand T))" "ts = ts' ⋅list θ"
      by (metis subst_lsst_memD(1) unlabel_in unlabel_mem_has_label)


    have "?sem (duallsst (transaction_receive T' ⋅lsst θ))"
      using 2 strand_sem_append_stateful[of "iklsst 𝒜 ⋅set ℐ" "dbupdsst (unlabel 𝒜) ℐ {}"]
      unfolding 3 transaction_dual_subst_unlabel_unfold by blast
    moreover have "list_all is_Receive (unlabel (transaction_receive T'))"
      using T'_wf unfolding wellformed_transaction_def by blast
    hence "list_all is_Send (unlabel (duallsst (transaction_receive T' ⋅lsst θ)))"
      by (metis subst_lsst_unlabel subst_sst_list_all(2) duallsst_list_all(1))
    hence "iklsst (duallsst (transaction_receive T' ⋅lsst θ)) = {}"
      using in_iksst_iff unfolding list_all_iff is_Send_def by fast
    ultimately have *: "iklsst 𝒜 ⋅set ℐ ⊢ t ⋅  ℐ"
      when "send⟨ts⟩ ∈ set (unlabel (duallsst (transaction_receive T' ⋅lsst θ)))" "t ∈ set ts"
      for t ts
      using strand_sem_stateful_sends_deduct[OF _ that] by simp
    hence *: "iklsst 𝒜 ⋅set ℐ ⊢ t ⋅ θ ⋅ ℐ"
      when ts: "receive⟨ts⟩ ∈ set (unlabel (transaction_receive T'))" "t ∈ set ts" for t ts
      using ts(2) duallsst_unlabel_steps_iff(2)[of "ts ⋅list θ" "transaction_receive T' ⋅lsst θ"]
            stateful_strand_step_subst_inI(2)[OF ts(1), of θ, unfolded unlabel_subst]
      by auto

    have **: "set (flt xs) = fv_transaction T' - set (transaction_fresh T')"
      using fv_listsst_is_fvsst unfolding flt_def xs_def by fastforce

    have rcv_case: ?thesis
      when "ts = ts' ⋅list θ" "Fun (Val n) [] ⊑set set ts ⋅set ℐ"
           "receive⟨ts'⟩ ∈ set (unlabel (transaction_receive T'))"
      for ts ts'
      using that * reachable_constraints_occurs_fact_ik_case''[OF step.hyps(1) IH P'(1,2)] by auto

    have "receive⟨ts'⟩ ∈ set (unlabel (transaction_receive T))"
      using wellformed_transaction_strand_unlabel_memberD(1)[OF T_wf] ts'(1) by blast
    hence "(ts' = map (λx. occurs (Var x)) (flt xs) ∧ ts' ≠ []) ∨
           receive⟨ts'⟩ ∈ set (unlabel (transaction_receive T'))"
      (is "?A ∨ ?B")
      using ** ts'(1) add_occurs_msgs_cases(13)[OF T'']
      unfolding T'(2)[symmetric] xs_def[symmetric] flt_def[symmetric] by force
    thus ?thesis
    proof
      assume ?A
      then obtain x where x: "x ∈ set (flt xs)" "Fun (Val n) [] ⊑ θ x ⋅ ℐ"
        using ts' n by fastforce
      
      have x': "θ x ⋅ ℐ = Fun (Val n) []" "x ∈ fv_transaction T" "x ∉ set (transaction_fresh T)"
               "x ∈ fv_transaction T'" "x ∉ set (transaction_fresh T')"
        using x(2) T'_var_is_θℐ_val[OF x(1)] 7[OF x(1)] ** x(1) by fastforce+

      let ?snds = "unlabel (duallsst (transaction_receive T' ⋅lsst θ))"
      let ?chks = "unlabel (duallsst (transaction_checks T' ⋅lsst θ))"

      have B_subsets: "set ?chks ⊆ set (unlabel ℬ)"
        unfolding ℬ_def transaction_dual_subst_unlabel_unfold 4(8) by fastforce

      from admissible_transaction_fv_in_receives_or_selects_dual_subst[OF T'_adm x'(4,5), of θ]
      show ?thesis
      proof
        assume "∃ts. send⟨ts⟩ ∈ set ?snds ∧ θ x ⊑set set ts"
        then obtain ss where ss: "send⟨ss⟩ ∈ set ?snds" "θ x ⊑set set ss" by blast
        
        obtain ss' where ss':
            "ss = ss' ⋅list θ" "receive⟨ss'⟩ ∈ set (unlabel (transaction_receive T'))"
          by (metis ss(1) duallsst_unlabel_steps_iff(2) subst_lsst_memD(1)
                    unlabel_in unlabel_mem_has_label)

        show ?thesis
          using rcv_case[OF ss'(1) _ ss'(2)] subst_subterms[OF ss(2), of ℐ] x'(1) by argo
      qed (use B_subsets poschecks_has_occ[OF _ x'(1)] in blast)
    qed (metis rcv_case[OF ts'(2) n])
  qed

  (* TODO: extract lemma *)
  have "occurs (θ x ⋅ ℐ) ∈ iklsst 𝒜" when x: "x ∈ set (flt xs)" for x
  proof -
    have "(∃ac s. ⟨ac: θ x ∈ s⟩ ∈ set (unlabel ℬ)) ∨
           (∃ts. send⟨ts⟩ ∈ set (unlabel ℬ) ∧ θ x ⊑set set ts)"
      (is "(∃ac s. ?A ac s) ∨ (∃ts. ?B1 ts ∧ ?B2 ts)")
      using 7[OF x] admissible_transaction_fv_in_receives_or_selects_dual_subst[OF T_adm, of x θ]
      unfolding ℬ_def transaction_dual_subst_unlabel_unfold by auto
    thus ?thesis
    proof
      assume "∃ac s. ?A ac s"
      then obtain ac s where s: "?A ac s" by blast
      show ?thesis using poschecks_has_occ[OF s] T'_var_is_θℐ_val[OF x] by force
    next
      assume "∃ts. ?B1 ts ∧ ?B2 ts"
      then obtain ts where ts: "?B1 ts" "?B2 ts" by meson
      have ts': "θ x ⋅ ℐ ⊑set set ts ⋅set ℐ" by (metis ts(2) subst_subterms)
      show ?thesis using snds_has_occ[OF ts(1)] ts' T'_var_is_θℐ_val[OF x] by force
    qed
  qed
  hence "occurs (θ x ⋅ ℐ) ⋅ ℐ ∈ iklsst 𝒜 ⋅set ℐ" when "x ∈ set (flt xs)" for x using that by fast
  moreover have "occurs (θ x ⋅ ℐ) ⋅ ℐ = occurs (θ x ⋅ ℐ)" for x
    using subst_ground_ident[OF interpretation_grounds[OF I'(2), of "θ x"], of ℐ] by simp
  ultimately have "occurs (θ x ⋅ ℐ) ∈ iklsst 𝒜 ⋅set ℐ" when "x ∈ set (flt xs)" for x
    using that by auto
  hence "iklsst 𝒜 ⋅set ℐ ⊢ t ⋅ ℐ" when "t ∈ set (occs (flt xs) ⋅list θ)" for t
    using that unfolding occs_def by auto
  hence occs_sem: "?sem [⟨⋆, send⟨occs (flt xs) ⋅list θ⟩⟩]"
    by auto


  (* TODO: extract lemma *)
  have "?sem ℬ"
  proof -
    let ?IK = "iklsst 𝒜 ⋅set ℐ"
    let ?DB = "dbupdsst (unlabel 𝒜) ℐ {}"
    let ?snds = "duallsst (transaction_receive T' ⋅lsst θ)"
    let ?snds_occs = "(⟨⋆, send⟨occs (flt xs) ⋅list θ⟩⟩)#?snds"
    let ?chks = "duallsst (transaction_checks T' ⋅lsst θ)"
    let ?upds = "duallsst (transaction_updates T' ⋅lsst θ)"
    let ?rcvs = "duallsst (transaction_send T' ⋅lsst θ)"

    note * = strand_sem_append_stateful[of _ _ _ _ ℐ]
    note ** = transaction_dual_subst_unlabel_unfold
    have ***: "⋀M. M ∪ (iksst [] ⋅set ℐ) = M"
              "⋀D. dbupdsst [] ℐ D = D"
      by simp_all

    have snds_sem:
        "?sem ?snds"
        "?sem ?snds_occs"
      using 2 occs_sem *[of ?IK ?DB]
      unfolding 3 ** by (blast, fastforce)

    have "list_all is_Receive (unlabel (transaction_receive T'))"
      using T'_wf unfolding wellformed_transaction_def by blast
    hence "list_all is_Send (unlabel ?snds)" "list_all is_Send (unlabel ?snds_occs)"
      using subst_sst_list_all(2) unlabel_subst duallsst_list_all(1)
      by (metis, metis (no_types) list.pred_inject(2) stateful_strand_step.disc(1) unlabel_Cons(1))
    hence "∀a ∈ set (unlabel ?snds). ¬is_Receive a ∧ ¬is_Insert a ∧ ¬is_Delete a"
          "∀a ∈ set (unlabel ?snds_occs). ¬is_Receive a ∧ ¬is_Insert a ∧ ¬is_Delete a"
      unfolding list_all_iff by (blast,blast)
    hence snds_no_upds:
        "iklsst ?snds ⋅set ℐ = {}"
        "dbupdsst (unlabel ?snds) ℐ ?DB = ?DB"
        "iklsst (?snds_occs) ⋅set ℐ = {}"
        "dbupdsst (unlabel ?snds_occs) ℐ ?DB = ?DB"
      by (metis iksst_snoc_no_receive_empty, metis dbupdsst_no_upd,
          metis iksst_snoc_no_receive_empty, metis dbupdsst_no_upd)

    have chks_sem:
        "?sem ?chks"
      using 2 snds_no_upds *
      unfolding 3 ** by auto

    have "list_all is_Check_or_Assignment (unlabel (transaction_checks T'))"
      using T'_wf unfolding wellformed_transaction_def by blast
    hence "list_all is_Check_or_Assignment (unlabel ?chks)"
      by (metis (no_types) subst_sst_list_all(11) unlabel_subst duallsst_list_all(11))
    hence "∀a ∈ set (unlabel ?chks). ¬is_Receive a ∧ ¬is_Insert a ∧ ¬is_Delete a"
      unfolding list_all_iff by blast
    hence chks_no_upds:
        "iklsst ?chks ⋅set ℐ = {}"
        "dbupdsst (unlabel ?chks) ℐ ?DB = ?DB"
      by (metis iksst_snoc_no_receive_empty, metis dbupdsst_no_upd)

    have upds_sem:
        "?sem ?upds"
      using 2 snds_no_upds chks_no_upds *
      unfolding 3 ** by auto

    have "list_all is_Send (unlabel (transaction_send T'))"
      using T'_wf unfolding wellformed_transaction_def by fast
    hence "list_all is_Send (unlabel (transaction_send T' ⋅lsst θ))"
      by (metis (no_types, opaque_lifting) subst_sst_list_all(1) unlabel_subst)
    hence rcvs_is_rcvs: "list_all is_Receive (unlabel ?rcvs)"
      using duallsst_list_all(2) by blast

    have rcvs_sem: "strand_sem_stateful M D (unlabel rcvs) ℐ"
      when "list_all is_Receive (unlabel rcvs)"
      for M D and rcvs::"('fun, 'atom, 'sets, 'lbl) prot_strand"
      using rcvs_is_rcvs strand_sem_receive_prepend_stateful[of M D "[]" ℐ, OF _ that] by auto

    have B_sem: "?sem (?snds@?chks@?upds@rcvs)"
                "?sem (?snds_occs@?chks@?upds@rcvs)"
      when "list_all is_Receive (unlabel rcvs)" for rcvs
      using strand_sem_append_stateful[of _ _ _ _ ℐ]
            snds_sem snds_no_upds chks_sem chks_no_upds
            upds_sem rcvs_sem[OF that]
      by (force, force)

    show ?thesis
    proof (cases "transaction_fresh T' = []")
      case True
      show ?thesis using B_sem[OF rcvs_is_rcvs] unfolding ℬ_def 6(1)[OF True] by force
    next
      case False
      note F = this
      show ?thesis
      proof (cases "∃ts F'. transaction_send T' = ⟨⋆, send⟨ts⟩⟩#F'")
        case True
        obtain ts F' rcvs' where F':
            "transaction_send T' = ⟨⋆, send⟨ts⟩⟩#F'"
            "ℬ = (if flt xs = [] then ?snds else ?snds_occs)@?chks@?upds@rcvs'"
            "rcvs' = ⟨⋆, receive⟨occs (transaction_fresh T')@ts ⋅list θ⟩⟩#duallsst (F' ⋅lsst θ)"
          using 6(3)[OF F True] unfolding ℬ_def by blast

        have *: "list_all is_Receive (unlabel rcvs')"
          using rcvs_is_rcvs duallsst_Cons(1)[of ⋆ ts "F' ⋅lsst θ"]
                subst_lsst_cons[of "⟨⋆, send⟨ts⟩⟩" F' θ]
          unfolding F'(1,3) list_all_iff by auto

        show ?thesis using B_sem[OF *] unfolding F'(2) by fastforce
      next
        case False
        have *:
            "list_all is_Receive (unlabel (⟨⋆, receive⟨occs (transaction_fresh T') ⋅list θ⟩⟩#?rcvs))"
          using rcvs_is_rcvs by auto

        show ?thesis using B_sem[OF *] unfolding ℬ_def 6(2)[OF F False] by fastforce
      qed
    qed
  qed
  thus ?case
    using IH strand_sem_append_stateful[of "{}" "{}" "unlabel 𝒜" "unlabel ℬ" ℐ]
    unfolding welltyped_constraint_model_def constraint_model_def θ_def[symmetric] ℬ_def[symmetric]
    by simp
qed simp

theorem add_occurs_msgs_soundness:
  defines "wt_attack ≡ λℐ 𝒜 l n. welltyped_constraint_model ℐ (𝒜@[(l, send⟨[attack⟨n⟩]⟩)])"
  assumes P: "∀T ∈ set P. admissible_transaction T"
             "has_initial_value_producing_transaction P"
    and A: "𝒜 ∈ reachable_constraints P" "wt_attack ℐ 𝒜 l n"
  shows "∃ℬ ∈ reachable_constraints (map add_occurs_msgs P). ∃𝒥. wt_attack 𝒥 ℬ l n"
proof -
  have P': "∀T ∈ set (map add_occurs_msgs P). admissible_transaction' T"
           "∀T ∈ set (map add_occurs_msgs P). admissible_transaction_occurs_checks T"
           "∀T ∈ set P. admissible_transaction' T"
           "∀T ∈ set P. admissible_transaction_no_occurs_msgs T"
    using P admissible_transactionE' add_occurs_msgs_admissible_occurs_checks
    by (fastforce,fastforce,fastforce,fastforce)

  obtain 𝒜' 𝒥 where A':
      "𝒜' ∈ reachable_constraints P" "wt_attack 𝒥 𝒜' l n" "∀x∈fvlsst 𝒜'. ∃n. 𝒥 x = Fun (Val n) []"
    using add_occurs_msgs_soundness_aux1[OF P'(3) P(2) A[unfolded wt_attack_def]]
    unfolding wt_attack_def by blast

  have J: "welltyped_constraint_model 𝒥 𝒜'"
    using A'(2) welltyped_constraint_model_prefix
    unfolding wt_attack_def by blast

  obtain ℬ where B:
      "ℬ ∈ reachable_constraints (map add_occurs_msgs P)" "𝒜' = rm_occurs_msgs_constr ℬ"
    using add_occurs_msgs_soundness_aux2[OF P(1) A'(1)] by blast

  have J': "welltyped_constraint_model 𝒥 ℬ"
    using add_occurs_msgs_soundness_aux3[OF P(1) B(1) J[unfolded B(2)]]
          A'(3) rm_occurs_msgs_constr_reachable_constraints_fv_eq[OF P'(3,4) B(1)]
    unfolding wt_attack_def B(2) by blast

  obtain ts where ts: "receive⟨ts⟩ ∈ set (unlabel ℬ)" "attack⟨n⟩ ∈ set ts"
    using reachable_constraints_receive_attack_if_attack''[OF P'(3) A'(1,2)[unfolded wt_attack_def]]
          rm_occurs_msgs_constr_receive_attack_iff[of n ℬ]
    unfolding B(2)[symmetric] by auto

  have J'': "wt_attack 𝒥 ℬ l n"
    using welltyped_constraint_model_attack_if_receive_attack[OF J' ts]
    unfolding wt_attack_def by fast

  show ?thesis
    using B(1) J'' by blast
qed

end

end


subsection ‹Automatically Checking Protocol Security in a Typed Model›
context stateful_protocol_model
begin

definition abs_intruder_knowledge (‹αik›) where
  "αik S ℐ ≡ (iklsst S ⋅set ℐ) ⋅αset α0 (dblsst S ℐ)"

definition abs_value_constants (‹αvals›) where
  "αvals S ℐ ≡ {t ∈ subtermsset (trmslsst S) ⋅set ℐ. ∃n. t = Fun (Val n) []} ⋅αset α0 (dblsst S ℐ)"

definition abs_term_implications (‹αti›) where
  "αti 𝒜 T θ ℐ ≡ {(s,t) | s t x.
    s ≠ t ∧ x ∈ fv_transaction T ∧ x ∉ set (transaction_fresh T) ∧
    Fun (Abs s) [] = θ x ⋅ ℐ ⋅α α0 (dblsst 𝒜 ℐ) ∧
    Fun (Abs t) [] = θ x ⋅ ℐ ⋅α α0 (dblsst (𝒜@duallsst (transaction_strand T ⋅lsst θ)) ℐ)}"

lemma abs_intruder_knowledge_append:
  "αik (A@B) ℐ =
    (iklsst A ⋅set ℐ) ⋅αset α0 (dblsst (A@B) ℐ) ∪
    (iklsst B ⋅set ℐ) ⋅αset α0 (dblsst (A@B) ℐ)"
by (metis unlabel_append abs_set_union image_Un iksst_append abs_intruder_knowledge_def)

lemma abs_value_constants_append:
  fixes A B::"('a,'b,'c,'d) prot_strand"
  shows "αvals (A@B) ℐ =
      {t ∈ subtermsset (trmslsst A) ⋅set ℐ. ∃n. t =