diff --git a/thys/Adaptive_State_Counting/ASC/ASC_LB.thy b/thys/Adaptive_State_Counting/ASC/ASC_LB.thy
--- a/thys/Adaptive_State_Counting/ASC/ASC_LB.thy
+++ b/thys/Adaptive_State_Counting/ASC/ASC_LB.thy
@@ -1,2892 +1,2892 @@
 theory ASC_LB
 imports "../ATC/ATC" "../FSM/FSM_Product"
 begin
 
 section \<open> The lower bound function \<close>
 
 text \<open>
 This theory defines the lower bound function @{verbatim LB} and its properties.
 
 Function @{verbatim LB} calculates a lower bound on the number of states of some FSM in order for
 some sequence to not contain certain repetitions.
 \<close>
 
 subsection \<open> Permutation function Perm \<close>
 
 text \<open>
 Function @{verbatim Perm} calculates all possible reactions of an FSM to a set of inputs sequences
 such that every set in the calculated set of reactions contains exactly one reaction for each input
 sequence.
 \<close>
 
 fun Perm :: "'in list set \<Rightarrow> ('in, 'out, 'state) FSM \<Rightarrow> ('in \<times> 'out) list set set" where
   "Perm V M = {image f V | f . \<forall> v \<in> V . f v \<in> language_state_for_input M (initial M) v }"
 
 lemma perm_empty :
   assumes "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
 shows "[] \<in> V''"
 proof -
   have init_seq : "[] \<in> V" using det_state_cover_empty assms by simp
   obtain f where f_def : "V'' = image f V
                                 \<and> (\<forall> v \<in> V . f v \<in> language_state_for_input M1 (initial M1) v)"
     using assms by auto
   then have "f [] = []"
     using init_seq by (metis language_state_for_input_empty singleton_iff)
   then show ?thesis
     using init_seq f_def by (metis image_eqI)
 qed
 
 lemma perm_elem_finite :
   assumes "is_det_state_cover M2 V"
   and     "well_formed M2"
   and     "V'' \<in> Perm V M1"
   shows "finite V''"
 proof -
   obtain f where "is_det_state_cover_ass M2 f \<and> V = f ` d_reachable M2 (initial M2)"
     using assms by auto
   moreover have "finite (d_reachable M2 (initial M2))"
   proof -
     have "finite (nodes M2)"
       using assms by auto
     moreover have "nodes M2 = reachable M2 (initial M2)"
       by auto
     ultimately have "finite (reachable M2 (initial M2))"
       by simp
     moreover have "d_reachable M2 (initial M2) \<subseteq> reachable M2 (initial M2)"
       by auto
     ultimately show ?thesis
       using infinite_super by blast
   qed
   ultimately have "finite V"
     by auto
   moreover obtain f'' where "V'' = image f'' V
                               \<and> (\<forall> v \<in> V . f'' v \<in> language_state_for_input M1 (initial M1) v)"
     using assms(3) by auto
   ultimately show ?thesis
     by simp
 qed
 
 lemma perm_inputs :
   assumes "V'' \<in> Perm V M"
   and     "vs \<in> V''"
 shows "map fst vs \<in> V"
 proof -
   obtain f where f_def : "V'' = image f V
                           \<and> (\<forall> v \<in> V . f v \<in> language_state_for_input M (initial M) v)"
     using assms by auto
   then obtain v where v_def : "v \<in> V \<and> f v = vs"
     using assms by auto
   then have "vs \<in> language_state_for_input M (initial M) v"
     using f_def by auto
   then show ?thesis
     using v_def unfolding language_state_for_input.simps by auto
 qed
 
 lemma perm_inputs_diff :
   assumes "V'' \<in> Perm V M"
   and     "vs1 \<in> V''"
   and     "vs2 \<in> V''"
   and     "vs1 \<noteq> vs2"
 shows "map fst vs1 \<noteq> map fst vs2"
 proof -
   obtain f where f_def : "V'' = image f V
                           \<and> (\<forall> v \<in> V . f v \<in> language_state_for_input M (initial M) v)"
     using assms by auto
   then obtain v1 v2 where v_def : "v1 \<in> V \<and> f v1 = vs1 \<and> v2 \<in> V \<and> f v2 = vs2"
     using assms by auto
   then have "vs1 \<in> language_state_for_input M (initial M) v1"
             "vs2 \<in> language_state_for_input M (initial M) v2"
     using f_def by auto
   moreover have "v1 \<noteq> v2"
     using v_def assms(4) by blast
   ultimately show ?thesis
     by auto
 qed
 
 lemma perm_language :
   assumes "V'' \<in> Perm V M"
   and     "vs \<in> V''"
 shows "vs \<in> L M"
 proof -
   obtain f where f_def : "image f V = V''
                           \<and> (\<forall> v \<in> V . f v \<in> language_state_for_input M (initial M) v)"
     using assms(1) by auto
   then have "\<exists> v . f v = vs \<and> f v \<in> language_state_for_input M (initial M) v"
     using assms(2) by blast
   then show ?thesis
     by auto
 qed
 
 
 
 
 subsection \<open> Helper predicates \<close>
 
 text \<open>
 The following predicates are used to combine often repeated assumption.
 \<close>
 
 abbreviation "asc_fault_domain M2 M1 m \<equiv> (inputs M2 = inputs M1 \<and> card (nodes M1) \<le> m )"
 
 lemma asc_fault_domain_props[elim!] :
   assumes "asc_fault_domain M2 M1 m"
   shows "inputs M2 = inputs M1"
         "card (nodes M1) \<le> m"using assms by auto
 
 abbreviation
   "test_tools M2 M1 FAIL PM V \<Omega> \<equiv> (
       productF M2 M1 FAIL PM
     \<and> is_det_state_cover M2 V
     \<and> applicable_set M2 \<Omega>
    )"
 
 lemma test_tools_props[elim] :
   assumes "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "asc_fault_domain M2 M1 m"
   shows "productF M2 M1 FAIL PM"
         "is_det_state_cover M2 V"
         "applicable_set M2 \<Omega>"
         "applicable_set M1 \<Omega>"
 proof -
   show "productF M2 M1 FAIL PM" using assms(1) by blast
   show "is_det_state_cover M2 V" using assms(1) by blast
   show "applicable_set M2 \<Omega>" using assms(1) by blast
   then show "applicable_set M1 \<Omega>"
     unfolding applicable_set.simps applicable.simps
     using asc_fault_domain_props(1)[OF assms(2)] by simp
 qed
 
 
 
 
 lemma perm_nonempty :
   assumes "is_det_state_cover M2 V"
   and "OFSM M1"
   and "OFSM M2"
   and "inputs M1 = inputs M2"
 shows "Perm V M1 \<noteq> {}"
 proof -
   have "finite (nodes M2)"
     using assms(3) by auto
   moreover have "d_reachable M2 (initial M2) \<subseteq> nodes M2"
     by auto
   ultimately have "finite V"
     using det_state_cover_card[OF assms(1)]
     by (metis assms(1) finite_imageI infinite_super is_det_state_cover.elims(2))
 
   have "[] \<in> V"
     using assms(1) det_state_cover_empty by blast
 
 
   have "\<And> VS . VS \<subseteq> V \<and> VS \<noteq> {} \<Longrightarrow> Perm VS M1 \<noteq> {}"
   proof -
     fix VS assume "VS \<subseteq> V \<and> VS \<noteq> {}"
     then have "finite VS" using \<open>finite V\<close>
       using infinite_subset by auto
     then show "Perm VS M1 \<noteq> {}"
       using \<open>VS \<subseteq> V \<and> VS \<noteq> {}\<close> \<open>finite VS\<close>
     proof (induction VS)
       case empty
       then show ?case by auto
     next
       case (insert vs F)
       then have "vs \<in> V" by blast
 
       obtain q2 where "d_reaches M2 (initial M2) vs q2"
         using det_state_cover_d_reachable[OF assms(1) \<open>vs \<in> V\<close>] by blast
       then obtain vs' vsP where io_path : "length vs = length vs'
                                             \<and> length vs = length vsP
                                             \<and> (path M2 ((vs || vs') || vsP) (initial M2))
                                             \<and> target ((vs || vs') || vsP) (initial M2) = q2"
         by auto
 
       have "well_formed M2"
         using assms by auto
 
       have "map fst (map fst ((vs || vs') || vsP)) = vs"
       proof -
         have "length (vs || vs') = length vsP"
           using io_path by simp
         then show ?thesis
           using io_path by auto
       qed
       moreover have "set (map fst (map fst ((vs || vs') || vsP))) \<subseteq> inputs M2"
         using path_input_containment[OF \<open>well_formed M2\<close>, of "(vs || vs') || vsP" "initial M2"]
               io_path
         by linarith
       ultimately have "set vs \<subseteq> inputs M2"
         by presburger
 
       then have "set vs \<subseteq> inputs M1"
         using assms by auto
 
       then have "L\<^sub>i\<^sub>n M1 {vs} \<noteq> {}"
         using assms(2) language_state_for_inputs_nonempty
         by (metis FSM.nodes.initial)
       then have "language_state_for_input M1 (initial M1) vs \<noteq> {}"
         by auto
       then obtain vs' where "vs' \<in> language_state_for_input M1 (initial M1) vs"
         by blast
 
       show ?case
       proof (cases "F = {}")
         case True
         moreover obtain f where "f vs = vs'"
-          by moura
+          by force
         ultimately have "image f (insert vs F) \<in> Perm (insert vs F) M1"
           using Perm.simps \<open>vs' \<in> language_state_for_input M1 (initial M1) vs\<close> by blast
         then show ?thesis by blast
       next
         case False
         then obtain F'' where "F'' \<in> Perm F M1"
           using insert.IH insert.hyps(1) insert.prems(1) by blast
         then obtain f where "F'' = image f F"
                             "(\<forall> v \<in> F . f v \<in> language_state_for_input M1 (initial M1) v)"
           by auto
         let ?f = "f(vs := vs')"
         have "\<forall> v \<in> (insert vs F) . ?f v \<in> language_state_for_input M1 (initial M1) v"
         proof
           fix v assume "v \<in> insert vs F"
           then show "?f v \<in> language_state_for_input M1 (initial M1) v"
           proof (cases "v = vs")
             case True
             then show ?thesis
               using \<open>vs' \<in> language_state_for_input M1 (initial M1) vs\<close> by auto
           next
             case False
             then have "v \<in> F"
               using \<open>v \<in> insert vs F\<close> by blast
             then show ?thesis
               using False \<open>\<forall>v\<in>F. f v \<in> language_state_for_input M1 (initial M1) v\<close> by auto
           qed
         qed
         then have "image ?f (insert vs F) \<in> Perm (insert vs F) M1"
           using Perm.simps by blast
         then show ?thesis
           by blast
       qed
     qed
   qed
 
   then show ?thesis
     using \<open>[] \<in> V\<close> by blast
 qed
 
 
 
 lemma perm_elem :
   assumes "is_det_state_cover M2 V"
   and "OFSM M1"
   and "OFSM M2"
   and "inputs M1 = inputs M2"
   and "vs \<in> V"
   and "vs' \<in> language_state_for_input M1 (initial M1) vs"
 obtains V''
 where "V'' \<in> Perm V M1" "vs' \<in> V''"
 proof -
   obtain V'' where "V'' \<in> Perm V M1"
     using perm_nonempty[OF assms(1-4)] by blast
   then obtain f where "V'' = image f V"
                       "(\<forall> v \<in> V . f v \<in> language_state_for_input M1 (initial M1) v)"
     by auto
 
   let ?f = "f(vs := vs')"
 
   have "\<forall> v \<in> V . (?f v) \<in> (language_state_for_input M1 (initial M1) v)"
     using \<open>\<forall>v\<in>V. (f v) \<in> (language_state_for_input M1 (initial M1) v)\<close> assms(6) by fastforce
 
   then have "(image ?f V) \<in> Perm V M1"
     unfolding Perm.simps by blast
   moreover have "vs' \<in> image ?f V"
     by (metis assms(5) fun_upd_same imageI)
   ultimately show ?thesis
     using that by blast
 qed
 
 
 
 subsection \<open> Function R \<close>
 
 text \<open>
 Function @{verbatim R} calculates the set of suffixes of a sequence that reach a given state if
 applied after a given other sequence.
 \<close>
 
 
 fun R :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in \<times> 'out) list
           \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> ('in \<times> 'out) list set"
   where
   "R M s vs xs = { vs@xs' | xs' . xs' \<noteq> []
                                 \<and> prefix xs' xs
                                 \<and> s \<in> io_targets M (initial M) (vs@xs') }"
 
 lemma finite_R : "finite (R M s vs xs)"
 proof -
   have "R M s vs xs \<subseteq> { vs @ xs' | xs' .prefix xs' xs }"
     by auto
   then have "R M s vs xs \<subseteq> image (\<lambda> xs' . vs @ xs') {xs' . prefix xs' xs}"
     by auto
   moreover have "{xs' . prefix xs' xs} = {take n xs | n . n \<le> length xs}"
   proof
     show "{xs'. prefix xs' xs} \<subseteq> {take n xs |n. n \<le> length xs}"
     proof
       fix xs' assume "xs' \<in> {xs'. prefix xs' xs}"
       then obtain zs' where "xs' @ zs' = xs"
         by (metis (full_types) mem_Collect_eq prefixE)
       then obtain i where "xs' = take i xs \<and> i \<le> length xs"
         by (metis (full_types) append_eq_conv_conj le_cases take_all)
       then show "xs' \<in> {take n xs |n. n \<le> length xs}"
         by auto
     qed
     show "{take n xs |n. n \<le> length xs} \<subseteq> {xs'. prefix xs' xs}"
       using take_is_prefix by force
   qed
   moreover have "finite {take n xs | n . n \<le> length xs}"
     by auto
   ultimately show ?thesis
     by auto
 qed
 
 
 
 lemma card_union_of_singletons :
   assumes "\<forall> S \<in> SS . (\<exists> t . S = {t})"
 shows "card (\<Union> SS) = card SS"
 proof -
   let ?f = "\<lambda> x . {x}"
   have "bij_betw ?f (\<Union> SS) SS"
     unfolding bij_betw_def inj_on_def using assms by fastforce
   then show ?thesis
     using bij_betw_same_card by blast
 qed
 
 lemma card_union_of_distinct :
   assumes "\<forall> S1 \<in> SS . \<forall> S2 \<in> SS . S1 = S2 \<or> f S1 \<inter> f S2 = {}"
   and     "finite SS"
   and     "\<forall> S \<in> SS . f S \<noteq> {}"
 shows "card (image f SS) = card SS"
 proof -
   from assms(2) have "\<forall> S1 \<in> SS . \<forall> S2 \<in> SS . S1 = S2 \<or> f S1 \<inter> f S2 = {}
                       \<Longrightarrow> \<forall> S \<in> SS . f S \<noteq> {} \<Longrightarrow> ?thesis"
   proof (induction SS)
     case empty
     then show ?case by auto
   next
     case (insert x F)
     then have "\<not> (\<exists> y \<in> F . f y = f x)"
       by auto
     then have "f x \<notin> image f F"
       by auto
     then have "card (image f (insert x F)) = Suc (card (image f F))"
       using insert by auto
     moreover have "card (f ` F) = card F"
       using insert by auto
     moreover have "card (insert x F) = Suc (card F)"
       using insert by auto
     ultimately show ?case
       by simp
   qed
   then show ?thesis
     using assms by simp
 qed
 
 lemma R_count :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "s \<in> nodes M2"
   and "productF M2 M1 FAIL PM"
   and "io_targets PM (initial PM) vs = {(q2,q1)}"
   and "path PM (xs || tr) (q2,q1)"
   and "length xs = length tr"
   and "distinct (states (xs || tr) (q2,q1))"
 shows "card (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))) = card (R M2 s vs xs)"
   \<comment> \<open>each sequence in the set calculated by R reaches a different state in M1\<close>
 proof -
 
   \<comment> \<open>Proof sketch:
        - states of PM reached by the sequences calculated by R can differ only in their second value
        - the sequences in the set calculated by R reach different states in PM due to distinctness\<close>
 
   have obs_PM : "observable PM" using observable_productF assms(2) assms(3) assms(7) by blast
 
   have state_component_2 : "\<forall> io \<in> (R M2 s vs xs) . io_targets M2 (initial M2) io = {s}"
   proof
     fix io assume "io \<in> R M2 s vs xs"
     then have "s \<in> io_targets M2 (initial M2) io"
       by auto
     moreover have "io \<in> language_state M2 (initial M2)"
       using calculation by auto
     ultimately show "io_targets M2 (initial M2) io = {s}"
       using assms(3) io_targets_observable_singleton_ex by (metis singletonD)
   qed
 
   moreover have "\<forall> io \<in> R M2 s vs xs . io_targets PM (initial PM) io
                     = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
   proof
     fix io assume io_assm : "io \<in> R M2 s vs xs"
     then have io_prefix : "prefix io (vs @ xs)"
       by auto
     then have io_lang_subs : "io \<in> L M1 \<and> io \<in> L M2"
       using assms(1) unfolding prefix_def by (metis IntE language_state language_state_split)
     then have io_lang_inter : "io \<in> L M1 \<inter> L M2"
       by simp
     then have io_lang_pm : "io \<in> L PM"
       using productF_language assms by blast
     moreover obtain p2 p1 where "(p2,p1) \<in> io_targets PM (initial PM) io"
       by (metis assms(2) assms(3) assms(7) calculation insert_absorb insert_ident insert_not_empty
           io_targets_observable_singleton_ob observable_productF singleton_insert_inj_eq subrelI)
     ultimately have targets_pm : "io_targets PM (initial PM) io = {(p2,p1)}"
       using assms io_targets_observable_singleton_ex singletonD by (metis observable_productF)
     then obtain trP where trP_def : "target (io || trP) (initial PM) = (p2,p1)
                                       \<and> path PM (io || trP) (initial PM)
                                       \<and> length io = length trP"
       proof -
         assume a1: "\<And>trP. target (io || trP) (initial PM) = (p2, p1)
                             \<and> path PM (io || trP) (initial PM)
                             \<and> length io = length trP \<Longrightarrow> thesis"
         have "\<exists>ps. target (io || ps) (initial PM) = (p2, p1)
                     \<and> path PM (io || ps) (initial PM) \<and> length io = length ps"
           using \<open>(p2, p1) \<in> io_targets PM (initial PM) io\<close> by auto
         then show ?thesis
           using a1 by blast
       qed
       then have trP_unique : "{ tr . path PM (io || tr) (initial PM) \<and> length io = length tr }
                               = { trP }"
         using observable_productF observable_path_unique_ex[of PM io "initial PM"]
               io_lang_pm assms(2) assms(3) assms(7)
       proof -
         obtain pps :: "('d \<times> 'c) list" where
           f1: "{ps. path PM (io || ps) (initial PM) \<and> length io = length ps} = {pps}
                 \<or> \<not> observable PM"
           by (metis (no_types) \<open>\<And>thesis. \<lbrakk>observable PM; io \<in> L PM; \<And>tr.
                                           {t. path PM (io || t) (initial PM)
                                           \<and> length io = length t} = {tr} \<Longrightarrow> thesis\<rbrakk> \<Longrightarrow> thesis\<close>
               io_lang_pm)
         have f2: "observable PM"
           by (meson \<open>observable M1\<close> \<open>observable M2\<close> \<open>productF M2 M1 FAIL PM\<close> observable_productF)
         then have "trP \<in> {pps}"
           using f1 trP_def by blast
         then show ?thesis
           using f2 f1 by force
       qed
 
 
     obtain trIO2 where trIO2_def : "{tr . path M2 (io||tr) (initial M2) \<and> length io = length tr}
                                     = { trIO2 }"
       using observable_path_unique_ex[of M2 io "initial M2"] io_lang_subs assms(3) by blast
     obtain trIO1 where trIO1_def : "{tr . path M1 (io||tr) (initial M1) \<and> length io = length tr}
                                     = { trIO1 }"
       using observable_path_unique_ex[of M1 io "initial M1"] io_lang_subs assms(2) by blast
 
     have "path PM (io || trIO2 || trIO1) (initial M2, initial M1)
           \<and> length io = length trIO2
           \<and> length trIO2 = length trIO1"
     proof -
       have f1: "path M2 (io || trIO2) (initial M2) \<and> length io = length trIO2"
         using trIO2_def by auto
       have f2: "path M1 (io || trIO1) (initial M1) \<and> length io = length trIO1"
         using trIO1_def by auto
       then have "length trIO2 = length trIO1"
         using f1 by presburger
       then show ?thesis
         using f2 f1 assms(4) assms(5) assms(7) by blast
     qed
     then have trP_split : "path PM (io || trIO2 || trIO1) (initial PM)
                             \<and> length io = length trIO2
                             \<and> length trIO2 = length trIO1"
       using assms(7) by auto
     then have trP_zip : "trIO2 || trIO1 = trP"
       using trP_def trP_unique using length_zip by fastforce
 
     have "target (io || trIO2) (initial M2) = p2
           \<and> path M2 (io || trIO2) (initial M2)
           \<and> length io = length trIO2"
       using trP_zip trP_split assms(7) trP_def trIO2_def by auto
     then have "p2 \<in> io_targets M2 (initial M2) io"
       by auto
     then have targets_2 : "io_targets M2 (initial M2) io = {p2}"
       by (metis state_component_2 io_assm singletonD)
 
     have "target (io || trIO1) (initial M1) = p1
             \<and> path M1 (io || trIO1) (initial M1)
             \<and> length io = length trIO1"
       using trP_zip trP_split assms(7) trP_def trIO1_def by auto
     then have "p1 \<in> io_targets M1 (initial M1) io"
       by auto
     then have targets_1 : "io_targets M1 (initial M1) io = {p1}"
       by (metis io_lang_subs assms(2) io_targets_observable_singleton_ex singletonD)
 
     have "io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io = {(p2,p1)}"
       using targets_2 targets_1 by simp
     then show "io_targets PM (initial PM) io
                 = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
       using targets_pm by simp
   qed
 
   ultimately have state_components : "\<forall> io \<in> R M2 s vs xs . io_targets PM (initial PM) io
                                       = {s} \<times> io_targets M1 (initial M1) io"
     by auto
 
   then have "\<Union> (image (io_targets PM (initial PM)) (R M2 s vs xs))
               = \<Union> (image (\<lambda> io . {s} \<times> io_targets M1 (initial M1) io) (R M2 s vs xs))"
     by auto
   then have "\<Union> (image (io_targets PM (initial PM)) (R M2 s vs xs))
               = {s} \<times> \<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))"
     by auto
   then have "card (\<Union> (image (io_targets PM (initial PM)) (R M2 s vs xs)))
               = card (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs)))"
     by (metis (no_types) card_cartesian_product_singleton)
 
   moreover have "card (\<Union> (image (io_targets PM (initial PM)) (R M2 s vs xs)))
                   = card (R M2 s vs xs)"
   proof (rule ccontr)
     assume assm : "card (\<Union> (io_targets PM (initial PM) ` R M2 s vs xs) ) \<noteq> card (R M2 s vs xs)"
 
     have "\<forall> io \<in> R M2 s vs xs . io \<in> L PM"
     proof
       fix io assume io_assm : "io \<in> R M2 s vs xs"
       then have "prefix io (vs @ xs)"
         by auto
       then have "io \<in> L M1 \<and> io \<in> L M2"
         using assms(1) unfolding prefix_def by (metis IntE language_state language_state_split)
       then show "io \<in> L PM"
         using productF_language assms by blast
     qed
     then have singletons : "\<forall> io \<in> R M2 s vs xs . (\<exists> t . io_targets PM (initial PM) io = {t})"
       using io_targets_observable_singleton_ex observable_productF assms by metis
     then have card_targets : "card (\<Union>(io_targets PM (initial PM) ` R M2 s vs xs))
                               = card (image (io_targets PM (initial PM)) (R M2 s vs xs))"
       using finite_R card_union_of_singletons
             [of "image (io_targets PM (initial PM)) (R M2 s vs xs)"]
       by simp
 
     moreover have "card (image (io_targets PM (initial PM)) (R M2 s vs xs)) \<le> card (R M2 s vs xs)"
       using finite_R by (metis card_image_le)
     ultimately have card_le : "card (\<Union>(io_targets PM (initial PM) ` R M2 s vs xs))
                                 < card (R M2 s vs xs)"
       using assm by linarith
 
     have "\<exists> io1 \<in> (R M2 s vs xs) . \<exists> io2 \<in> (R M2 s vs xs) . io1 \<noteq> io2
             \<and> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2 \<noteq> {}"
     proof (rule ccontr)
       assume "\<not> (\<exists>io1\<in>R M2 s vs xs. \<exists>io2\<in>R M2 s vs xs. io1 \<noteq> io2
                   \<and> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2 \<noteq> {})"
       then have "\<forall>io1\<in>R M2 s vs xs. \<forall>io2\<in>R M2 s vs xs. io1 = io2
                   \<or> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2 = {}"
         by blast
       moreover have "\<forall>io\<in>R M2 s vs xs. io_targets PM (initial PM) io \<noteq> {}"
         by (metis insert_not_empty singletons)
       ultimately have "card (image (io_targets PM (initial PM)) (R M2 s vs xs))
                         = card (R M2 s vs xs)"
         using finite_R[of M2 s vs xs] card_union_of_distinct
               [of "R M2 s vs xs" "(io_targets PM (initial PM))"]
         by blast
       then show "False"
         using card_le card_targets by linarith
     qed
 
     then have "\<exists> io1 io2 . io1 \<in> (R M2 s vs xs)
                             \<and> io2 \<in> (R M2 s vs xs)
                             \<and> io1 \<noteq> io2
                             \<and> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2 \<noteq> {}"
       by blast
     moreover have "\<forall> io1 io2 . (io1 \<in> (R M2 s vs xs) \<and> io2 \<in> (R M2 s vs xs) \<and> io1 \<noteq> io2)
                                 \<longrightarrow> length io1 \<noteq> length io2"
     proof (rule ccontr)
       assume " \<not> (\<forall>io1 io2. io1 \<in> R M2 s vs xs \<and> io2 \<in> R M2 s vs xs \<and> io1 \<noteq> io2
                   \<longrightarrow> length io1 \<noteq> length io2)"
       then obtain io1 io2 where io_def : "io1 \<in> R M2 s vs xs
                                           \<and> io2 \<in> R M2 s vs xs
                                           \<and> io1 \<noteq> io2
                                           \<and> length io1 = length io2"
         by auto
       then have "prefix io1 (vs @ xs) \<and> prefix io2 (vs @ xs)"
         by auto
       then have "io1 = take (length io1) (vs @ xs) \<and> io2 = take (length io2) (vs @ xs)"
         by (metis append_eq_conv_conj prefixE)
       then show "False"
         using io_def by auto
     qed
 
     ultimately obtain io1 io2 where rep_ios_def :
       "io1 \<in> (R M2 s vs xs)
         \<and> io2 \<in> (R M2 s vs xs)
         \<and> length io1 < length io2
         \<and> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2 \<noteq> {}"
       by (metis inf_sup_aci(1) linorder_neqE_nat)
 
     obtain rep where "(s,rep) \<in> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2"
     proof -
       assume a1: "\<And>rep. (s, rep) \<in> io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2
                         \<Longrightarrow> thesis"
       have "\<exists>f. Sigma {s} f \<inter> (io_targets PM (initial PM) io1 \<inter> io_targets PM (initial PM) io2)
                  \<noteq> {}"
         by (metis (no_types) inf.left_idem rep_ios_def state_components)
       then show ?thesis
         using a1 by blast
     qed
     then have rep_state : "io_targets PM (initial PM) io1 = {(s,rep)}
                             \<and> io_targets PM (initial PM) io2 = {(s,rep)}"
       by (metis Int_iff rep_ios_def singletonD singletons)
 
     obtain io1X io2X where rep_ios_split : "io1 = vs @ io1X
                                             \<and> prefix io1X xs
                                             \<and> io2 = vs @ io2X
                                             \<and> prefix io2X xs"
       using rep_ios_def by auto
     then have "length io1 > length vs"
       using rep_ios_def by auto
 
 
     \<comment> \<open>get a path from (initial PM) to (q2,q1)\<close>
 
     have "vs@xs \<in> L PM"
       by (metis (no_types) assms(1) assms(4) assms(5) assms(7) inf_commute productF_language)
     then have "vs \<in> L PM"
       by (meson language_state_prefix)
     then obtain trV where trV_def : "{tr . path PM (vs || tr) (initial PM) \<and> length vs = length tr}
                                       = { trV }"
       using observable_path_unique_ex[of PM vs "initial PM"]
             assms(2) assms(3) assms(7) observable_productF
       by blast
     let ?qv = "target (vs || trV) (initial PM)"
 
     have "?qv \<in> io_targets PM (initial PM) vs"
       using trV_def by auto
     then have qv_simp[simp] : "?qv = (q2,q1)"
       using singletons assms by blast
     then have "?qv \<in> nodes PM"
       using trV_def assms by blast
 
 
     \<comment> \<open>get a path using io1X from the state reached by vs in PM\<close>
 
     obtain tr1X_all where tr1X_all_def : "path PM (vs @ io1X || tr1X_all) (initial PM)
                                           \<and> length (vs @ io1X) = length tr1X_all"
       using rep_ios_def rep_ios_split by auto
     let ?tr1X = "drop (length vs) tr1X_all"
     have "take (length vs) tr1X_all = trV"
     proof -
       have "path PM (vs || take (length vs) tr1X_all) (initial PM)
             \<and> length vs = length (take (length vs) tr1X_all)"
         using tr1X_all_def trV_def
         by (metis (no_types, lifting) FSM.path_append_elim append_eq_conv_conj
             length_take zip_append1)
       then show "take (length vs) tr1X_all = trV"
         using trV_def by blast
     qed
     then have tr1X_def : "path PM (io1X || ?tr1X) ?qv \<and> length io1X = length ?tr1X"
     proof -
       have "length tr1X_all = length vs + length io1X"
         using tr1X_all_def by auto
       then have "length io1X = length tr1X_all - length vs"
         by presburger
       then show ?thesis
         by (metis (no_types) FSM.path_append_elim \<open>take (length vs) tr1X_all = trV\<close>
             length_drop tr1X_all_def zip_append1)
     qed
     then have io1X_lang : "io1X \<in> language_state PM ?qv"
       by auto
     then obtain tr1X' where tr1X'_def : "{tr . path PM (io1X || tr) ?qv \<and> length io1X = length tr}
                                           = { tr1X' }"
       using observable_path_unique_ex[of PM io1X ?qv]
             assms(2) assms(3) assms(7) observable_productF
       by blast
     moreover have "?tr1X \<in> { tr . path PM (io1X || tr) ?qv \<and> length io1X = length tr }"
       using tr1X_def by auto
     ultimately have tr1x_unique : "tr1X' = ?tr1X"
       by simp
 
     \<comment> \<open>get a path using io2X from the state reached by vs in PM\<close>
 
     obtain tr2X_all where tr2X_all_def : "path PM (vs @ io2X || tr2X_all) (initial PM)
                                           \<and> length (vs @ io2X) = length tr2X_all"
       using rep_ios_def rep_ios_split by auto
     let ?tr2X = "drop (length vs) tr2X_all"
     have "take (length vs) tr2X_all = trV"
     proof -
       have "path PM (vs || take (length vs) tr2X_all) (initial PM)
             \<and> length vs = length (take (length vs) tr2X_all)"
         using tr2X_all_def trV_def
         by (metis (no_types, lifting) FSM.path_append_elim append_eq_conv_conj
             length_take zip_append1)
       then show "take (length vs) tr2X_all = trV"
         using trV_def by blast
     qed
     then have tr2X_def : "path PM (io2X || ?tr2X) ?qv \<and> length io2X = length ?tr2X"
     proof -
       have "length tr2X_all = length vs + length io2X"
         using tr2X_all_def by auto
       then have "length io2X = length tr2X_all - length vs"
         by presburger
       then show ?thesis
         by (metis (no_types) FSM.path_append_elim \<open>take (length vs) tr2X_all = trV\<close>
             length_drop tr2X_all_def zip_append1)
     qed
     then have io2X_lang : "io2X \<in> language_state PM ?qv" by auto
     then obtain tr2X' where tr2X'_def : "{tr . path PM (io2X || tr) ?qv \<and> length io2X = length tr}
                                           = { tr2X' }"
       using observable_path_unique_ex[of PM io2X ?qv] assms(2) assms(3) assms(7) observable_productF
       by blast
     moreover have "?tr2X \<in> { tr . path PM (io2X || tr) ?qv \<and> length io2X = length tr }"
       using tr2X_def by auto
     ultimately have tr2x_unique : "tr2X' = ?tr2X"
       by simp
 
     \<comment> \<open>both paths reach the same state\<close>
 
     have "io_targets PM (initial PM) (vs @ io1X) = {(s,rep)}"
       using rep_state rep_ios_split by auto
     moreover have "io_targets PM (initial PM) vs = {?qv}"
       using assms(8) by auto
     ultimately have rep_via_1 : "io_targets PM ?qv io1X = {(s,rep)}"
       by (meson obs_PM observable_io_targets_split)
     then have rep_tgt_1 : "target (io1X || tr1X') ?qv = (s,rep)"
       using obs_PM observable_io_target_unique_target[of PM ?qv io1X "(s,rep)"] tr1X'_def by blast
     have length_1 : "length (io1X || tr1X') > 0"
       using \<open>length vs < length io1\<close> rep_ios_split tr1X_def tr1x_unique by auto
 
     have tr1X_alt_def : "tr1X' = take (length io1X) tr"
       by (metis (no_types) assms(10) assms(9) obs_PM observable_path_prefix qv_simp
           rep_ios_split tr1X_def tr1x_unique)
     moreover have "io1X = take (length io1X) xs"
       using rep_ios_split by (metis append_eq_conv_conj prefixE)
     ultimately have "(io1X || tr1X') = take (length io1X) (xs || tr)"
       by (metis take_zip)
     moreover have "length (xs || tr) \<ge> length (io1X || tr1X')"
       by (metis (no_types) \<open>io1X = take (length io1X) xs\<close> assms(10) length_take length_zip
           nat_le_linear take_all tr1X_def tr1x_unique)
     ultimately have rep_idx_1 : "(states (xs || tr) ?qv) ! ((length io1X) - 1) = (s,rep)"
       by (metis (no_types, lifting) One_nat_def Suc_less_eq Suc_pred rep_tgt_1 length_1
           less_Suc_eq_le map_snd_zip scan_length scan_nth states_alt_def tr1X_def tr1x_unique)
 
 
     have "io_targets PM (initial PM) (vs @ io2X) = {(s,rep)}"
       using rep_state rep_ios_split by auto
     moreover have "io_targets PM (initial PM) vs = {?qv}"
       using assms(8) by auto
     ultimately have rep_via_2 : "io_targets PM ?qv io2X = {(s,rep)}"
       by (meson obs_PM observable_io_targets_split)
     then have rep_tgt_2 : "target (io2X || tr2X') ?qv = (s,rep)"
       using obs_PM observable_io_target_unique_target[of PM ?qv io2X "(s,rep)"] tr2X'_def by blast
     moreover have length_2 : "length (io2X || tr2X') > 0"
       by (metis \<open>length vs < length io1\<close> append.right_neutral length_0_conv length_zip less_asym min.idem neq0_conv rep_ios_def rep_ios_split tr2X_def tr2x_unique)
 
     have tr2X_alt_def : "tr2X' = take (length io2X) tr"
       by (metis (no_types) assms(10) assms(9) obs_PM observable_path_prefix qv_simp rep_ios_split tr2X_def tr2x_unique)
     moreover have "io2X = take (length io2X) xs"
       using rep_ios_split by (metis append_eq_conv_conj prefixE)
     ultimately have "(io2X || tr2X') = take (length io2X) (xs || tr)"
       by (metis take_zip)
     moreover have "length (xs || tr) \<ge> length (io2X || tr2X')"
       using calculation by auto
     ultimately have rep_idx_2 : "(states (xs || tr) ?qv) ! ((length io2X) - 1) = (s,rep)"
       by (metis (no_types, lifting) One_nat_def Suc_less_eq Suc_pred rep_tgt_2 length_2
           less_Suc_eq_le map_snd_zip scan_length scan_nth states_alt_def tr2X_def tr2x_unique)
 
 
     \<comment> \<open>thus the distinctness assumption is violated\<close>
 
     have "length io1X \<noteq> length io2X"
       by (metis \<open>io1X = take (length io1X) xs\<close> \<open>io2X = take (length io2X) xs\<close> less_irrefl
           rep_ios_def rep_ios_split)
     moreover have "(states (xs || tr) ?qv) ! ((length io1X) - 1)
                     = (states (xs || tr) ?qv) ! ((length io2X) - 1)"
       using rep_idx_1 rep_idx_2 by simp
     ultimately have "\<not> (distinct (states (xs || tr) ?qv))"
       by (metis Suc_less_eq \<open>io1X = take (length io1X) xs\<close>
           \<open>io1X || tr1X' = take (length io1X) (xs || tr)\<close> \<open>io2X = take (length io2X) xs\<close>
           \<open>io2X || tr2X' = take (length io2X) (xs || tr)\<close>
           \<open>length (io1X || tr1X') \<le> length (xs || tr)\<close> \<open>length (io2X || tr2X') \<le> length (xs || tr)\<close>
           assms(10) diff_Suc_1 distinct_conv_nth gr0_conv_Suc le_imp_less_Suc length_1 length_2
           length_take map_snd_zip scan_length states_alt_def)
     then show "False"
       by (metis assms(11) states_alt_def)
   qed
 
   ultimately show ?thesis
     by linarith
 qed
 
 
 
 lemma R_state_component_2 :
   assumes "io \<in> (R M2 s vs xs)"
   and     "observable M2"
 shows "io_targets M2 (initial M2) io = {s}"
 proof -
   have "s \<in> io_targets M2 (initial M2) io"
     using assms(1) by auto
   moreover have "io \<in> language_state M2 (initial M2)"
     using calculation by auto
   ultimately show "io_targets M2 (initial M2) io = {s}"
     using assms(2) io_targets_observable_singleton_ex by (metis singletonD)
 qed
 
 
 lemma R_union_card_is_suffix_length :
   assumes "OFSM M2"
   and     "io@xs \<in> L M2"
 shows "sum (\<lambda> q . card (R M2 q io xs)) (nodes M2) = length xs"
 using assms proof (induction xs rule: rev_induct)
   case Nil
   show ?case
     by (simp add: sum.neutral)
 next
   case (snoc x xs)
 
   have "finite (nodes M2)"
     using assms by auto
 
   have R_update : "\<And> q . R M2 q io (xs@[x]) = (if (q \<in> io_targets M2 (initial M2) (io @ xs @ [x]))
                                     then insert (io@xs@[x]) (R M2 q io xs)
                                     else R M2 q io xs)"
     by auto
 
   obtain q where "io_targets M2 (initial M2) (io @ xs @ [x]) = {q}"
     by (meson assms(1) io_targets_observable_singleton_ex snoc.prems(2))
 
   then have "R M2 q io (xs@[x]) = insert (io@xs@[x]) (R M2 q io xs)"
     using R_update by auto
   moreover have "(io@xs@[x]) \<notin> (R M2 q io xs)"
     by auto
   ultimately have "card (R M2 q io (xs@[x])) = Suc (card (R M2 q io xs))"
     by (metis card_insert_disjoint finite_R)
 
   have "q \<in> nodes M2"
     by (metis (full_types) FSM.nodes.initial \<open>io_targets M2 (initial M2) (io@xs @ [x]) = {q}\<close>
         insertI1 io_targets_nodes)
 
   have "\<forall> q' . q' \<noteq> q \<longrightarrow> R M2 q' io (xs@[x]) = R M2 q' io xs"
     using \<open>io_targets M2 (initial M2) (io@xs @ [x]) = {q}\<close> R_update
     by auto
   then have "\<forall> q' . q' \<noteq> q \<longrightarrow> card (R M2 q' io (xs@[x])) = card (R M2 q' io xs)"
     by auto
 
   then have "(\<Sum>q\<in>(nodes M2 - {q}). card (R M2 q io (xs@[x])))
               = (\<Sum>q\<in>(nodes M2 - {q}). card (R M2 q io xs))"
     by auto
   moreover have "(\<Sum>q\<in>nodes M2. card (R M2 q io (xs@[x])))
                   = (\<Sum>q\<in>(nodes M2 - {q}). card (R M2 q io (xs@[x]))) + (card (R M2 q io (xs@[x])))"
                 "(\<Sum>q\<in>nodes M2. card (R M2 q io xs))
                   = (\<Sum>q\<in>(nodes M2 - {q}). card (R M2 q io xs)) + (card (R M2 q io xs))"
   proof -
     have "\<forall>C c f. (infinite C \<or> (c::'c) \<notin> C) \<or> sum f C = (f c::nat) + sum f (C - {c})"
       by (meson sum.remove)
     then show "(\<Sum>q\<in>nodes M2. card (R M2 q io (xs@[x])))
                 = (\<Sum>q\<in>(nodes M2 - {q}). card (R M2 q io (xs@[x]))) + (card (R M2 q io (xs@[x])))"
               "(\<Sum>q\<in>nodes M2. card (R M2 q io xs))
                 = (\<Sum>q\<in>(nodes M2 - {q}). card (R M2 q io xs)) + (card (R M2 q io xs))"
       using \<open>finite (nodes M2)\<close> \<open>q \<in> nodes M2\<close> by presburger+
   qed
   ultimately have "(\<Sum>q\<in>nodes M2. card (R M2 q io (xs@[x])))
                     = Suc (\<Sum>q\<in>nodes M2. card (R M2 q io xs))"
     using \<open>card (R M2 q io (xs@[x])) = Suc (card (R M2 q io xs))\<close>
     by presburger
 
   have "(\<Sum>q\<in>nodes M2. card (R M2 q io xs)) = length xs"
     using snoc.IH snoc.prems language_state_prefix[of "io@xs" "[x]" M2 "initial M2"]
   proof -
     show ?thesis
       by (metis (no_types) \<open>(io @ xs) @ [x] \<in> L M2 \<Longrightarrow> io @ xs \<in> L M2\<close>
           \<open>OFSM M2\<close> \<open>io @ xs @ [x] \<in> L M2\<close> append.assoc snoc.IH)
   qed
 
   show ?case
   proof -
     show ?thesis
       by (metis (no_types)
           \<open>(\<Sum>q\<in>nodes M2. card (R M2 q io (xs @ [x]))) = Suc (\<Sum>q\<in>nodes M2. card (R M2 q io xs))\<close>
           \<open>(\<Sum>q\<in>nodes M2. card (R M2 q io xs)) = length xs\<close> length_append_singleton)
   qed
 qed
 
 lemma R_state_repetition_via_long_sequence :
   assumes "OFSM M"
   and     "card (nodes M) \<le> m"
   and     "Suc (m * m) \<le> length xs"
   and     "vs@xs \<in> L M"
 shows "\<exists> q \<in> nodes M . card (R M q vs xs) > m"
 proof (rule ccontr)
   assume "\<not> (\<exists>q\<in>nodes M. m < card (R M q vs xs))"
   then have "\<forall> q \<in> nodes M . card (R M q vs xs) \<le> m"
     by auto
   then have "sum (\<lambda> q . card (R M q vs xs)) (nodes M) \<le> sum (\<lambda> q . m) (nodes M)"
     by (meson sum_mono)
   moreover have "sum (\<lambda> q . m) (nodes M) \<le> m * m"
     using assms(2) by auto
   ultimately have "sum (\<lambda> q . card (R M q vs xs)) (nodes M) \<le> m * m"
     by presburger
 
   moreover have "Suc (m*m) \<le> sum (\<lambda> q . card (R M q vs xs)) (nodes M)"
     using R_union_card_is_suffix_length[OF assms(1), of vs xs] assms(4,3) by auto
   ultimately show "False" by simp
 qed
 
 lemma R_state_repetition_distribution :
   assumes "OFSM M"
   and     "Suc (card (nodes M) * m) \<le> length xs"
   and     "vs@xs \<in> L M"
 shows "\<exists> q \<in> nodes M . card (R M q vs xs) > m"
 proof (rule ccontr)
   assume "\<not> (\<exists>q\<in>nodes M. m < card (R M q vs xs))"
   then have "\<forall> q \<in> nodes M . card (R M q vs xs) \<le> m"
     by auto
   then have "sum (\<lambda> q . card (R M q vs xs)) (nodes M) \<le> sum (\<lambda> q . m) (nodes M)"
     by (meson sum_mono)
   moreover have "sum (\<lambda> q . m) (nodes M) \<le> card (nodes M) * m"
     using assms(2) by auto
   ultimately have "sum (\<lambda> q . card (R M q vs xs)) (nodes M) \<le> card (nodes M) * m"
     by presburger
 
   moreover have "Suc (card (nodes M)*m) \<le> sum (\<lambda> q . card (R M q vs xs)) (nodes M)"
     using R_union_card_is_suffix_length[OF assms(1), of vs xs] assms(3,2) by auto
   ultimately show "False"
     by simp
 qed
 
 
 
 subsection \<open> Function RP \<close>
 
 text \<open>
 Function @{verbatim RP} extends function @{verbatim MR} by adding all elements from a set of
 IO-sequences that also reach the given state.
 \<close>
 
 
 fun RP :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in \<times> 'out) list
             \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> ('in \<times> 'out) list set
             \<Rightarrow> ('in \<times> 'out) list set"
   where
   "RP M s vs xs V'' = R M s vs xs
                       \<union> {vs' \<in> V'' . io_targets M (initial M) vs' = {s}}"
 
 lemma RP_from_R:
   assumes "is_det_state_cover M2 V"
   and     "V'' \<in> Perm V M1"
 shows "RP M2 s vs xs V'' = R M2 s vs xs
         \<or> (\<exists> vs' \<in> V'' . vs' \<notin> R M2 s vs xs \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs))"
 proof (rule ccontr)
   assume assm : "\<not> (RP M2 s vs xs V'' = R M2 s vs xs \<or>
         (\<exists>vs'\<in>V''. vs' \<notin> R M2 s vs xs \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs)))"
 
   moreover have "R M2 s vs xs \<subseteq> RP M2 s vs xs V''"
     by simp
   moreover have "RP M2 s vs xs V'' \<subseteq> R M2 s vs xs \<union> V''"
     by auto
   ultimately obtain vs1 vs2 where vs_def :
        "vs1 \<noteq> vs2 \<and> vs1 \<in> V'' \<and> vs2 \<in> V''
         \<and> vs1 \<notin> R M2 s vs xs \<and> vs2 \<notin> R M2 s vs xs
         \<and> vs1 \<in> RP M2 s vs xs V'' \<and> vs2 \<in> RP M2 s vs xs V''"
     by blast
 
   then have "io_targets M2 (initial M2) vs1 = {s} \<and> io_targets M2 (initial M2) vs2 = {s}"
     by (metis (mono_tags, lifting) RP.simps Un_iff mem_Collect_eq)
   then have "io_targets M2 (initial M2) vs1 = io_targets M2 (initial M2) vs2"
     by simp
 
   obtain f where f_def : "is_det_state_cover_ass M2 f \<and> V = f ` d_reachable M2 (initial M2)"
     using assms by auto
   moreover have "V = image f (d_reachable M2 (initial M2))"
     using f_def by blast
   moreover have "map fst vs1 \<in> V \<and> map fst vs2 \<in> V"
     using assms(2) perm_inputs vs_def by blast
   ultimately obtain r1 r2 where r_def :
     "f r1 = map fst vs1 \<and> r1 \<in> d_reachable M2 (initial M2)"
     "f r2 = map fst vs2 \<and> r2 \<in> d_reachable M2 (initial M2)"
     by force
   then have "d_reaches M2 (initial M2) (map fst vs1) r1"
             "d_reaches M2 (initial M2) (map fst vs2) r2"
     by (metis f_def is_det_state_cover_ass.elims(2))+
 
   then have "io_targets M2 (initial M2) vs1 \<subseteq> {r1}"
     using d_reaches_io_target[of M2 "initial M2" "map fst vs1" r1 "map snd vs1"] by simp
   moreover have "io_targets M2 (initial M2) vs2 \<subseteq> {r2}"
     using d_reaches_io_target[of M2 "initial M2" "map fst vs2" r2 "map snd vs2"]
           \<open>d_reaches M2 (initial M2) (map fst vs2) r2\<close> by auto
   ultimately have "r1 = r2"
     using \<open>io_targets M2 (initial M2) vs1 = {s} \<and> io_targets M2 (initial M2) vs2 = {s}\<close> by auto
 
   have "map fst vs1 \<noteq> map fst vs2"
     using assms(2) perm_inputs_diff vs_def by blast
   then have "r1 \<noteq> r2"
     using r_def(1) r_def(2) by force
 
   then show "False"
     using \<open>r1 = r2\<close> by auto
 qed
 
 lemma finite_RP :
   assumes "is_det_state_cover M2 V"
   and     "V'' \<in> Perm V M1"
 shows "finite (RP M2 s vs xs V'')"
   using assms RP_from_R finite_R by (metis finite_insert)
 
 
 
 
 lemma RP_count :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "s \<in> nodes M2"
   and "productF M2 M1 FAIL PM"
   and "io_targets PM (initial PM) vs = {(q2,q1)}"
   and "path PM (xs || tr) (q2,q1)"
   and "length xs = length tr"
   and "distinct (states (xs || tr) (q2,q1))"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "\<forall> s' \<in> set (states (xs || map fst tr) q2) . \<not> (\<exists> v \<in> V . d_reaches M2 (initial M2) v s')"
 shows "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) = card (RP M2 s vs xs V'')"
   \<comment> \<open>each sequence in the set calculated by RP reaches a different state in M1\<close>
 proof -
 
   \<comment> \<open>Proof sketch:
      - RP calculates either the same set as R or the set of R and an additional element
      - in the first case, the result for R applies
      - in the second case, the additional element is not contained in the set calcualted by R due to
        the assumption that no state reached by a non-empty prefix of xs after vs is also reached by
        some sequence in V (see the last two assumptions)\<close>
 
 
   have RP_cases : "RP M2 s vs xs V'' = R M2 s vs xs
                     \<or> (\<exists> vs' \<in> V'' . vs' \<notin> R M2 s vs xs
                                       \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs))"
     using RP_from_R assms by metis
   show ?thesis
   proof (cases "RP M2 s vs xs V'' = R M2 s vs xs")
     case True
     then show ?thesis using R_count assms by metis
   next
     case False
     then obtain vs' where vs'_def : "vs' \<in> V''
                                       \<and> vs' \<notin> R M2 s vs xs
                                       \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs)"
       using RP_cases by auto
 
     have obs_PM : "observable PM"
       using observable_productF assms(2) assms(3) assms(7) by blast
 
     have state_component_2 : "\<forall> io \<in> (R M2 s vs xs) . io_targets M2 (initial M2) io = {s}"
     proof
       fix io assume "io \<in> R M2 s vs xs"
       then have "s \<in> io_targets M2 (initial M2) io"
         by auto
       moreover have "io \<in> language_state M2 (initial M2)"
         using calculation by auto
       ultimately show "io_targets M2 (initial M2) io = {s}"
         using assms(3) io_targets_observable_singleton_ex by (metis singletonD)
     qed
 
     have "vs' \<in> L M1"
       using assms(13) perm_language vs'_def by blast
     then obtain s' where s'_def : "io_targets M1 (initial M1) vs' = {s'}"
       by (meson assms(2) io_targets_observable_singleton_ob)
 
     moreover have "s' \<notin> \<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))"
     proof (rule ccontr)
       assume "\<not> s' \<notin> \<Union>(io_targets M1 (initial M1) ` R M2 s vs xs)"
       then obtain xs' where xs'_def : "vs @ xs' \<in> R M2 s vs xs \<and> s' \<in> io_targets M1 (initial M1) (vs @ xs')"
       proof -
         assume a1: "\<And>xs'. vs @ xs' \<in> R M2 s vs xs \<and> s' \<in> io_targets M1 (initial M1) (vs @ xs')
                           \<Longrightarrow> thesis"
         obtain pps :: "('a \<times> 'b) list set \<Rightarrow> (('a \<times> 'b) list \<Rightarrow> 'c set) \<Rightarrow> 'c \<Rightarrow> ('a \<times> 'b) list"
           where
           "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x0 \<and> x2 \<in> x1 v3) = (pps x0 x1 x2 \<in> x0 \<and> x2 \<in> x1 (pps x0 x1 x2))"
           by moura
         then have f2: "pps (R M2 s vs xs) (io_targets M1 (initial M1)) s' \<in> R M2 s vs xs
                         \<and> s' \<in> io_targets M1 (initial M1) (pps (R M2 s vs xs)
                                               (io_targets M1 (initial M1)) s')"
           using \<open>\<not> s' \<notin> \<Union>(io_targets M1 (initial M1) ` R M2 s vs xs)\<close> by blast
         then have "\<exists>ps. pps (R M2 s vs xs) (io_targets M1 (initial M1)) s' = vs @ ps
                         \<and> ps \<noteq> [] \<and> prefix ps xs \<and> s \<in> io_targets M2 (initial M2) (vs @ ps)"
           by simp
         then show ?thesis
           using f2 a1 by (metis (no_types))
       qed
       then obtain tr' where tr'_def : "path M2 (vs @ xs' || tr') (initial M2)
                                         \<and> length tr' = length (vs @ xs')"
         by auto
 
       then obtain trV' trX' where tr'_split : "trV' = take (length vs) tr'"
                                               "trX' = drop (length vs) tr'"
                                               "tr' = trV' @ trX'"
         by fastforce
       then have "path M2 (vs || trV') (initial M2) \<and> length trV' = length vs"
         by (metis (no_types) FSM.path_append_elim \<open>trV' = take (length vs) tr'\<close>
             append_eq_conv_conj length_take tr'_def zip_append1)
 
 
 
 
       have "initial PM = (initial M2, initial M1)"
         using assms(7) by simp
       moreover have "vs \<in> L M2" "vs \<in> L M1"
         using assms(1) language_state_prefix by auto
       ultimately have "io_targets M1 (initial M1) vs = {q1}"
                       "io_targets M2 (initial M2) vs = {q2}"
         using productF_path_io_targets[of M2 M1 FAIL PM "initial M2" "initial M1" vs q2 q1]
         by (metis FSM.nodes.initial assms(7) assms(8) assms(2) assms(3) assms(4) assms(5)
             io_targets_observable_singleton_ex singletonD)+
 
       then have "target (vs || trV') (initial M2) = q2"
         using \<open>path M2 (vs || trV') (initial M2) \<and> length trV' = length vs\<close> io_target_target
         by metis
       then have path_xs' : "path M2 (xs' || trX') q2 \<and> length trX' = length xs'"
         by (metis (no_types) FSM.path_append_elim
             \<open>path M2 (vs || trV') (initial M2) \<and> length trV' = length vs\<close>
             \<open>target (vs || trV') (initial M2) = q2\<close> append_eq_conv_conj length_drop tr'_def
             tr'_split(1) tr'_split(2) zip_append2)
 
 
       have "io_targets M2 (initial M2) (vs @ xs') = {s}"
         using state_component_2 xs'_def by blast
       then have "io_targets M2 q2 xs' = {s}"
         by (meson assms(3) observable_io_targets_split \<open>io_targets M2 (initial M2) vs = {q2}\<close>)
       then have target_xs' : "target (xs' || trX') q2 = s"
         using io_target_target path_xs' by metis
       moreover have "length xs' > 0"
         using xs'_def by auto
       ultimately have "last (states (xs' || trX') q2) = s"
         using path_xs' target_in_states by metis
       moreover have "length (states (xs' || trX') q2) > 0"
         using \<open>0 < length xs'\<close> path_xs' by auto
       ultimately have states_xs' : "s \<in> set (states (xs' || trX') q2)"
         using last_in_set by blast
 
       have "vs @ xs \<in> L M2"
         using assms by simp
       then obtain q' where "io_targets M2 (initial M2) (vs@xs) = {q'}"
         using io_targets_observable_singleton_ob[of M2 "vs@xs" "initial M2"] assms(3) by auto
       then have "xs \<in> language_state M2 q2"
         using assms(3) \<open>io_targets M2 (initial M2) vs = {q2}\<close>
               observable_io_targets_split[of M2 "initial M2" vs xs q' q2]
         by auto
 
       moreover have "path PM (xs || map fst tr || map snd tr) (q2,q1)
                       \<and> length xs = length (map fst tr)"
         using assms(7) assms(9) assms(10) productF_path_unzip by simp
       moreover have "xs \<in> language_state PM (q2,q1)"
         using assms(9) assms(10) by auto
       moreover have "q2 \<in> nodes M2"
         using \<open>io_targets M2 (initial M2) vs = {q2}\<close> io_targets_nodes
         by (metis FSM.nodes.initial insertI1)
       moreover have "q1 \<in> nodes M1"
         using \<open>io_targets M1 (initial M1) vs = {q1}\<close> io_targets_nodes
         by (metis FSM.nodes.initial insertI1)
       ultimately have path_xs : "path M2 (xs || map fst tr) q2"
         using productF_path_reverse_ob_2(1)[of xs "map fst tr" "map snd tr" M2 M1 FAIL PM q2 q1]
               assms(2,3,4,5,7)
         by simp
 
 
 
       moreover have "prefix xs' xs"
         using xs'_def by auto
       ultimately have "trX' = take (length xs') (map fst tr)"
         using \<open>path PM (xs || map fst tr || map snd tr) (q2, q1) \<and> length xs = length (map fst tr)\<close>
               assms(3) path_xs'
         by (metis observable_path_prefix)
 
       then have states_xs : "s \<in> set (states (xs || map fst tr) q2)"
         by (metis assms(10) in_set_takeD length_map map_snd_zip path_xs' states_alt_def states_xs')
 
 
 
       have "d_reaches M2 (initial M2) (map fst vs') s"
       proof -
         obtain fV where fV_def : "is_det_state_cover_ass M2 fV
                                   \<and> V = fV ` d_reachable M2 (initial M2)"
           using assms(12) by auto
         moreover have "V = image fV (d_reachable M2 (initial M2))"
           using fV_def by blast
         moreover have "map fst vs' \<in> V"
           using perm_inputs vs'_def assms(13) by metis
         ultimately obtain qv where qv_def : "fV qv = map fst vs' \<and> qv\<in> d_reachable M2 (initial M2)"
           by force
         then have "d_reaches M2 (initial M2) (map fst vs') qv"
           by (metis fV_def is_det_state_cover_ass.elims(2))
         then have "io_targets M2 (initial M2) vs' \<subseteq> {qv}"
           using d_reaches_io_target[of M2 "initial M2" "map fst vs'" qv "map snd vs'"] by simp
         moreover have "io_targets M2 (initial M2) vs' = {s}"
           using vs'_def by (metis (mono_tags, lifting) RP.simps Un_iff insertI1 mem_Collect_eq)
         ultimately have "qv = s"
           by simp
         then show ?thesis
           using \<open>d_reaches M2 (initial M2) (map fst vs') qv\<close> by blast
       qed
 
       then show "False"  by (meson assms(14) assms(13) perm_inputs states_xs vs'_def)
     qed
 
     moreover have "\<Union> (image (io_targets M1 (initial M1)) (insert vs' (R M2 s vs xs)))
                     = insert s' (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs)))"
       using s'_def by simp
 
     moreover have "finite (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs)))"
     proof
       show "finite (R M2 s vs xs)"
         using finite_R by simp
       show "\<And>a. a \<in> R M2 s vs xs \<Longrightarrow> finite (io_targets M1 (initial M1) a)"
       proof -
         fix a assume "a \<in> R M2 s vs xs"
         then have "prefix a (vs@xs)"
           by auto
         then have "a \<in> L M1"
           using language_state_prefix by (metis IntD1 assms(1) prefix_def)
         then obtain p where "io_targets M1 (initial M1) a = {p}"
           using assms(2) io_targets_observable_singleton_ob by metis
         then show "finite (io_targets M1 (initial M1) a)"
           by simp
       qed
     qed
 
     ultimately have "card (\<Union> (image (io_targets M1 (initial M1)) (insert vs' (R M2 s vs xs))))
                      = Suc (card (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))))"
       by (metis (no_types) card_insert_disjoint)
 
 
     moreover have "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))
                     = card (\<Union> (image (io_targets M1 (initial M1)) (insert vs' (R M2 s vs xs))))"
       using vs'_def by simp
 
     ultimately have "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))
                       = Suc (card (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))))"
       by linarith
 
     then have "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))
                 = Suc (card (R M2 s vs xs))"
       using R_count[of vs xs M1 M2 s FAIL PM q2 q1 tr] assms(1,10,11,2-9) by linarith
 
     moreover have "card (RP M2 s vs xs V'') = Suc (card (R M2 s vs xs))"
       using vs'_def by (metis card_insert_if finite_R)
 
     ultimately show ?thesis
       by linarith
   qed
 qed
 
 
 lemma RP_state_component_2 :
   assumes "io \<in> (RP M2 s vs xs V'')"
   and     "observable M2"
 shows "io_targets M2 (initial M2) io = {s}"
   by (metis (mono_tags, lifting) RP.simps R_state_component_2 Un_iff assms mem_Collect_eq)
 
 
 lemma RP_io_targets_split :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "productF M2 M1 FAIL PM"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "io \<in> RP M2 s vs xs V''"
 shows "io_targets PM (initial PM) io
         = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
 proof -
   have RP_cases : "RP M2 s vs xs V'' = R M2 s vs xs
                     \<or> (\<exists> vs' \<in> V'' . vs' \<notin> R M2 s vs xs
                                       \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs))"
     using RP_from_R assms by metis
   show ?thesis
   proof (cases "io \<in> R M2 s vs xs")
     case True
     then have io_prefix : "prefix io (vs @ xs)"
       by auto
     then have io_lang_subs : "io \<in> L M1 \<and> io \<in> L M2"
       using assms(1) unfolding prefix_def by (metis IntE language_state language_state_split)
     then have io_lang_inter : "io \<in> L M1 \<inter> L M2"
       by simp
     then have io_lang_pm : "io \<in> L PM"
       using productF_language assms by blast
     moreover obtain p2 p1 where "(p2,p1) \<in> io_targets PM (initial PM) io"
       by (metis assms(2) assms(3) assms(6) calculation insert_absorb insert_ident insert_not_empty
           io_targets_observable_singleton_ob observable_productF singleton_insert_inj_eq subrelI)
     ultimately have targets_pm : "io_targets PM (initial PM) io = {(p2,p1)}"
       using assms io_targets_observable_singleton_ex singletonD
       by (metis observable_productF)
     then obtain trP where trP_def : "target (io || trP) (initial PM) = (p2,p1)
                                       \<and> path PM (io || trP) (initial PM) \<and> length io = length trP"
     proof -
       assume a1: "\<And>trP. target (io || trP) (initial PM) = (p2, p1)
                           \<and> path PM (io || trP) (initial PM) \<and> length io = length trP \<Longrightarrow> thesis"
       have "\<exists>ps. target (io || ps) (initial PM) = (p2, p1) \<and> path PM (io || ps) (initial PM)
                                                            \<and> length io = length ps"
         using \<open>(p2, p1) \<in> io_targets PM (initial PM) io\<close> by auto
       then show ?thesis
         using a1 by blast
     qed
     then have trP_unique : "{tr . path PM (io || tr) (initial PM) \<and> length io = length tr} = {trP}"
       using observable_productF observable_path_unique_ex[of PM io "initial PM"]
             io_lang_pm assms(2) assms(3) assms(7)
     proof -
       obtain pps :: "('d \<times> 'c) list" where
         f1: "{ps. path PM (io || ps) (initial PM) \<and> length io = length ps} = {pps}
               \<or> \<not> observable PM"
         by (metis (no_types) \<open>\<And>thesis. \<lbrakk>observable PM; io \<in> L PM; \<And>tr.
                               {t. path PM (io || t) (initial PM) \<and> length io = length t} = {tr}
                                \<Longrightarrow> thesis\<rbrakk> \<Longrightarrow> thesis\<close>
             io_lang_pm)
       have f2: "observable PM"
         by (meson \<open>observable M1\<close> \<open>observable M2\<close> \<open>productF M2 M1 FAIL PM\<close> observable_productF)
       then have "trP \<in> {pps}"
         using f1 trP_def by blast
       then show ?thesis
         using f2 f1 by force
     qed
 
 
     obtain trIO2 where trIO2_def : "{tr . path M2 (io || tr) (initial M2) \<and> length io = length tr}
                                     = { trIO2 }"
       using observable_path_unique_ex[of M2 io "initial M2"] io_lang_subs assms(3) by blast
     obtain trIO1 where trIO1_def : "{tr . path M1 (io || tr) (initial M1) \<and> length io = length tr}
                                     = { trIO1 }"
       using observable_path_unique_ex[of M1 io "initial M1"] io_lang_subs assms(2) by blast
 
     have "path PM (io || trIO2 || trIO1) (initial M2, initial M1)
           \<and> length io = length trIO2 \<and> length trIO2 = length trIO1"
     proof -
       have f1: "path M2 (io || trIO2) (initial M2) \<and> length io = length trIO2"
         using trIO2_def by auto
       have f2: "path M1 (io || trIO1) (initial M1) \<and> length io = length trIO1"
         using trIO1_def by auto
       then have "length trIO2 = length trIO1"
         using f1 by presburger
       then show ?thesis
         using f2 f1 assms(4) assms(5) assms(6) by blast
     qed
     then have trP_split : "path PM (io || trIO2 || trIO1) (initial PM)
                            \<and> length io = length trIO2 \<and> length trIO2 = length trIO1"
       using assms(6) by auto
     then have trP_zip : "trIO2 || trIO1 = trP"
       using trP_def trP_unique length_zip by fastforce
 
     have "target (io || trIO2) (initial M2) = p2
             \<and> path M2 (io || trIO2) (initial M2)
             \<and> length io = length trIO2"
       using trP_zip trP_split assms(6) trP_def trIO2_def by auto
     then have "p2 \<in> io_targets M2 (initial M2) io"
       by auto
     then have targets_2 : "io_targets M2 (initial M2) io = {p2}"
       by (meson assms(3) observable_io_target_is_singleton)
 
     have "target (io || trIO1) (initial M1) = p1
           \<and> path M1 (io || trIO1) (initial M1)
           \<and> length io = length trIO1"
       using trP_zip trP_split assms(6) trP_def trIO1_def by auto
     then have "p1 \<in> io_targets M1 (initial M1) io"
       by auto
     then have targets_1 : "io_targets M1 (initial M1) io = {p1}"
       by (metis io_lang_subs assms(2) io_targets_observable_singleton_ex singletonD)
 
     have "io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io = {(p2,p1)}"
       using targets_2 targets_1 by simp
     then show "io_targets PM (initial PM) io
                 = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
       using targets_pm by simp
 
   next
     case False
     then have "io \<notin> R M2 s vs xs \<and> RP M2 s vs xs V'' = insert io (R M2 s vs xs)"
       using RP_cases assms(9) by (metis insertE)
 
     have "io \<in> L M1" using assms(8) perm_language assms(9)
       using False by auto
     then obtain s' where s'_def : "io_targets M1 (initial M1) io = {s'}"
       by (meson assms(2) io_targets_observable_singleton_ob)
     then obtain tr1 where tr1_def : "target (io || tr1) (initial M1) = s'
                                       \<and> path M1 (io || tr1) (initial M1) \<and> length tr1 = length io"
       by (metis io_targets_elim singletonI)
 
     have "io_targets M2 (initial M2) io = {s}"
       using assms(9) assms(3) RP_state_component_2 by simp
     then obtain tr2 where tr2_def : "target (io || tr2) (initial M2) = s
                                       \<and> path M2 (io || tr2) (initial M2) \<and> length tr2 = length io"
       by (metis io_targets_elim singletonI)
     then have paths : "path M2 (io || tr2) (initial M2) \<and> path M1 (io || tr1) (initial M1)"
       using tr1_def by simp
 
 
     have "length io = length tr2"
       using tr2_def by simp
     moreover have "length tr2 = length tr1"
       using tr1_def tr2_def by simp
     ultimately have "path PM (io || tr2 || tr1) (initial M2, initial M1)"
       using assms(6) assms(5) assms(4) paths
             productF_path_forward[of io tr2 tr1 M2 M1 FAIL PM "initial M2" "initial M1"]
       by blast
 
     moreover have "target (io || tr2 || tr1) (initial M2, initial M1) = (s,s')"
       by (simp add: tr1_def tr2_def)
     moreover have "length (tr2 || tr2) = length io"
       using tr1_def tr2_def by simp
     moreover have "(initial M2, initial M1) = initial PM"
       using assms(6) by simp
     ultimately have "(s,s') \<in> io_targets PM (initial PM) io"
       by (metis io_target_from_path length_zip tr1_def tr2_def)
     moreover have "observable PM"
       using assms(2) assms(3) assms(6) observable_productF by blast
     then have "io_targets PM (initial PM) io = {(s,s')}"
       by (meson calculation observable_io_target_is_singleton)
 
     then show ?thesis
       using \<open>io_targets M2 (initial M2) io = {s}\<close> \<open>io_targets M1 (initial M1) io = {s'}\<close>
       by simp
   qed
 qed
 
 
 
 
 
 lemma RP_io_targets_finite_M1 :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
 shows "finite (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))"
 proof
   show "finite (RP M2 s vs xs V'')" using finite_RP assms(3) assms(4) by simp
   show "\<And>a. a \<in> RP M2 s vs xs V'' \<Longrightarrow> finite (io_targets M1 (initial M1) a)"
   proof -
     fix a assume "a \<in> RP M2 s vs xs V''"
 
     have RP_cases : "RP M2 s vs xs V'' = R M2 s vs xs
                       \<or> (\<exists> vs' \<in> V'' . vs' \<notin> R M2 s vs xs
                                         \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs))"
       using RP_from_R assms by metis
     have "a \<in> L M1"
     proof (cases "a \<in> R M2 s vs xs")
       case True
       then have "prefix a (vs@xs)"
         by auto
       then show "a \<in> L M1"
         using language_state_prefix by (metis IntD1 assms(1) prefix_def)
     next
       case False
       then have "a \<in> V'' \<and> RP M2 s vs xs V'' = insert a (R M2 s vs xs)"
         using RP_cases \<open>a \<in> RP M2 s vs xs V''\<close> by (metis insertE)
       then show "a \<in> L M1"
         by (meson assms(4) perm_language)
     qed
     then obtain p where "io_targets M1 (initial M1) a = {p}"
       using assms(2) io_targets_observable_singleton_ob by metis
     then show "finite (io_targets M1 (initial M1) a)"
       by simp
   qed
 qed
 
 lemma RP_io_targets_finite_PM :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "productF M2 M1 FAIL PM"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
 shows "finite (\<Union> (image (io_targets PM (initial PM)) (RP M2 s vs xs V'')))"
 proof -
   have "\<forall> io \<in> RP M2 s vs xs V'' . io_targets PM (initial PM) io
                                     = {s} \<times> io_targets M1 (initial M1) io"
   proof
     fix io assume "io \<in> RP M2 s vs xs V''"
     then have "io_targets PM (initial PM) io
                 = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
       using assms RP_io_targets_split[of vs xs M1 M2 FAIL PM V V'' io s] by simp
     moreover have "io_targets M2 (initial M2) io = {s}"
       using \<open>io \<in> RP M2 s vs xs V''\<close> assms(3) RP_state_component_2[of io M2 s vs xs V'']
       by blast
     ultimately show "io_targets PM (initial PM) io = {s} \<times> io_targets M1 (initial M1) io"
       by auto
   qed
   then have "\<Union> (image (io_targets PM (initial PM)) (RP M2 s vs xs V''))
               = \<Union> (image (\<lambda> io . {s} \<times> io_targets M1 (initial M1) io) (RP M2 s vs xs V''))"
     by simp
   moreover have "\<Union> (image (\<lambda> io . {s} \<times> io_targets M1 (initial M1) io) (RP M2 s vs xs V''))
                   = {s} \<times> \<Union> (image (\<lambda> io . io_targets M1 (initial M1) io) (RP M2 s vs xs V''))"
     by blast
   ultimately have "\<Union> (image (io_targets PM (initial PM)) (RP M2 s vs xs V''))
                     = {s} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))"
     by auto
   moreover have "finite ({s} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))"
     using assms(1,2,7,8) RP_io_targets_finite_M1[of vs xs M1 M2 V V'' s] by simp
   ultimately show ?thesis
     by simp
 qed
 
 
 
 lemma RP_union_card_is_suffix_length :
   assumes "OFSM M2"
   and     "io@xs \<in> L M2"
   and     "is_det_state_cover M2 V"
   and     "V'' \<in> Perm V M1"
 shows "\<And> q . card (R M2 q io xs) \<le> card (RP M2 q io xs V'')"
       "sum (\<lambda> q . card (RP M2 q io xs V'')) (nodes M2) \<ge> length xs"
 proof -
   have "sum (\<lambda> q . card (R M2 q io xs)) (nodes M2) = length xs"
     using R_union_card_is_suffix_length[OF assms(1,2)] by assumption
   show "\<And> q . card (R M2 q io xs) \<le> card (RP M2 q io xs V'')"
     by (metis RP_from_R assms(3) assms(4) card_insert_le eq_iff finite_R)
   show "sum (\<lambda> q . card (RP M2 q io xs V'')) (nodes M2) \<ge> length xs"
     by (metis (no_types, lifting) \<open>(\<Sum>q\<in>nodes M2. card (R M2 q io xs)) = length xs\<close>
         \<open>\<And>q. card (R M2 q io xs) \<le> card (RP M2 q io xs V'')\<close> sum_mono)
 qed
 
 lemma RP_state_repetition_distribution_productF :
   assumes "OFSM M2"
   and     "OFSM M1"
   and     "(card (nodes M2) * m) \<le> length xs"
   and     "card (nodes M1) \<le> m"
   and     "vs@xs \<in> L M2 \<inter> L M1"
   and     "is_det_state_cover M2 V"
   and     "V'' \<in> Perm V M1"
 shows "\<exists> q \<in> nodes M2 . card (RP M2 q vs xs V'') > m"
 proof -
   have "finite (nodes M1)"
        "finite (nodes M2)"
     using assms(1,2) by auto
   then have "card(nodes M2 \<times> nodes M1) = card (nodes M2) * card (nodes M1)"
     using card_cartesian_product by blast
 
   have "nodes (product M2 M1) \<subseteq> nodes M2 \<times> nodes M1"
     using product_nodes by auto
 
   have "card (nodes (product M2 M1)) \<le> card (nodes M2) * card (nodes M1)"
     by (metis (no_types) \<open>card (nodes M2 \<times> nodes M1) = |M2| * |M1|\<close> \<open>finite (nodes M1)\<close>
         \<open>finite (nodes M2)\<close> \<open>nodes (product M2 M1) \<subseteq> nodes M2 \<times> nodes M1\<close>
         card_mono finite_cartesian_product)
 
 
   have "(\<forall> q \<in> nodes M2 . card (R M2 q vs xs) = m) \<or> (\<exists> q \<in> nodes M2 . card (R M2 q vs xs) > m)"
   proof (rule ccontr)
     assume "\<not> ((\<forall>q\<in>nodes M2. card (R M2 q vs xs) = m) \<or> (\<exists>q\<in>nodes M2. m < card (R M2 q vs xs)))"
 
     then have "\<forall> q \<in> nodes M2 . card (R M2 q vs xs) \<le> m"
       by auto
     moreover obtain q' where "q'\<in>nodes M2" "card (R M2 q' vs xs) < m"
       using \<open>\<not> ((\<forall>q\<in>nodes M2. card (R M2 q vs xs) = m) \<or> (\<exists>q\<in>nodes M2. m < card (R M2 q vs xs)))\<close>
             nat_neq_iff
       by blast
 
     have "sum (\<lambda> q . card (R M2 q vs xs)) (nodes M2)
           = sum (\<lambda> q . card (R M2 q vs xs)) (nodes M2 - {q'})
             + sum (\<lambda> q . card (R M2 q vs xs)) {q'}"
       using \<open>q'\<in>nodes M2\<close>
       by (meson \<open>finite (nodes M2)\<close> empty_subsetI insert_subset sum.subset_diff)
     moreover have "sum (\<lambda> q . card (R M2 q vs xs)) (nodes M2 - {q'})
                     \<le> sum (\<lambda> q . m) (nodes M2 - {q'})"
       using \<open>\<forall> q \<in> nodes M2 . card (R M2 q vs xs) \<le> m\<close>
       by (meson sum_mono DiffD1)
     moreover have "sum (\<lambda> q . card (R M2 q vs xs)) {q'} < m"
       using \<open>card (R M2 q' vs xs) < m\<close> by auto
     ultimately have "sum (\<lambda> q . card (R M2 q vs xs)) (nodes M2) < sum (\<lambda> q . m) (nodes M2)"
     proof -
       have "\<forall>C c f. infinite C \<or> (c::'c) \<notin> C \<or> sum f C = (f c::nat) + sum f (C - {c})"
         by (meson sum.remove)
       then have "(\<Sum>c\<in>nodes M2. m) = m + (\<Sum>c\<in>nodes M2 - {q'}. m)"
         using \<open>finite (nodes M2)\<close> \<open>q' \<in> nodes M2\<close> by blast
       then show ?thesis
         using \<open>(\<Sum>q\<in>nodes M2 - {q'}. card (R M2 q vs xs)) \<le> (\<Sum>q\<in>nodes M2 - {q'}. m)\<close>
               \<open>(\<Sum>q\<in>nodes M2. card (R M2 q vs xs)) = (\<Sum>q\<in>nodes M2 - {q'}. card (R M2 q vs xs))
                 + (\<Sum>q\<in>{q'}. card (R M2 q vs xs))\<close>
               \<open>(\<Sum>q\<in>{q'}. card (R M2 q vs xs)) < m\<close>
         by linarith
     qed
 
 
     moreover have "sum (\<lambda> q . m) (nodes M2) \<le> card (nodes M2) * m"
       using assms(2) by auto
     ultimately have "sum (\<lambda> q . card (R M2 q vs xs)) (nodes M2) < card (nodes M2) * m"
       by presburger
 
     moreover have "Suc (card (nodes M2)*m) \<le> sum (\<lambda> q . card (R M2 q vs xs)) (nodes M2)"
       using R_union_card_is_suffix_length[OF assms(1), of vs xs] assms(5,3)
       by (metis Int_iff \<open>vs @ xs \<in> L M2 \<Longrightarrow> (\<Sum>q\<in>nodes M2. card (R M2 q vs xs)) = length xs\<close>
           \<open>vs @ xs \<in> L M2 \<inter> L M1\<close> \<open>|M2| * m \<le> length xs\<close> calculation less_eq_Suc_le not_less_eq_eq)
 
     ultimately show "False" by simp
   qed
   then show ?thesis
   proof
     let ?q = "initial M2"
 
     assume "\<forall>q\<in>nodes M2. card (R M2 q vs xs) = m"
     then have "card (R M2 ?q vs xs) = m"
       by auto
 
     have "[] \<in> V''"
       by (meson assms(6) assms(7) perm_empty)
     then have "[] \<in> RP M2 ?q vs xs V''"
       by auto
     have "[] \<notin> R M2 ?q vs xs"
       by auto
     have "card (RP M2 ?q vs xs V'') \<ge> card (R M2 ?q vs xs)"
       using finite_R[of M2 ?q vs xs] finite_RP[OF assms(6,7),of ?q vs xs] unfolding RP.simps
       by (simp add: card_mono)
 
     have "card (RP M2 ?q vs xs V'') > card (R M2 ?q vs xs)"
     proof -
       have f1: "\<forall>n na. (\<not> (n::nat) \<le> na \<or> n = na) \<or> n < na"
         by (meson le_neq_trans)
       have "RP M2 (initial M2) vs xs V'' \<noteq> R M2 (initial M2) vs xs"
         using \<open>[] \<in> RP M2 (initial M2) vs xs V''\<close> \<open>[] \<notin> R M2 (initial M2) vs xs\<close> by blast
       then show ?thesis
         using f1 by (metis (no_types) RP_from_R
                      \<open>card (R M2 (initial M2) vs xs) \<le> card (RP M2 (initial M2) vs xs V'')\<close>
                      assms(6) assms(7) card_insert_disjoint finite_R le_simps(2))
     qed
 
     then show ?thesis
       using \<open>card (R M2 ?q vs xs) = m\<close>
       by blast
   next
     assume "\<exists>q\<in>nodes M2. m < card (R M2 q vs xs)"
     then obtain q where "q\<in>nodes M2" "m < card (R M2 q vs xs)"
       by blast
     moreover have "card (RP M2 q vs xs V'') \<ge> card (R M2 q vs xs)"
       using finite_R[of M2 q vs xs] finite_RP[OF assms(6,7),of q vs xs] unfolding RP.simps
       by (simp add: card_mono)
     ultimately have "m < card (RP M2 q vs xs V'')"
       by simp
 
     show ?thesis
       using \<open>q \<in> nodes M2\<close>  \<open>m < card (RP M2 q vs xs V'')\<close> by blast
   qed
 qed
 
 
 
 subsection \<open> Conditions for the result of LB to be a valid lower bound \<close>
 
 text \<open>
 The following predicates describe the assumptions necessary to show that the value calculated by
 @{verbatim LB} is a lower bound on the number of states of a given FSM.
 \<close>
 
 fun Prereq :: "('in, 'out, 'state1) FSM \<Rightarrow> ('in, 'out, 'state2) FSM \<Rightarrow> ('in \<times> 'out) list
               \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> 'in list set \<Rightarrow> 'state1 set \<Rightarrow> ('in, 'out) ATC set
               \<Rightarrow> ('in \<times> 'out) list set \<Rightarrow> bool"
   where
   "Prereq M2 M1 vs xs T S \<Omega> V'' = (
     (finite T)
     \<and> (vs @ xs) \<in> L M2 \<inter> L M1
     \<and> S \<subseteq> nodes M2
     \<and> (\<forall> s1 \<in> S . \<forall> s2 \<in> S . s1 \<noteq> s2
         \<longrightarrow> (\<forall> io1 \<in> RP M2 s1 vs xs V'' .
                \<forall> io2 \<in> RP M2 s2 vs xs V'' .
                  B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> )))"
 
 
 fun Rep_Pre :: "('in, 'out, 'state1) FSM \<Rightarrow> ('in, 'out, 'state2) FSM \<Rightarrow> ('in \<times> 'out) list
                 \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> bool" where
   "Rep_Pre M2 M1 vs xs = (\<exists> xs1 xs2 . prefix xs1 xs2 \<and> prefix xs2 xs \<and> xs1 \<noteq> xs2
     \<and> (\<exists> s2 . io_targets M2 (initial M2) (vs @ xs1) = {s2}
               \<and> io_targets M2 (initial M2) (vs @ xs2) = {s2})
     \<and> (\<exists> s1 . io_targets M1 (initial M1) (vs @ xs1) = {s1}
               \<and> io_targets M1 (initial M1) (vs @ xs2) = {s1}))"
 
 
 fun Rep_Cov :: "('in, 'out, 'state1) FSM \<Rightarrow> ('in, 'out, 'state2) FSM \<Rightarrow> ('in \<times> 'out) list set
                 \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> bool" where
   "Rep_Cov M2 M1 V'' vs xs = (\<exists> xs' vs' . xs' \<noteq> [] \<and> prefix xs' xs \<and> vs' \<in> V''
     \<and> (\<exists> s2 . io_targets M2 (initial M2) (vs @ xs') = {s2}
               \<and> io_targets M2 (initial M2) (vs') = {s2})
     \<and> (\<exists> s1 . io_targets M1 (initial M1) (vs @ xs') = {s1}
               \<and> io_targets M1 (initial M1) (vs') = {s1}))"
 
 
 
 lemma distinctness_via_Rep_Pre :
   assumes "\<not> Rep_Pre M2 M1 vs xs"
   and "productF M2 M1 FAIL PM"
   and "observable M1"
   and "observable M2"
   and "io_targets PM (initial PM) vs = {(q2,q1)}"
   and "path PM (xs || tr) (q2,q1)"
   and "length xs = length tr"
   and "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "well_formed M1"
   and "well_formed M2"
 shows "distinct (states (xs || tr) (q2, q1))"
 proof (rule ccontr)
   assume assm : "\<not> distinct (states (xs || tr) (q2, q1))"
   then obtain i1 i2 where index_def :
      "i1 \<noteq> 0
       \<and> i1 \<noteq> i2
       \<and> i1 < length (states (xs || tr) (q2, q1))
       \<and> i2 < length (states (xs || tr) (q2, q1))
       \<and> (states (xs || tr) (q2, q1)) ! i1 = (states (xs || tr) (q2, q1)) ! i2"
     by (metis distinct_conv_nth)
   then have "length xs > 0" by auto
 
   let ?xs1 = "take (Suc i1) xs"
   let ?xs2 = "take (Suc i2) xs"
   let ?tr1 = "take (Suc i1) tr"
   let ?tr2 = "take (Suc i2) tr"
   let ?st  = "(states (xs || tr) (q2, q1)) ! i1"
 
   have obs_PM : "observable PM"
     using observable_productF assms(2) assms(3) assms(4) by blast
 
   have "initial PM = (initial M2, initial M1)"
     using assms(2) by simp
   moreover have "vs \<in> L M2" "vs \<in> L M1"
     using assms(8) language_state_prefix by auto
   ultimately have "io_targets M1 (initial M1) vs = {q1}" "io_targets M2 (initial M2) vs = {q2}"
     using productF_path_io_targets[of M2 M1 FAIL PM "initial M2" "initial M1" vs q2 q1]
     by (metis FSM.nodes.initial assms(2) assms(3) assms(4) assms(5) assms(9) assms(10)
         io_targets_observable_singleton_ex singletonD)+
 
   \<comment> \<open>paths for ?xs1\<close>
 
   have "(states (xs || tr) (q2, q1)) ! i1 \<in> io_targets PM (q2, q1) ?xs1"
     by (metis \<open>0 < length xs\<close> assms(6) assms(7) index_def map_snd_zip states_alt_def
         states_index_io_target)
   then have "io_targets PM (q2, q1) ?xs1 = {?st}"
     using obs_PM by (meson observable_io_target_is_singleton)
 
   have "path PM (?xs1 || ?tr1) (q2,q1)"
     by (metis FSM.path_append_elim append_take_drop_id assms(6) assms(7) length_take zip_append)
   then have "path PM (?xs1 || map fst ?tr1 || map snd ?tr1) (q2,q1)"
     by auto
 
   have "vs @ ?xs1 \<in> L M2"
     by (metis (no_types) IntD2 append_assoc append_take_drop_id assms(8) language_state_prefix)
   then obtain q2' where "io_targets M2 (initial M2) (vs@?xs1) = {q2'}"
     using io_targets_observable_singleton_ob[of M2 "vs@?xs1" "initial M2"] assms(4) by auto
   then have "q2' \<in> io_targets M2 q2 ?xs1"
     using assms(4) \<open>io_targets M2 (initial M2) vs = {q2}\<close>
           observable_io_targets_split[of M2 "initial M2" vs ?xs1 q2' q2]
     by simp
   then have "?xs1 \<in> language_state M2 q2"
     by auto
   moreover have "length ?xs1 = length (map snd ?tr1)"
     using assms(7) by auto
   moreover have "length (map fst ?tr1) = length (map snd ?tr1)"
     by auto
   moreover have "q2 \<in> nodes M2"
     using \<open>io_targets M2 (initial M2) vs = {q2}\<close> io_targets_nodes
     by (metis FSM.nodes.initial insertI1)
   moreover have "q1 \<in> nodes M1"
     using \<open>io_targets M1 (initial M1) vs = {q1}\<close> io_targets_nodes
     by (metis FSM.nodes.initial insertI1)
   ultimately have
      "path M1 (?xs1 || map snd ?tr1) q1"
      "path M2 (?xs1 || map fst ?tr1) q2"
      "target (?xs1 || map snd ?tr1) q1 = snd (target (?xs1 || map fst ?tr1 || map snd ?tr1) (q2,q1))"
      "target (?xs1 || map fst ?tr1) q2 = fst (target (?xs1 || map fst ?tr1 || map snd ?tr1) (q2,q1))"
     using assms(2) assms(9) assms(10) \<open>path PM (?xs1 || map fst ?tr1 || map snd ?tr1) (q2,q1)\<close>
           assms(4)
           productF_path_reverse_ob_2[of ?xs1 "map fst ?tr1" "map snd ?tr1" M2 M1 FAIL PM q2 q1]
     by simp+
   moreover have "target (?xs1 || map fst ?tr1 || map snd ?tr1) (q2,q1) = ?st"
     by (metis (no_types) index_def scan_nth take_zip zip_map_fst_snd)
   ultimately have
      "target (?xs1 || map snd ?tr1) q1 = snd ?st"
      "target (?xs1 || map fst ?tr1) q2 = fst ?st"
     by simp+
 
   \<comment> \<open>paths for ?xs2\<close>
 
   have "(states (xs || tr) (q2, q1)) ! i2 \<in> io_targets PM (q2, q1) ?xs2"
     by (metis \<open>0 < length xs\<close> assms(6) assms(7) index_def map_snd_zip states_alt_def states_index_io_target)
   then have "io_targets PM (q2, q1) ?xs2 = {?st}"
     using obs_PM by (metis index_def observable_io_target_is_singleton)
 
   have "path PM (?xs2 || ?tr2) (q2,q1)"
     by (metis FSM.path_append_elim append_take_drop_id assms(6) assms(7) length_take zip_append)
   then have "path PM (?xs2 || map fst ?tr2 || map snd ?tr2) (q2,q1)"
     by auto
 
   have "vs @ ?xs2 \<in> L M2"
     by (metis (no_types) IntD2 append_assoc append_take_drop_id assms(8) language_state_prefix)
   then obtain q2'' where "io_targets M2 (initial M2) (vs@?xs2) = {q2''}"
     using io_targets_observable_singleton_ob[of M2 "vs@?xs2" "initial M2"] assms(4)
     by auto
   then have "q2'' \<in> io_targets M2 q2 ?xs2"
     using assms(4) \<open>io_targets M2 (initial M2) vs = {q2}\<close>
           observable_io_targets_split[of M2 "initial M2" vs ?xs2 q2'' q2]
     by simp
   then have "?xs2 \<in> language_state M2 q2"
     by auto
   moreover have "length ?xs2 = length (map snd ?tr2)" using assms(7)
     by auto
   moreover have "length (map fst ?tr2) = length (map snd ?tr2)"
     by auto
   moreover have "q2 \<in> nodes M2"
     using \<open>io_targets M2 (initial M2) vs = {q2}\<close> io_targets_nodes
     by (metis FSM.nodes.initial insertI1)
   moreover have "q1 \<in> nodes M1"
     using \<open>io_targets M1 (initial M1) vs = {q1}\<close> io_targets_nodes
     by (metis FSM.nodes.initial insertI1)
   ultimately have
      "path M1 (?xs2 || map snd ?tr2) q1"
      "path M2 (?xs2 || map fst ?tr2) q2"
      "target (?xs2 || map snd ?tr2) q1 = snd(target (?xs2 || map fst ?tr2 || map snd ?tr2) (q2,q1))"
      "target (?xs2 || map fst ?tr2) q2 = fst(target (?xs2 || map fst ?tr2 || map snd ?tr2) (q2,q1))"
     using assms(2) assms(9) assms(10) \<open>path PM (?xs2 || map fst ?tr2 || map snd ?tr2) (q2,q1)\<close>
           assms(4)
           productF_path_reverse_ob_2[of ?xs2 "map fst ?tr2" "map snd ?tr2" M2 M1 FAIL PM q2 q1]
     by simp+
   moreover have "target (?xs2 || map fst ?tr2 || map snd ?tr2) (q2,q1) = ?st"
     by (metis (no_types) index_def scan_nth take_zip zip_map_fst_snd)
   ultimately have
      "target (?xs2 || map snd ?tr2) q1 = snd ?st"
      "target (?xs2 || map fst ?tr2) q2 = fst ?st"
     by simp+
 
 
 
   have "io_targets M1 q1 ?xs1 = {snd ?st}"
     using \<open>path M1 (?xs1 || map snd ?tr1) q1\<close> \<open>target (?xs1 || map snd ?tr1) q1 = snd ?st\<close>
           \<open>length ?xs1 = length (map snd ?tr1)\<close> assms(3) obs_target_is_io_targets[of M1 ?xs1
           "map snd ?tr1" q1]
     by simp
   then have tgt_1_1 : "io_targets M1 (initial M1) (vs @ ?xs1) = {snd ?st}"
     by (meson \<open>io_targets M1 (initial M1) vs = {q1}\<close> assms(3) observable_io_targets_append)
 
   have "io_targets M2 q2 ?xs1 = {fst ?st}"
     using \<open>path M2 (?xs1 || map fst ?tr1) q2\<close> \<open>target (?xs1 || map fst ?tr1) q2 = fst ?st\<close>
           \<open>length ?xs1 = length (map snd ?tr1)\<close> assms(4)
           obs_target_is_io_targets[of M2 ?xs1 "map fst ?tr1" q2]
     by simp
   then have tgt_1_2 : "io_targets M2 (initial M2) (vs @ ?xs1) = {fst ?st}"
     by (meson \<open>io_targets M2 (initial M2) vs = {q2}\<close> assms(4) observable_io_targets_append)
 
   have "io_targets M1 q1 ?xs2 = {snd ?st}"
     using \<open>path M1 (?xs2 || map snd ?tr2) q1\<close> \<open>target (?xs2 || map snd ?tr2) q1 = snd ?st\<close>
           \<open>length ?xs2 = length (map snd ?tr2)\<close> assms(3)
           obs_target_is_io_targets[of M1 ?xs2 "map snd ?tr2" q1]
     by simp
   then have tgt_2_1 : "io_targets M1 (initial M1) (vs @ ?xs2) = {snd ?st}"
     by (meson \<open>io_targets M1 (initial M1) vs = {q1}\<close> assms(3) observable_io_targets_append)
 
   have "io_targets M2 q2 ?xs2 = {fst ?st}"
     using \<open>path M2 (?xs2 || map fst ?tr2) q2\<close> \<open>target (?xs2 || map fst ?tr2) q2 = fst ?st\<close>
           \<open>length ?xs2 = length (map snd ?tr2)\<close> assms(4)
           obs_target_is_io_targets[of M2 ?xs2 "map fst ?tr2" q2]
     by simp
   then have tgt_2_2 : "io_targets M2 (initial M2) (vs @ ?xs2) = {fst ?st}"
     by (meson \<open>io_targets M2 (initial M2) vs = {q2}\<close> assms(4) observable_io_targets_append)
 
   have "?xs1 \<noteq> []" using \<open>0 < length xs\<close>
     by auto
   have "prefix ?xs1 xs"
     using take_is_prefix by blast
   have "prefix ?xs2 xs"
     using take_is_prefix by blast
   have "?xs1 \<noteq> ?xs2"
   proof -
     have f1: "\<forall>n na. \<not> n < na \<or> Suc n \<le> na"
       by presburger
     have f2: "Suc i1 \<le> length xs"
       using index_def by force
     have "Suc i2 \<le> length xs"
       using f1 by (metis index_def length_take map_snd_zip_take min_less_iff_conj states_alt_def)
     then show ?thesis
       using f2 by (metis (no_types) index_def length_take min.absorb2 nat.simps(1))
   qed
   have "Rep_Pre M2 M1 vs xs"
   proof (cases "length ?xs1 < length ?xs2")
     case True
     then have "prefix ?xs1 ?xs2"
       by (meson \<open>prefix (take (Suc i1) xs) xs\<close> \<open>prefix (take (Suc i2) xs) xs\<close> leD prefix_length_le
           prefix_same_cases)
     show ?thesis
       by (meson Rep_Pre.elims(3) \<open>prefix (take (Suc i1) xs) (take (Suc i2) xs)\<close>
           \<open>prefix (take (Suc i2) xs) xs\<close> \<open>take (Suc i1) xs \<noteq> take (Suc i2) xs\<close>
           tgt_1_1 tgt_1_2 tgt_2_1 tgt_2_2)
   next
     case False
     moreover have "length ?xs1 \<noteq> length ?xs2"
       by (metis (no_types) \<open>take (Suc i1) xs \<noteq> take (Suc i2) xs\<close> append_eq_conv_conj
           append_take_drop_id)
     ultimately have "length ?xs2 < length ?xs1"
       by auto
     then have "prefix ?xs2 ?xs1"
       using \<open>prefix (take (Suc i1) xs) xs\<close> \<open>prefix (take (Suc i2) xs) xs\<close> less_imp_le_nat
             prefix_length_prefix
       by blast
     show ?thesis
       by (metis Rep_Pre.elims(3) \<open>prefix (take (Suc i1) xs) xs\<close>
           \<open>prefix (take (Suc i2) xs) (take (Suc i1) xs)\<close> \<open>take (Suc i1) xs \<noteq> take (Suc i2) xs\<close>
           tgt_1_1 tgt_1_2 tgt_2_1 tgt_2_2)
   qed
 
   then show "False"
     using assms(1) by simp
 qed
 
 
 
 
 
 lemma RP_count_via_Rep_Cov :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "s \<in> nodes M2"
   and "productF M2 M1 FAIL PM"
   and "io_targets PM (initial PM) vs = {(q2,q1)}"
   and "path PM (xs || tr) (q2,q1)"
   and "length xs = length tr"
   and "distinct (states (xs || tr) (q2,q1))"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "\<not> Rep_Cov M2 M1 V'' vs xs"
 shows "card (\<Union>(image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) = card (RP M2 s vs xs V'')"
 proof -
   have RP_cases : "RP M2 s vs xs V'' = R M2 s vs xs
                     \<or> (\<exists> vs' \<in> V'' . vs' \<notin> R M2 s vs xs
                                       \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs))"
     using RP_from_R assms by metis
   show ?thesis
   proof (cases "RP M2 s vs xs V'' = R M2 s vs xs")
     case True
     then show ?thesis
       using R_count assms by metis
   next
     case False
     then obtain vs' where vs'_def : "vs' \<in> V''
                                       \<and> vs' \<notin> R M2 s vs xs
                                       \<and> RP M2 s vs xs V'' = insert vs' (R M2 s vs xs)"
       using RP_cases by auto
 
     have state_component_2 : "\<forall> io \<in> (R M2 s vs xs) . io_targets M2 (initial M2) io = {s}"
     proof
       fix io assume "io \<in> R M2 s vs xs"
       then have "s \<in> io_targets M2 (initial M2) io"
         by auto
       moreover have "io \<in> language_state M2 (initial M2)"
         using calculation by auto
       ultimately show "io_targets M2 (initial M2) io = {s}"
         using assms(3) io_targets_observable_singleton_ex by (metis singletonD)
     qed
 
     have "vs' \<in> L M1"
       using assms(13) perm_language vs'_def by blast
     then obtain s' where s'_def : "io_targets M1 (initial M1) vs' = {s'}"
       by (meson assms(2) io_targets_observable_singleton_ob)
 
     moreover have "s' \<notin> \<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))"
     proof (rule ccontr)
       assume "\<not> s' \<notin> \<Union>(io_targets M1 (initial M1) ` R M2 s vs xs)"
       then obtain xs' where xs'_def : "vs @ xs' \<in> R M2 s vs xs
                                         \<and> s' \<in> io_targets M1 (initial M1) (vs @ xs')"
       proof -
         assume a1: "\<And>xs'. vs @ xs' \<in> R M2 s vs xs
                           \<and> s' \<in> io_targets M1 (initial M1) (vs @ xs') \<Longrightarrow> thesis"
         obtain pps :: "('a \<times> 'b) list set \<Rightarrow> (('a \<times> 'b) list \<Rightarrow> 'c set) \<Rightarrow> 'c \<Rightarrow> ('a \<times> 'b) list"
           where
           "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x0 \<and> x2 \<in> x1 v3) = (pps x0 x1 x2 \<in> x0 \<and> x2 \<in> x1 (pps x0 x1 x2))"
           by moura
         then have f2: "pps (R M2 s vs xs) (io_targets M1 (initial M1)) s' \<in> R M2 s vs xs
                         \<and> s' \<in> io_targets M1 (initial M1)
                                               (pps (R M2 s vs xs) (io_targets M1 (initial M1)) s')"
           using \<open>\<not> s' \<notin> \<Union>(io_targets M1 (initial M1) ` R M2 s vs xs)\<close> by blast
         then have "\<exists>ps. pps (R M2 s vs xs) (io_targets M1 (initial M1)) s' = vs @ ps \<and> ps \<noteq> []
                         \<and> prefix ps xs \<and> s \<in> io_targets M2 (initial M2) (vs @ ps)"
           by simp
         then show ?thesis
           using f2 a1 by (metis (no_types))
       qed
 
       have "vs @ xs' \<in> L M1"
         using xs'_def by blast
       then have "io_targets M1 (initial M1) (vs@xs') = {s'}"
         by (metis assms(2) io_targets_observable_singleton_ob singletonD xs'_def)
       moreover have "io_targets M1 (initial M1) (vs') = {s'}"
         using s'_def by blast
       moreover have "io_targets M2 (initial M2) (vs @ xs') = {s}"
         using state_component_2 xs'_def by blast
       moreover have "io_targets M2 (initial M2) (vs') = {s}"
         by (metis (mono_tags, lifting) RP.simps Un_iff insertI1 mem_Collect_eq vs'_def)
       moreover have "xs' \<noteq> []"
         using xs'_def by simp
       moreover have "prefix xs' xs"
         using xs'_def by simp
       moreover have "vs' \<in> V''"
         using vs'_def by simp
       ultimately have "Rep_Cov M2 M1 V'' vs xs"
         by auto
 
       then show "False"
         using assms(14) by simp
     qed
 
     moreover have "\<Union> (image (io_targets M1 (initial M1)) (insert vs' (R M2 s vs xs)))
                     = insert s' (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs)))"
       using s'_def by simp
 
     moreover have "finite (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs)))"
     proof
       show "finite (R M2 s vs xs)"
         using finite_R by simp
       show "\<And>a. a \<in> R M2 s vs xs \<Longrightarrow> finite (io_targets M1 (initial M1) a)"
       proof -
         fix a assume "a \<in> R M2 s vs xs"
         then have "prefix a (vs@xs)"
           by auto
         then have "a \<in> L M1"
           using language_state_prefix by (metis IntD1 assms(1) prefix_def)
         then obtain p where "io_targets M1 (initial M1) a = {p}"
           using assms(2) io_targets_observable_singleton_ob by metis
         then show "finite (io_targets M1 (initial M1) a)"
           by simp
       qed
     qed
 
     ultimately have "card (\<Union> (image (io_targets M1 (initial M1)) (insert vs' (R M2 s vs xs))))
                       = Suc (card (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))))"
       by (metis (no_types) card_insert_disjoint)
 
 
     moreover have "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))
                     = card (\<Union> (image (io_targets M1 (initial M1)) (insert vs' (R M2 s vs xs))))"
       using vs'_def by simp
 
     ultimately have "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))
                       = Suc (card (\<Union> (image (io_targets M1 (initial M1)) (R M2 s vs xs))))"
       by linarith
 
     then have "card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))
                   = Suc (card (R M2 s vs xs))"
       using R_count[of vs xs M1 M2 s FAIL PM q2 q1 tr] using assms(1,10,11,2-9)
       by linarith
 
     moreover have "card (RP M2 s vs xs V'') = Suc (card (R M2 s vs xs))"
       using vs'_def by (metis card_insert_if finite_R)
 
     ultimately show ?thesis
       by linarith
   qed
 qed
 
 
 lemma RP_count_alt_def :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "s \<in> nodes M2"
   and "productF M2 M1 FAIL PM"
   and "io_targets PM (initial PM) vs = {(q2,q1)}"
   and "path PM (xs || tr) (q2,q1)"
   and "length xs = length tr"
   and "\<not> Rep_Pre M2 M1 vs xs"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "\<not> Rep_Cov M2 M1 V'' vs xs"
 shows "card (\<Union>(image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) = card (RP M2 s vs xs V'')"
 proof -
   have "distinct (states (xs || tr) (q2,q1))"
     using distinctness_via_Rep_Pre[of M2 M1 vs xs FAIL PM q2 q1 tr] assms by simp
   then show ?thesis
     using RP_count_via_Rep_Cov[of vs xs M1 M2 s FAIL PM q2 q1 tr V V'']
     using assms(1,10,12-14,2-9) by blast
 qed
 
 
 
 
 subsection \<open> Function LB \<close>
 
 text \<open>
 @{verbatim LB} adds together the number of elements in sets calculated via RP for a given set of
 states and the number of ATC-reaction known to exist but not produced by a state reached by any of
 the above elements.
 \<close>
 
 fun LB :: "('in, 'out, 'state1) FSM \<Rightarrow> ('in, 'out, 'state2) FSM
           \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> 'in list set
           \<Rightarrow> 'state1 set \<Rightarrow> ('in, 'out) ATC set
           \<Rightarrow> ('in \<times> 'out) list set \<Rightarrow> nat"
   where
   "LB M2 M1 vs xs T S \<Omega> V'' =
     (sum (\<lambda> s . card (RP M2 s vs xs V'')) S)
     + card ((D M1 T \<Omega>) -
             {B M1 xs' \<Omega> | xs' s' . s' \<in> S \<and> xs' \<in> RP M2 s' vs xs V''})"
 
 
 
 lemma LB_count_helper_RP_disjoint_and_cards :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "productF M2 M1 FAIL PM"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "s1 \<noteq> s2"
 shows "\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V''))
         \<inter> \<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V'')) = {}"
       "card (\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V'')))
         = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V'')))"
       "card (\<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V'')))
         = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')))"
 proof -
   have "\<forall> io \<in> RP M2 s1 vs xs V'' . io_targets PM (initial PM) io
                                       = {s1} \<times> io_targets M1 (initial M1) io"
   proof
     fix io assume "io \<in> RP M2 s1 vs xs V''"
     then have "io_targets PM (initial PM) io
                 = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
       using assms RP_io_targets_split[of vs xs M1 M2 FAIL PM V V'' io s1] by simp
     moreover have "io_targets M2 (initial M2) io = {s1}"
       using \<open>io \<in> RP M2 s1 vs xs V''\<close> assms(3) RP_state_component_2[of io M2 s1 vs xs V'']
       by blast
     ultimately show "io_targets PM (initial PM) io = {s1} \<times> io_targets M1 (initial M1) io"
       by auto
   qed
   then have "\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V''))
               = \<Union> (image (\<lambda> io . {s1} \<times> io_targets M1 (initial M1) io) (RP M2 s1 vs xs V''))"
     by simp
   moreover have "\<Union> (image (\<lambda> io . {s1} \<times> io_targets M1 (initial M1) io) (RP M2 s1 vs xs V''))
                   = {s1} \<times> \<Union> (image (\<lambda> io . io_targets M1 (initial M1) io) (RP M2 s1 vs xs V''))"
     by blast
   ultimately have image_split_1 :
     "\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V'') )
       = {s1} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V''))"
     by simp
   then show "card (\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V'')))
               = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V'')))"
     by (metis (no_types)  card_cartesian_product_singleton)
 
 
 
 
   have "\<forall> io \<in> RP M2 s2 vs xs V'' . io_targets PM (initial PM) io
                                       = {s2} \<times> io_targets M1 (initial M1) io"
   proof
     fix io assume "io \<in> RP M2 s2 vs xs V''"
     then have "io_targets PM (initial PM) io
                   = io_targets M2 (initial M2) io \<times> io_targets M1 (initial M1) io"
       using assms RP_io_targets_split[of vs xs M1 M2 FAIL PM V V'' io s2] by simp
     moreover have "io_targets M2 (initial M2) io = {s2}"
       using \<open>io \<in> RP M2 s2 vs xs V''\<close> assms(3) RP_state_component_2[of io M2 s2 vs xs V'']
       by blast
     ultimately show "io_targets PM (initial PM) io = {s2} \<times> io_targets M1 (initial M1) io"
       by auto
   qed
   then have "\<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V''))
               = \<Union> (image (\<lambda> io . {s2} \<times> io_targets M1 (initial M1) io) (RP M2 s2 vs xs V''))"
     by simp
   moreover have "\<Union> (image (\<lambda> io . {s2} \<times> io_targets M1 (initial M1) io) (RP M2 s2 vs xs V''))
                   = {s2} \<times> \<Union> (image (\<lambda> io . io_targets M1 (initial M1) io) (RP M2 s2 vs xs V''))"
     by blast
   ultimately have image_split_2 :
     "\<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V''))
       = {s2} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V''))" by simp
   then show "card (\<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V'')))
               = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')))"
     by (metis (no_types)  card_cartesian_product_singleton)
 
 
   have "\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V''))
           \<inter> \<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V''))
         = {s1} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V''))
           \<inter> {s2} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V''))"
     using image_split_1 image_split_2 by blast
   moreover have "{s1} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V''))
                   \<inter> {s2} \<times> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')) = {}"
     using assms(9) by auto
   ultimately show "\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V''))
                     \<inter> \<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V'')) = {}"
     by presburger
 qed
 
 
 lemma LB_count_helper_RP_disjoint_card_M1 :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "productF M2 M1 FAIL PM"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "s1 \<noteq> s2"
 shows "card (\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V''))
               \<union> \<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V'')))
        = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V'')))
           + card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')))"
 proof -
   have "finite (\<Union> (image (io_targets PM (initial PM)) (RP M2 s1 vs xs V'')))"
     using RP_io_targets_finite_PM[OF assms(1-8)] by simp
   moreover have "finite (\<Union> (image (io_targets PM (initial PM)) (RP M2 s2 vs xs V'')))"
     using RP_io_targets_finite_PM[OF assms(1-8)] by simp
   ultimately show ?thesis
     using LB_count_helper_RP_disjoint_and_cards[OF assms]
     by (metis (no_types) card_Un_disjoint)
 qed
 
 lemma LB_count_helper_RP_disjoint_M1_pair :
   assumes "(vs @ xs) \<in> L M1 \<inter> L M2"
   and "observable M1"
   and "observable M2"
   and "well_formed M1"
   and "well_formed M2"
   and "productF M2 M1 FAIL PM"
   and "io_targets PM (initial PM) vs = {(q2,q1)}"
   and "path PM (xs || tr) (q2,q1)"
   and "length xs = length tr"
   and "\<not> Rep_Pre M2 M1 vs xs"
   and "is_det_state_cover M2 V"
   and "V'' \<in> Perm V M1"
   and "\<not> Rep_Cov M2 M1 V'' vs xs"
   and "Prereq M2 M1 vs xs T S \<Omega> V''"
   and "s1 \<noteq> s2"
   and "s1 \<in> S"
   and "s2 \<in> S"
   and "applicable_set M1 \<Omega>"
   and "completely_specified M1"
 shows "card (RP M2 s1 vs xs V'') + card (RP M2 s2 vs xs V'')
         = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V'')))
           + card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')))"
       "\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V''))
           \<inter> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V''))
         = {}"
 proof -
   have "s1 \<in> nodes M2"
     using assms(14,16) unfolding Prereq.simps by blast
   have "s2 \<in> nodes M2"
     using assms(14,17) unfolding Prereq.simps by blast
   have "card (RP M2 s1 vs xs V'')
           = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V'')))"
     using RP_count_alt_def[OF assms(1-5) \<open>s1 \<in> nodes M2\<close> assms(6-13)]
     by linarith
   moreover have "card (RP M2 s2 vs xs V'')
                   = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')))"
     using RP_count_alt_def[OF assms(1-5) \<open>s2 \<in> nodes M2\<close> assms(6-13)]
     by linarith
 
   moreover show "\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V''))
                   \<inter> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')) = {}"
   proof (rule ccontr)
     assume "\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V''))
               \<inter> \<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')) \<noteq> {}"
     then obtain io1 io2 t where shared_elem_def :
       "io1 \<in> (RP M2 s1 vs xs V'')"
       "io2 \<in> (RP M2 s2 vs xs V'')"
       "t \<in> io_targets M1 (initial M1) io1"
       "t \<in> io_targets M1 (initial M1) io2"
       by blast
 
 
     have dist_prop: "(\<forall> s1 \<in> S . \<forall> s2 \<in> S . s1 \<noteq> s2
             \<longrightarrow> (\<forall> io1 \<in> RP M2 s1 vs xs V'' .
                        \<forall> io2 \<in> RP M2 s2 vs xs V'' .
                          B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> ))"
       using assms(14) by simp
 
     have "io_targets M1 (initial M1) io1 \<inter> io_targets M1 (initial M1) io2 = {}"
     proof (rule ccontr)
       assume "io_targets M1 (initial M1) io1 \<inter> io_targets M1 (initial M1) io2 \<noteq> {}"
       then have "io_targets M1 (initial M1) io1 \<noteq> {}" "io_targets M1 (initial M1) io2 \<noteq> {}"
         by blast+
 
       then obtain s1 s2 where "s1 \<in> io_targets M1 (initial M1) io1"
                               "s2 \<in> io_targets M1 (initial M1) io2"
         by blast
 
       then have "io_targets M1 (initial M1) io1 = {s1}"
                 "io_targets M1 (initial M1) io2 = {s2}"
         by (meson assms(2) observable_io_target_is_singleton)+
 
       then have "s1 = s2"
         using \<open>io_targets M1 (initial M1) io1 \<inter> io_targets M1 (initial M1) io2 \<noteq> {}\<close>
         by auto
 
       then have "B M1 io1 \<Omega> = B M1 io2 \<Omega>"
         using \<open>io_targets M1 (initial M1) io1 = {s1}\<close> \<open>io_targets M1 (initial M1) io2 = {s2}\<close>
         by auto
       then show "False"
         using assms(15-17) dist_prop shared_elem_def(1,2) by blast
     qed
     then show "False"
       using shared_elem_def(3,4) by blast
   qed
 
   ultimately show "card (RP M2 s1 vs xs V'') + card (RP M2 s2 vs xs V'')
        = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s1 vs xs V'')))
           + card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s2 vs xs V'')))"
     by linarith
 qed
 
 
 
 
 
 
 lemma LB_count_helper_RP_card_union :
   assumes "observable M2"
   and     "s1 \<noteq> s2"
 shows "RP M2 s1 vs xs V'' \<inter> RP M2 s2 vs xs V'' = {}"
 proof (rule ccontr)
   assume "RP M2 s1 vs xs V'' \<inter> RP M2 s2 vs xs V'' \<noteq> {}"
   then obtain io where "io \<in> RP M2 s1 vs xs V'' \<and> io \<in> RP M2 s2 vs xs V''"
     by blast
   then have "s1 \<in> io_targets M2 (initial M2) io"
             "s2 \<in> io_targets M2 (initial M2) io"
     by auto
   then have "s1 = s2"
     using assms(1) by (metis observable_io_target_is_singleton singletonD)
   then show "False"
     using assms(2) by simp
 qed
 
 
 
 lemma LB_count_helper_RP_inj :
 obtains f
 where "\<forall> q \<in> (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S)) .
           f q \<in> nodes M1"
       "inj_on f (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S))"
 proof -
   let ?f =
     "\<lambda> q . if (q \<in> (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S)))
       then q
       else (initial M1)"
 
   have "(\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S)) \<subseteq> nodes M1"
     by blast
 
   then have "\<forall> q \<in> (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S)) .
               ?f q \<in> nodes M1"
     by (metis Un_iff  sup.order_iff)
 
   moreover have "inj_on ?f (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1))
                                                       (RP M2 s vs xs V''))) S))"
   proof
     fix x assume "x \<in> (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S))"
     then have "?f x = x"
       by presburger
 
     fix y assume "y \<in> (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S))"
     then have "?f y = y"
       by presburger
 
     assume "?f x = ?f y"
     then show "x = y" using \<open>?f x = x\<close> \<open>?f y = y\<close>
       by presburger
   qed
 
   ultimately show ?thesis
     using that by presburger
 qed
 
 abbreviation (input) UNION :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set"
   where "UNION A f \<equiv> \<Union> (f ` A)"
 
 
 lemma LB_count_helper_RP_card_union_sum :
   assumes "(vs @ xs) \<in> L M2 \<inter> L M1"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> Perm V M1"
   and     "Prereq M2 M1 vs xs T S \<Omega> V''"
   and     "\<not> Rep_Pre M2 M1 vs xs"
   and     "\<not> Rep_Cov M2 M1 V'' vs xs"
 shows "sum (\<lambda> s . card (RP M2 s vs xs V'')) S
         = sum (\<lambda> s . card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))) S"
 using assms proof -
   have "finite (nodes M2)"
     using assms(3) by auto
   moreover have "S \<subseteq> nodes M2"
     using assms(7) by simp
   ultimately have "finite S"
     using infinite_super by blast
 
   then have "sum (\<lambda> s . card (RP M2 s vs xs V'')) S
               = sum (\<lambda> s . card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))) S"
   using assms proof (induction S)
     case empty
     show ?case by simp
   next
     case (insert s S)
 
     have "(insert s S) \<subseteq> nodes M2"
       using insert.prems(7) by simp
     then have "s \<in> nodes M2"
       by simp
 
     have "Prereq M2 M1 vs xs T S \<Omega> V''"
       using \<open>Prereq M2 M1 vs xs T (insert s S) \<Omega> V''\<close> by simp
     then have "(\<Sum>s\<in>S. card (RP M2 s vs xs V''))
                 = (\<Sum>s\<in>S. card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a))"
       using insert.IH[OF insert.prems(1-6) _ assms(8,9)] by metis
     moreover have "(\<Sum>s'\<in>(insert s S). card (RP M2 s' vs xs V''))
                     = (\<Sum>s'\<in>S. card (RP M2 s' vs xs V'')) + card (RP M2 s vs xs V'')"
       by (simp add: add.commute insert.hyps(1) insert.hyps(2))
     ultimately have S_prop : "(\<Sum>s'\<in>(insert s S). card (RP M2 s' vs xs V''))
                                = (\<Sum>s\<in>S. card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a))
                                   + card (RP M2 s vs xs V'')"
       by presburger
 
     have "vs@xs \<in> L M1 \<inter> L M2"
       using insert.prems(1) by simp
 
     obtain q2 q1 tr where suffix_path : "io_targets PM (initial PM) vs = {(q2,q1)}"
                           "path PM (xs || tr) (q2,q1)"
                           "length xs = length tr"
       using productF_language_state_intermediate[OF insert.prems(1)
             test_tools_props(1)[OF insert.prems(5,4)] OFSM_props(2,1)[OF insert.prems(3)]
                                     OFSM_props(2,1)[OF insert.prems(2)]]
       by blast
 
 
 
     have "card (RP M2 s vs xs V'')
             = card (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V'')))"
       using OFSM_props(2,1)[OF insert.prems(3)] OFSM_props(2,1)[OF insert.prems(2)]
             RP_count_alt_def[OF \<open>vs@xs \<in> L M1 \<inter> L M2\<close> _ _ _ _
                                 \<open>s\<in>nodes M2\<close> test_tools_props(1)[OF insert.prems(5,4)]
                                 suffix_path insert.prems(8)
                                 test_tools_props(2)[OF insert.prems(5,4)] assms(6) insert.prems(9)]
       by linarith
 
     show "(\<Sum>s\<in>insert s S. card (RP M2 s vs xs V'')) =
                   (\<Sum>s\<in>insert s S. card (UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1))))"
     proof -
       have "(\<Sum>c\<in>insert s S. card (UNION (RP M2 c vs xs V'') (io_targets M1 (initial M1))))
             = card (UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1)))
               + (\<Sum>c\<in>S. card (UNION (RP M2 c vs xs V'') (io_targets M1 (initial M1))))"
         by (meson insert.hyps(1) insert.hyps(2) sum.insert)
       then show ?thesis
         using \<open>(\<Sum>s'\<in>insert s S. card (RP M2 s' vs xs V''))
                 = (\<Sum>s\<in>S. card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a))
                     + card (RP M2 s vs xs V'')\<close>
               \<open>card (RP M2 s vs xs V'')
                 = card (UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1)))\<close>
         by presburger
     qed
   qed
 
   then show ?thesis
     using assms by blast
 qed
 
 
 lemma finite_insert_card :
   assumes "finite (\<Union>SS)"
   and     "finite S"
   and     "S \<inter> (\<Union>SS) = {}"
 shows "card (\<Union> (insert S SS)) = card (\<Union>SS) + card S"
   by (simp add: assms(1) assms(2) assms(3) card_Un_disjoint)
 
 lemma LB_count_helper_RP_disjoint_M1_union :
   assumes "(vs @ xs) \<in> L M2 \<inter> L M1"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> Perm V M1"
   and     "Prereq M2 M1 vs xs T S \<Omega> V''"
   and     "\<not> Rep_Pre M2 M1 vs xs"
   and     "\<not> Rep_Cov M2 M1 V'' vs xs"
 shows "sum (\<lambda> s . card (RP M2 s vs xs V'')) S
         = card (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S))"
 using assms proof -
   have "finite (nodes M2)"
     using assms(3) by auto
   moreover have "S \<subseteq> nodes M2"
     using assms(7) by simp
   ultimately have "finite S"
     using infinite_super by blast
 
   then show "sum (\<lambda> s . card (RP M2 s vs xs V'')) S
               = card (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S))"
   using assms proof (induction S)
     case empty
     show ?case by simp
   next
     case (insert s S)
 
     have "(insert s S) \<subseteq> nodes M2"
       using insert.prems(7) by simp
     then have "s \<in> nodes M2"
       by simp
 
     have "Prereq M2 M1 vs xs T S \<Omega> V''"
       using \<open>Prereq M2 M1 vs xs T (insert s S) \<Omega> V''\<close> by simp
     then have applied_IH : "(\<Sum>s\<in>S. card (RP M2 s vs xs V''))
                               = card (\<Union>s\<in>S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)"
       using insert.IH[OF insert.prems(1-6) _ insert.prems(8,9)] by metis
 
     obtain q2 q1 tr where suffix_path : "io_targets PM (initial PM) vs = {(q2,q1)}"
                               "path PM (xs || tr) (q2,q1)"
                               "length xs = length tr"
       using productF_language_state_intermediate
             [OF insert.prems(1) test_tools_props(1)[OF insert.prems(5,4)]
                 OFSM_props(2,1)[OF insert.prems(3)] OFSM_props(2,1)[OF insert.prems(2)]]
       by blast
 
     have "s \<in> insert s S"
       by simp
 
     have "vs@xs \<in> L M1 \<inter> L M2"
       using insert.prems(1) by simp
 
     have "\<forall> s' \<in> S . (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
                         \<inter> (\<Union>a\<in>RP M2 s' vs xs V''. io_targets M1 (initial M1) a) = {}"
     proof
       fix s' assume "s' \<in> S"
 
       have "s \<noteq> s'"
         using insert.hyps(2) \<open>s' \<in> S\<close> by blast
       have "s' \<in> insert s S"
         using \<open>s' \<in> S\<close> by simp
 
       show "(\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
               \<inter> (\<Union>a\<in>RP M2 s' vs xs V''. io_targets M1 (initial M1) a) = {}"
         using OFSM_props(2,1)[OF assms(3)] OFSM_props(2,1,3)[OF assms(2)]
               LB_count_helper_RP_disjoint_M1_pair(2)
                 [OF \<open>vs@xs \<in> L M1 \<inter> L M2\<close> _ _ _ _ test_tools_props(1)[OF insert.prems(5,4)]
                     suffix_path insert.prems(8) test_tools_props(2)[OF insert.prems(5,4)]
                     insert.prems(6,9,7) \<open>s \<noteq> s'\<close> \<open>s \<in> insert s S\<close> \<open>s' \<in> insert s S\<close>
                     test_tools_props(4)[OF insert.prems(5,4)]]
         by linarith
     qed
     then have disj_insert : "(\<Union>s\<in>S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
                                 \<inter> (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a) = {}"
       by blast
     have finite_S : "finite (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)"
       using RP_io_targets_finite_M1[OF insert.prems(1)]
       by (meson RP_io_targets_finite_M1 \<open>vs @ xs \<in> L M1 \<inter> L M2\<close> assms(2) assms(5) insert.prems(6))
     have finite_s : "finite (\<Union>s\<in>S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)"
       by (meson RP_io_targets_finite_M1 \<open>vs @ xs \<in> L M1 \<inter> L M2\<close> assms(2) assms(5)
           finite_UN_I insert.hyps(1) insert.prems(6))
 
 
     have "card (\<Union>s\<in>insert s S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
           = card (\<Union>s\<in>S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
             + card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)"
     proof -
       have f1: "insert (UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1)))
                     ((\<lambda>c. UNION (RP M2 c vs xs V'') (io_targets M1 (initial M1))) ` S)
                 = (\<lambda>c. UNION (RP M2 c vs xs V'') (io_targets M1 (initial M1))) ` insert s S"
         by blast
       have "\<forall>c. c \<in> S \<longrightarrow> UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1))
                           \<inter> UNION (RP M2 c vs xs V'') (io_targets M1 (initial M1)) = {}"
         by (meson \<open>\<forall>s'\<in>S. (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
                               \<inter> (\<Union>a\<in>RP M2 s' vs xs V''. io_targets M1 (initial M1) a) = {}\<close>)
       then have "UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1))
                   \<inter> (\<Union>c\<in>S. UNION (RP M2 c vs xs V'') (io_targets M1 (initial M1))) = {}"
         by blast
       then show ?thesis
         using f1 by (metis finite_S finite_insert_card finite_s)
     qed
 
     have "card (RP M2 s vs xs V'')
           = card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)"
       using assms(2) assms(3)
             RP_count_alt_def[OF \<open>vs@xs \<in> L M1 \<inter> L M2\<close> _ _ _ _ \<open>s \<in> nodes M2\<close>
                                 test_tools_props(1)[OF insert.prems(5,4)] suffix_path
                                 insert.prems(8) test_tools_props(2)[OF insert.prems(5,4)]
                                 insert.prems(6,9)]
       by metis
 
     show ?case
     proof -
       have "(\<Sum>c\<in>insert s S. card (RP M2 c vs xs V''))
               = card (RP M2 s vs xs V'') + (\<Sum>c\<in>S. card (RP M2 c vs xs V''))"
         by (meson insert.hyps(1) insert.hyps(2) sum.insert)
       then show ?thesis
         using \<open>card (RP M2 s vs xs V'')
                 = card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)\<close>
               \<open>card (\<Union>s\<in>insert s S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
                 = card (\<Union>s\<in>S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)
                   + card (\<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a)\<close> applied_IH
         by presburger
     qed
   qed
 qed
 
 
 
 
 
 lemma LB_count_helper_LB1 :
   assumes "(vs @ xs) \<in> L M2 \<inter> L M1"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> Perm V M1"
   and     "Prereq M2 M1 vs xs T S \<Omega> V''"
   and     "\<not> Rep_Pre M2 M1 vs xs"
   and     "\<not> Rep_Cov M2 M1 V'' vs xs"
 shows "(sum (\<lambda> s . card (RP M2 s vs xs V'')) S) \<le> card (nodes M1)"
 proof -
   have "(\<Union>s\<in>S. UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1))) \<subseteq> nodes M1"
     by blast
   moreover have "finite (nodes M1)"
     using assms(2) OFSM_props(1) unfolding well_formed.simps finite_FSM.simps by simp
   ultimately have "card (\<Union>s\<in>S. UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1)))
                     \<le> card (nodes M1)"
     by (meson card_mono)
 
   moreover have "(\<Sum>s\<in>S. card (RP M2 s vs xs V''))
                     = card (\<Union>s\<in>S. UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1)))"
     using LB_count_helper_RP_disjoint_M1_union[OF assms]
     by linarith
 
   ultimately show ?thesis
     by linarith
 qed
 
 
 
 
 lemma LB_count_helper_D_states :
   assumes "observable M"
   and     "RS \<in> (D M T \<Omega>)"
 obtains q
 where "q \<in> nodes M \<and> RS = IO_set M q \<Omega>"
 proof -
   have "RS \<in> image (\<lambda> io . B M io \<Omega>) (LS\<^sub>i\<^sub>n M (initial M) T)"
     using assms by simp
   then obtain io where "RS = B M io \<Omega>" "io \<in> LS\<^sub>i\<^sub>n M (initial M) T"
     by blast
   then have "io \<in> language_state M (initial M)"
     using language_state_for_inputs_in_language_state[of M "initial M" T] by blast
   then obtain q where "{q} = io_targets M (initial M) io"
     by (metis assms(1) io_targets_observable_singleton_ob)
   then have "B M io \<Omega> = \<Union> (image (\<lambda> s . IO_set M s \<Omega>) {q})"
     by simp
   then have "B M io \<Omega> = IO_set M q \<Omega>"
     by simp
   then have "RS = IO_set M q \<Omega>" using \<open>RS = B M io \<Omega>\<close>
     by simp
   moreover have "q \<in> nodes M" using \<open>{q} = io_targets M (initial M) io\<close>
     by (metis FSM.nodes.initial insertI1 io_targets_nodes)
   ultimately show ?thesis
     using that by simp
 qed
 
 
 lemma LB_count_helper_LB2 :
   assumes "observable M1"
   and     "IO_set M1 q \<Omega> \<in> (D M1 T \<Omega>) - {B M1 xs' \<Omega> | xs' s' . s' \<in> S \<and> xs' \<in> RP M2 s' vs xs V''}"
 shows "q \<notin> (\<Union> (image (\<lambda> s . \<Union> (image (io_targets M1 (initial M1)) (RP M2 s vs xs V''))) S))"
 proof
   assume "q \<in> (\<Union>s\<in>S. UNION (RP M2 s vs xs V'') (io_targets M1 (initial M1)))"
   then obtain s' where "s' \<in> S" "q \<in> (\<Union> (image (io_targets M1 (initial M1)) (RP M2 s' vs xs V'')))"
     by blast
   then obtain xs' where "q \<in> io_targets M1 (initial M1) xs'" "xs' \<in> RP M2 s' vs xs V''"
     by blast
   then have "{q} = io_targets M1 (initial M1) xs'"
     by (metis assms(1) observable_io_target_is_singleton)
   then have "B M1 xs' \<Omega> = \<Union> (image (\<lambda> s . IO_set M1 s \<Omega>) {q})"
     by simp
   then have "B M1 xs' \<Omega> = IO_set M1 q \<Omega>"
     by simp
   moreover have "B M1 xs' \<Omega> \<in> {B M1 xs' \<Omega> | xs' s' . s' \<in> S \<and> xs' \<in> RP M2 s' vs xs V''}"
     using \<open>s' \<in> S\<close> \<open>xs' \<in> RP M2 s' vs xs V''\<close> by blast
   ultimately have "IO_set M1 q \<Omega> \<in> {B M1 xs' \<Omega> | xs' s' . s' \<in> S \<and> xs' \<in> RP M2 s' vs xs V''}"
     by blast
   moreover have "IO_set M1 q \<Omega> \<notin> {B M1 xs' \<Omega> | xs' s' . s' \<in> S \<and> xs' \<in> RP M2 s' vs xs V''}"
     using assms(2) by blast
   ultimately show "False"
     by simp
 qed
 
 
 
 
 subsection \<open> Validity of the result of LB constituting a lower bound \<close>
 
 
 lemma LB_count :
 assumes "(vs @ xs) \<in> L M1"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> Perm V M1"
   and     "Prereq M2 M1 vs xs T S \<Omega> V''"
   and     "\<not> Rep_Pre M2 M1 vs xs"
   and     "\<not> Rep_Cov M2 M1 V'' vs xs"
 shows "LB M2 M1 vs xs T S \<Omega> V'' \<le> |M1|"
 proof -
 
   let ?D = "D M1 T \<Omega>"
   let ?B = "{B M1 xs' \<Omega> | xs' s' . s' \<in> S \<and> xs' \<in> RP M2 s' vs xs V''}"
   let ?DB = "?D - ?B"
   let ?RP = "\<Union>s\<in>S. \<Union>a\<in>RP M2 s vs xs V''. io_targets M1 (initial M1) a"
 
   have "finite (nodes M1)"
     using OFSM_props[OF assms(2)] unfolding well_formed.simps finite_FSM.simps by simp
   then have "finite ?D"
     using OFSM_props[OF assms(2)] assms(7) D_bound[of M1 T \<Omega>] unfolding Prereq.simps by linarith
   then have "finite ?DB"
     by simp
 
   \<comment> \<open>Proof sketch:
       Construct a function f (via induction) that maps each response set in ?DB to some state
       that produces that response set.
       This is then used to show that each response sets in ?DB indicates the existence of
       a distinct state in M1 not reached via the RP-sequences.\<close>
 
   have states_f : "\<And> DB' . DB' \<subseteq> ?DB \<Longrightarrow> \<exists> f . inj_on f DB'
                                                 \<and> image f DB' \<subseteq> (nodes M1) - ?RP
                                                 \<and> (\<forall> RS \<in> DB' . IO_set M1 (f RS) \<Omega> = RS)"
   proof -
     fix DB' assume "DB' \<subseteq> ?DB"
     have "finite DB'"
     proof (rule ccontr)
       assume "infinite DB'"
       have "infinite ?DB"
         using infinite_super[OF \<open>DB' \<subseteq> ?DB\<close> \<open>infinite DB'\<close> ] by simp
       then show "False"
         using \<open>finite ?DB\<close> by simp
     qed
     then show "\<exists> f . inj_on f DB' \<and> image f DB' \<subseteq> (nodes M1) - ?RP
                                   \<and> (\<forall> RS \<in> DB' . IO_set M1 (f RS) \<Omega> = RS)"
     using assms \<open>DB' \<subseteq> ?DB\<close> proof (induction DB')
       case empty
       show ?case by simp
     next
       case (insert RS DB')
 
       have "DB' \<subseteq> ?DB"
         using insert.prems(10) by blast
       obtain f' where "inj_on f' DB'"
                       "image f' DB' \<subseteq> (nodes M1) - ?RP"
                       "\<forall> RS \<in> DB' . IO_set M1 (f' RS) \<Omega> = RS"
         using insert.IH[OF insert.prems(1-9) \<open>DB' \<subseteq> ?DB\<close>]
         by blast
 
       have "RS \<in> D M1 T \<Omega>"
         using insert.prems(10) by blast
       obtain q where "q \<in> nodes M1" "RS = IO_set M1 q \<Omega>"
         using insert.prems(2)  LB_count_helper_D_states[OF _ \<open>RS \<in> D M1 T \<Omega>\<close>]
         by blast
       then have "IO_set M1 q \<Omega> \<in> ?DB"
         using insert.prems(10) by blast
 
       have "q \<notin> ?RP"
         using insert.prems(2) LB_count_helper_LB2[OF _ \<open>IO_set M1 q \<Omega> \<in> ?DB\<close>]
         by blast
 
       let ?f = "f'(RS := q)"
       have "inj_on ?f (insert RS DB')"
       proof
         have "?f RS \<notin> ?f ` (DB' - {RS})"
         proof
           assume "?f RS \<in> ?f ` (DB' - {RS})"
           then have "q \<in> ?f ` (DB' - {RS})" by auto
           have "RS \<in> DB'"
           proof -
             have "\<forall>P c f. \<exists>Pa. ((c::'c) \<notin> f ` P \<or> (Pa::('a \<times> 'b) list set) \<in> P)
                                 \<and> (c \<notin> f ` P \<or> f Pa = c)"
               by auto
             moreover
             { assume "q \<notin> f' ` DB'"
               moreover
               { assume "q \<notin> f'(RS := q) ` DB'"
                 then have ?thesis
                   using \<open>q \<in> f'(RS := q) ` (DB' - {RS})\<close> by blast }
               ultimately have ?thesis
                 by (metis fun_upd_image) }
             ultimately show ?thesis
               by (metis (no_types) \<open>RS = IO_set M1 q \<Omega>\<close> \<open>\<forall>RS\<in>DB'. IO_set M1 (f' RS) \<Omega> = RS\<close>)
           qed
           then show "False" using insert.hyps(2) by simp
         qed
         then show "inj_on ?f DB' \<and> ?f RS \<notin> ?f ` (DB' - {RS})"
           using \<open>inj_on f' DB'\<close> inj_on_fun_updI by fastforce
       qed
       moreover have "image ?f (insert RS DB') \<subseteq> (nodes M1) - ?RP"
       proof -
         have "image ?f {RS} = {q}" by simp
         then have "image ?f {RS} \<subseteq> (nodes M1) - ?RP"
           using \<open>q \<in> nodes M1\<close> \<open>q \<notin> ?RP\<close> by auto
         moreover have "image ?f (insert RS DB') = image ?f {RS} \<union> image ?f DB'"
           by auto
         ultimately show ?thesis
           by (metis (no_types, lifting) \<open>image f' DB' \<subseteq> (nodes M1) - ?RP\<close> fun_upd_other image_cong
               image_insert insert.hyps(2) insert_subset)
       qed
       moreover have "\<forall> RS \<in> (insert RS DB') . IO_set M1 (?f RS) \<Omega> = RS"
         using \<open>RS = IO_set M1 q \<Omega>\<close> \<open>\<forall>RS\<in>DB'. IO_set M1 (f' RS) \<Omega> = RS\<close> by auto
 
       ultimately show ?case
         by blast
     qed
   qed
 
   have "?DB \<subseteq> ?DB"
     by simp
   obtain f where "inj_on f ?DB" "image f ?DB \<subseteq> (nodes M1) - ?RP"
     using states_f[OF \<open>?DB \<subseteq> ?DB\<close>] by blast
   have "finite (nodes M1 - ?RP)"
     using \<open>finite (nodes M1)\<close> by simp
   have "card ?DB \<le> card (nodes M1 - ?RP)"
     using card_inj_on_le[OF \<open>inj_on f ?DB\<close> \<open>image f ?DB \<subseteq> (nodes M1) - ?RP\<close>
                             \<open>finite (nodes M1 - ?RP)\<close>]
     by assumption
 
   have "?RP \<subseteq> nodes M1"
     by blast
   then have "card (nodes M1 - ?RP) = card (nodes M1) - card ?RP"
     by (meson \<open>finite (nodes M1)\<close> card_Diff_subset infinite_subset)
   then have "card ?DB \<le> card (nodes M1) - card ?RP"
     using \<open>card ?DB \<le> card (nodes M1 - ?RP)\<close> by linarith
 
   have "vs @ xs \<in> L M2 \<inter> L M1"
     using assms(7) by simp
   have "(sum (\<lambda> s . card (RP M2 s vs xs V'')) S) = card ?RP"
     using LB_count_helper_RP_disjoint_M1_union[OF \<open>vs @ xs \<in> L M2 \<inter> L M1\<close> assms(2-9)] by simp
   moreover have "card ?RP \<le> card (nodes M1)"
     using card_mono[OF \<open>finite (nodes M1)\<close> \<open>?RP \<subseteq> nodes M1\<close>] by assumption
   ultimately show ?thesis
     unfolding LB.simps using \<open>card ?DB \<le> card (nodes M1) - card ?RP\<close>
     by linarith
 qed
 
 
 
 lemma contradiction_via_LB :
 assumes "(vs @ xs) \<in> L M1"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> Perm V M1"
   and     "Prereq M2 M1 vs xs T S \<Omega> V''"
   and     "\<not> Rep_Pre M2 M1 vs xs"
   and     "\<not> Rep_Cov M2 M1 V'' vs xs"
   and     "LB M2 M1 vs xs T S \<Omega> V'' > m"
 shows  "False"
 proof -
   have "LB M2 M1 vs xs T S \<Omega> V'' \<le> card (nodes M1)"
     using LB_count[OF assms(1-9)] by assumption
   moreover have "card (nodes M1) \<le> m"
     using assms(4) by auto
   ultimately show "False"
     using assms(10) by linarith
 qed
 
 
 
 end
\ No newline at end of file
diff --git a/thys/Adaptive_State_Counting/FSM/FSM.thy b/thys/Adaptive_State_Counting/FSM/FSM.thy
--- a/thys/Adaptive_State_Counting/FSM/FSM.thy
+++ b/thys/Adaptive_State_Counting/FSM/FSM.thy
@@ -1,2031 +1,2031 @@
 theory FSM
 imports
   "Transition_Systems_and_Automata.Sequence_Zip"
   "Transition_Systems_and_Automata.Transition_System"
   "Transition_Systems_and_Automata.Transition_System_Extra"
   "Transition_Systems_and_Automata.Transition_System_Construction"
 begin 
 
 section \<open> Finite state machines \<close>
 
 text \<open>
 We formalise finite state machines as a 4-tuples, omitting the explicit formulation of the state 
 set,as it can easily be calculated from the successor function.
 This definition does not require the successor function to be restricted to the input or output 
 alphabet, which is later expressed by the property @{verbatim well_formed}, together with the 
 finiteness of the state set.
 \<close>
 
 record ('in, 'out, 'state) FSM =
   succ    :: "('in \<times> 'out) \<Rightarrow> 'state \<Rightarrow> 'state set"
   inputs  :: "'in set"
   outputs :: "'out set"
   initial :: "'state"
 
 
 
 subsection \<open> FSMs as transition systems \<close>
 
 text \<open>
 We interpret FSMs as transition systems with a singleton initial state set, based on 
 \<^cite>\<open>"Transition_Systems_and_Automata-AFP"\<close>. 
 \<close>
                                    
 global_interpretation FSM : transition_system_initial
   "\<lambda> a p. snd a"                    \<comment> \<open>execute\<close>
   "\<lambda> a p. snd a \<in> succ A (fst a) p" \<comment> \<open>enabled\<close>
   "\<lambda> p. p = initial A"              \<comment> \<open>initial\<close>
   for A
   defines path = FSM.path 
       and run = FSM.run 
       and reachable = FSM.reachable 
       and nodes = FSM.nodes
   by this
 
 abbreviation "size_FSM M \<equiv> card (nodes M)" 
 notation 
   size_FSM ("(|_|)")
 
 subsection \<open> Language \<close>
 
 text \<open>
 The following definitions establish basic notions for FSMs similarly to those of nondeterministic
 finite automata as defined in \<^cite>\<open>"Transition_Systems_and_Automata-AFP"\<close>.
 
 In particular, the language of an FSM state are the IO-parts of the paths in the FSM enabled from
 that state.
 \<close>
 
 abbreviation "target \<equiv> FSM.target"
 abbreviation "states \<equiv> FSM.states"
 abbreviation "trace \<equiv> FSM.trace"
 
 abbreviation successors :: "('in, 'out, 'state, 'more) FSM_scheme \<Rightarrow> 'state \<Rightarrow> 'state set" where
     "successors \<equiv> FSM.successors TYPE('in) TYPE('out) TYPE('more)"
 
 lemma states_alt_def: "states r p = map snd r" 
   by (induct r arbitrary: p) (auto)
 lemma trace_alt_def: "trace r p = smap snd r" 
   by (coinduction arbitrary: r p) (auto)
 
 
 definition language_state :: "('in, 'out, 'state) FSM \<Rightarrow> 'state 
                               \<Rightarrow> ('in \<times> 'out) list set" ("LS") 
   where
   "language_state M q \<equiv> {map fst r |r . path M r q}"
 
 text \<open>
 The language of an FSM is the language of its initial state.
 \<close>
 abbreviation "L M \<equiv> LS M (initial M)"
   
 
 lemma language_state_alt_def : "LS M q = {io | io tr . path M (io || tr) q \<and> length io = length tr}"
 proof -
   have "LS M q \<subseteq> { io | io tr . path M  (io || tr) q \<and> length io = length tr }"
   proof 
     fix xr assume xr_assm : "xr \<in> LS M q"
     then obtain r where r_def : "map fst r = xr" "path M r q" 
       unfolding language_state_def by auto
     then obtain xs ys where xr_split : "xr = xs || ys" 
                                        "length xs = length ys" 
                                        "length xs = length xr"
       by (metis length_map zip_map_fst_snd) 
     then have "(xs || ys) \<in> { io | io tr . path M  (io || tr) q \<and> length io = length tr }" 
     proof -
       have f1: "xs || ys = map fst r"
         by (simp add: r_def(1) xr_split(1))
       then have f2: "path M ((xs || ys) || take (min (length (xs || ys)) (length (map snd r))) 
                                                   (map snd r)) q"
         by (simp add: r_def(2))
       have "length (xs || ys) = length 
                                   (take (min (length (xs || ys)) (length (map snd r))) (map snd r))"
         using f1 by force
       then show ?thesis
         using f2 by blast
     qed 
     then show "xr \<in> { io | io tr . path M  (io || tr) q \<and> length io = length tr }" 
       using xr_split by metis
   qed
   moreover have "{ io | io tr . path M  (io || tr) q \<and> length io = length tr } \<subseteq> LS M q" 
   proof 
     fix xs assume xs_assm : "xs \<in> { io | io tr . path M  (io || tr) q \<and> length io = length tr }"
     then obtain ys where ys_def : "path M (xs || ys) q" "length xs = length ys" 
       by auto
     then have "xs = map fst (xs || ys)" 
       by auto
     then show "xs \<in> LS M q" 
       using ys_def unfolding language_state_def by blast 
   qed
   ultimately show ?thesis 
     by auto
 qed
   
 
 lemma language_state[intro]:
   assumes "path M (w || r) q" "length w = length r"
   shows "w \<in> LS M q"
   using assms unfolding language_state_def by force
 
 lemma language_state_elim[elim]:
   assumes "w \<in> LS M q"
   obtains r
   where "path M (w || r) q" "length w = length r"
   using assms unfolding language_state_def by (force iff: split_zip_ex)
 
 lemma language_state_split:
   assumes "w1 @ w2 \<in> LS M q"
   obtains tr1 tr2
   where "path M (w1 || tr1) q" "length w1 = length tr1"
         "path M (w2 || tr2) (target (w1 || tr1) q)" "length w2 = length tr2"
 proof -
   obtain tr where tr_def : "path M ((w1 @ w2) || tr) q" "length (w1 @ w2) = length tr"
     using assms by blast 
   let ?tr1 = "take (length w1) tr"
   let ?tr2 = "drop (length w1) tr"
   have tr_split : "?tr1 @ ?tr2 = tr" 
     by auto
   then show ?thesis
   proof -
     have f1: "length w1 + length w2 = length tr"
       using tr_def(2) by auto
     then have f2: "length w2 = length tr - length w1" 
       by presburger
     then have "length w1 = length (take (length w1) tr)"
       using f1 by (metis (no_types) tr_split diff_add_inverse2 length_append length_drop)
     then show ?thesis
       using f2 by (metis (no_types) FSM.path_append_elim length_drop that tr_def(1) zip_append1)
   qed
 qed
 
 lemma language_state_prefix :
   assumes "w1 @ w2 \<in> LS M q"
 shows "w1 \<in> LS M q"
   using assms by (meson language_state language_state_split) 
 
 
 lemma succ_nodes :
   fixes A :: "('a,'b,'c) FSM"
   and   w :: "('a \<times> 'b)"
   assumes "q2 \<in> succ A w q1"
   and     "q1 \<in> nodes A"
 shows "q2 \<in> nodes A"
 proof -
   obtain x y where "w = (x,y)" 
     by (meson surj_pair)
   then have "q2 \<in> successors A q1" 
     using assms  by auto
   then have "q2 \<in> reachable A q1" 
     by blast 
   then have "q2 \<in> reachable A (initial A)" 
     using assms by blast 
   then show "q2 \<in> nodes A" 
     by blast
 qed
 
 lemma states_target_index :
   assumes "i < length p"
   shows "(states p q1) ! i = target (take (Suc i) p) q1"
   using assms by auto 
 
 
 
 subsection \<open> Product machine for language intersection \<close>
 
 text \<open>
 The following describes the construction of a product machine from two FSMs @{verbatim M1} 
 and @{verbatim M2} such that the language of the product machine is the intersection of the 
 language of @{verbatim M1} and the language of @{verbatim M2}.
 \<close>
 
 definition product :: "('in, 'out, 'state1) FSM \<Rightarrow> ('in, 'out, 'state2) FSM \<Rightarrow>
   ('in, 'out, 'state1 \<times>'state2) FSM" where
   "product A B \<equiv>
   \<lparr>
     succ = \<lambda> a (p\<^sub>1, p\<^sub>2). succ A a p\<^sub>1 \<times> succ B a p\<^sub>2,
     inputs = inputs A \<union> inputs B,
     outputs = outputs A \<union> outputs B,
     initial = (initial A, initial B)
   \<rparr>"
 
 lemma product_simps[simp]:
   "succ (product A B) a (p\<^sub>1, p\<^sub>2) = succ A a p\<^sub>1 \<times> succ B a p\<^sub>2"
   "inputs (product A B) = inputs A \<union> inputs B"
   "outputs (product A B) = outputs A \<union> outputs B"
   "initial (product A B) = (initial A, initial B)"
   unfolding product_def by simp+
 
 lemma product_target[simp]:
   assumes "length w = length r\<^sub>1" "length r\<^sub>1 = length r\<^sub>2"
   shows "target (w || r\<^sub>1 || r\<^sub>2) (p\<^sub>1, p\<^sub>2) = (target (w || r\<^sub>1) p\<^sub>1, target (w || r\<^sub>2) p\<^sub>2)"
   using assms by (induct arbitrary: p\<^sub>1 p\<^sub>2 rule: list_induct3) (auto)
 lemma product_path[iff]:
   assumes "length w = length r\<^sub>1" "length r\<^sub>1 = length r\<^sub>2"
   shows "path (product A B) (w || r\<^sub>1 || r\<^sub>2) (p\<^sub>1, p\<^sub>2) \<longleftrightarrow> path A (w || r\<^sub>1) p\<^sub>1 \<and> path B (w || r\<^sub>2) p\<^sub>2"
   using assms by (induct arbitrary: p\<^sub>1 p\<^sub>2 rule: list_induct3) (auto)
 
 lemma product_language_state[simp]: "LS (product A B) (q1,q2) = LS A q1 \<inter> LS B q2"
   by (fastforce iff: split_zip)
 
 lemma product_nodes :
   "nodes (product A B) \<subseteq> nodes A \<times> nodes B"
 proof 
   fix q assume "q \<in> nodes (product A B)"
   then show "q \<in> nodes A \<times> nodes B"
   proof (induction rule: FSM.nodes.induct)
     case (initial p)
     then show ?case by auto
   next
     case (execute p a)
     then have "fst p \<in> nodes A" "snd p \<in> nodes B" 
       by auto
     
     have "snd a \<in> (succ A (fst a) (fst p)) \<times> (succ B (fst a) (snd p))"
       using execute by auto
     then have "fst (snd a) \<in> succ A (fst a) (fst p)"
               "snd (snd a) \<in> succ B (fst a) (snd p)"
       by auto
 
     have "fst (snd a) \<in> nodes A"
       using \<open>fst p \<in> nodes A\<close> \<open>fst (snd a) \<in> succ A (fst a) (fst p)\<close>
       by (metis FSM.nodes.simps fst_conv snd_conv) 
     moreover have "snd (snd a) \<in> nodes B"
       using \<open>snd p \<in> nodes B\<close> \<open>snd (snd a) \<in> succ B (fst a) (snd p)\<close>
       by (metis FSM.nodes.simps fst_conv snd_conv) 
     ultimately show ?case
       by (simp add: mem_Times_iff) 
       
   qed
 qed
 
 
 
 subsection \<open> Required properties \<close>
 
 text \<open>
 FSMs used by the adaptive state counting algorithm are required to satisfy certain properties which
 are introduced in here.
 Most notably, the observability property (see function @{verbatim observable}) implies the 
 uniqueness of certain paths and hence allows for several stronger variations of previous results.
 \<close>
 
 
 fun finite_FSM :: "('in, 'out, 'state) FSM \<Rightarrow> bool" where
   "finite_FSM M = (finite (nodes M) 
                   \<and> finite (inputs M) 
                   \<and> finite (outputs M))"
 
 fun observable :: "('in, 'out, 'state) FSM \<Rightarrow> bool" where
   "observable M = (\<forall> t . \<forall> s1 . ((succ M) t s1 = {}) 
                                 \<or> (\<exists> s2 . (succ M) t s1 = {s2}))"
 
 fun completely_specified :: "('in, 'out, 'state) FSM \<Rightarrow> bool" where
   "completely_specified M = (\<forall> s1 \<in> nodes M . \<forall> x \<in> inputs M . 
                               \<exists> y \<in> outputs M . 
                                 \<exists> s2 . s2 \<in> (succ M) (x,y) s1)"
 
 fun well_formed :: "('in, 'out, 'state) FSM \<Rightarrow> bool" where
   "well_formed M = (finite_FSM M
                     \<and> (\<forall> s1 x y . (x \<notin> inputs M \<or> y \<notin> outputs M) 
                                     \<longrightarrow> succ M (x,y) s1 = {})
                     \<and> inputs M \<noteq> {}
                     \<and> outputs M \<noteq> {})"
 
 abbreviation "OFSM M \<equiv> well_formed M 
                         \<and> observable M 
                         \<and> completely_specified M"
 
 lemma OFSM_props[elim!] :
   assumes "OFSM M"
 shows "well_formed M" 
       "observable M" 
       "completely_specified M" using assms by auto
 
 lemma set_of_succs_finite :
   assumes "well_formed M"
   and     "q \<in> nodes M"
 shows "finite (succ M io q)"
 proof (rule ccontr)
   assume "infinite (succ M io q)"
   moreover have "succ M io q \<subseteq> nodes M" 
     using assms by (simp add: subsetI succ_nodes) 
   ultimately have "infinite (nodes M)"
     using infinite_super by blast 
   then show "False" 
     using assms by auto
 qed
 
 lemma well_formed_path_io_containment : 
   assumes "well_formed M"
   and     "path M p q"
 shows "set (map fst p) \<subseteq> (inputs M \<times> outputs M)"
 using assms proof (induction p arbitrary: q)
 case Nil
   then show ?case by auto
 next
   case (Cons a p)
   have "fst a \<in> (inputs M \<times> outputs M)"
   proof (rule ccontr)
     assume "fst a \<notin> inputs M \<times> outputs M"
     then have "fst (fst a) \<notin> inputs M \<or> snd (fst a) \<notin> outputs M" 
       by (metis SigmaI prod.collapse) 
     then have "succ M (fst a) q = {}" 
       using Cons by (metis prod.collapse well_formed.elims(2)) 
     moreover have "(snd a) \<in> succ M (fst a) q" 
       using Cons by auto
     ultimately show "False" 
       by auto
   qed
   moreover have "set (map fst p) \<subseteq> (inputs M \<times> outputs M)" 
     using Cons by blast 
   ultimately show ?case 
     by auto
 qed
 
 
 lemma path_input_containment :
   assumes "well_formed M"
   and     "path M p q"  
 shows "set (map fst (map fst p)) \<subseteq> inputs M"
 using assms proof (induction p arbitrary: q rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc a p)
   have "set (map fst (p @ [a])) \<subseteq> (inputs M \<times> outputs M)" 
     using well_formed_path_io_containment[OF snoc.prems] by assumption
   then have "(fst a) \<in> (inputs M \<times> outputs M)" 
     by auto
   then have "fst (fst a) \<in> inputs M" 
     by auto
   moreover have "set (map fst (map fst p)) \<subseteq> inputs M" 
     using snoc.IH[OF snoc.prems(1)]
     using snoc.prems(2) by blast 
   ultimately show ?case
     by simp 
 qed
 
 lemma path_state_containment :
   assumes "path M p q"
   and     "q \<in> nodes M"
 shows "set (map snd p) \<subseteq> nodes M"
   using assms by (metis FSM.nodes_states states_alt_def) 
 
 
 lemma language_state_inputs :
   assumes "well_formed M"
   and     "io \<in> language_state M q"
 shows "set (map fst io) \<subseteq> inputs M"
 proof -
   obtain tr where "path M (io || tr) q" "length tr = length io" 
     using assms(2) by auto
   show ?thesis 
     by (metis (no_types) 
         \<open>\<And>thesis. (\<And>tr. \<lbrakk>path M (io || tr) q; length tr = length io\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> 
         assms(1) map_fst_zip path_input_containment)
 qed 
 
 
 lemma set_of_paths_finite : 
   assumes "well_formed M"
   and     "q1 \<in> nodes M"
 shows "finite { p . path M p q1 \<and> target p q1 = q2 \<and> length p \<le> k }"
 proof -
 
   let ?trs = "{ tr . set tr \<subseteq> nodes M \<and> length tr \<le> k }"
   let ?ios = "{ io . set io \<subseteq> inputs M \<times> outputs M \<and> length io \<le> k }"
   let ?iotrs = "image (\<lambda> (io,tr) . io || tr) (?ios \<times> ?trs)"
 
   let ?paths = "{ p . path M p q1 \<and> target p q1 = q2 \<and> length p \<le> k }"
   
   have "finite (inputs M \<times> outputs M)" 
     using assms by auto
   then have "finite ?ios" 
     using assms by (simp add: finite_lists_length_le) 
   moreover have "finite ?trs" 
     using assms by (simp add: finite_lists_length_le)
   ultimately have "finite ?iotrs" 
     by auto
 
   moreover have "?paths \<subseteq> ?iotrs" 
   proof 
     fix p assume p_assm : "p \<in> { p . path M p q1 \<and> target p q1 = q2 \<and> length p \<le> k }"
     then obtain io tr where p_split : "p = io || tr \<and> length io = length tr" 
       using that by (metis (no_types) length_map zip_map_fst_snd)
     then have "io \<in> ?ios" 
       using well_formed_path_io_containment
     proof -
       have f1: "path M p q1 \<and> target p q1 = q2 \<and> length p \<le> k"
         using p_assm by force
       then have "set io \<subseteq> inputs M \<times> outputs M"
         by (metis (no_types) assms(1) map_fst_zip p_split well_formed_path_io_containment)
       then show ?thesis
         using f1 by (simp add: p_split)
     qed 
 
     moreover have "tr \<in> ?trs" using p_split
     proof -
       have f1: "path M (io || tr) q1 \<and> target (io || tr) q1 = q2 
                   \<and> length (io || tr) \<le> k" using \<open>p \<in> {p. path M p q1 
                   \<and> target p q1 = q2 \<and> length p \<le> k}\<close> p_split by force
       then have f2: "length tr \<le> k" by (simp add: p_split)
       have "set tr \<subseteq> nodes M"
         using f1 by (metis (no_types) assms(2) length_map p_split path_state_containment 
                       zip_eq zip_map_fst_snd)
       then show ?thesis 
         using f2 by blast
     qed 
     ultimately show "p \<in> ?iotrs" 
       using p_split by auto
   qed
 
   ultimately show ?thesis 
     using Finite_Set.finite_subset by blast
 qed 
 
 
 lemma non_distinct_duplicate_indices :
   assumes "\<not> distinct xs"
 shows "\<exists> i1 i2 . i1 \<noteq> i2 \<and> xs ! i1 = xs ! i2 \<and> i1 \<le> length xs \<and> i2 \<le> length xs"
   using assms by (meson distinct_conv_nth less_imp_le) 
 
 lemma reaching_path_without_repetition :
   assumes "well_formed M"
   and     "q2 \<in> reachable M q1"
   and     "q1 \<in> nodes M"
 shows "\<exists> p . path M p q1 \<and> target p q1 = q2 \<and> distinct (q1 # states p q1)"
 proof -
   have shorten_nondistinct : "\<forall> p. (path M p q1 \<and> target p q1 = q2 \<and> \<not> distinct (q1 # states p q1)) 
                \<longrightarrow> (\<exists> p' . path M p' q1 \<and> target p' q1 = q2 \<and> length p' < length p)"
   proof 
     fix p 
     show "(path M p q1 \<and> target p q1 = q2 \<and> \<not> distinct (q1 # states p q1)) 
                \<longrightarrow> (\<exists> p' . path M p' q1 \<and> target p' q1 = q2 \<and> length p' < length p)"
     proof 
       assume assm : "path M p q1 \<and> target p q1 = q2 \<and> \<not> distinct (q1 # states p q1)"
       then show "(\<exists>p'. path M p' q1 \<and> target p' q1 = q2 \<and> length p' < length p)"
       proof (cases "q1 \<in> set (states p q1)")
         case True
         have "\<exists> i1 . target (take i1 p) q1 = q1 \<and> i1 \<le> length p \<and> i1 > 0"
         proof (rule ccontr)
           assume "\<not> (\<exists> i1. target (take i1 p) q1 = q1 \<and> i1 \<le> length p \<and> i1 > 0)"
           then have "\<not> (\<exists> i1 . (states p q1) ! i1 = q1 \<and> i1 \<le> length (states p q1))" 
             by (metis True in_set_conv_nth less_eq_Suc_le scan_length scan_nth zero_less_Suc)
           then have "q1 \<notin> set (states p q1)" 
             by (meson in_set_conv_nth less_imp_le)  
           then show "False" 
             using True by auto
         qed
         then obtain i1 where i1_def : "target (take i1 p) q1 = q1 \<and> i1 \<le> length p \<and> i1 > 0" 
           by auto
 
         then have "path M (take i1 p) q1" 
           using assm by (metis FSM.path_append_elim append_take_drop_id)  
         moreover have "path M (drop i1 p) q1" 
           using i1_def by (metis FSM.path_append_elim append_take_drop_id assm) 
         ultimately have "path M (drop i1 p) q1 \<and> (target (drop i1 p) q1 = q2)" 
           using i1_def by (metis (no_types) append_take_drop_id assm fold_append o_apply)
         
         moreover have "length (drop i1 p) < length p" 
           using i1_def by auto
         ultimately show ?thesis 
           using assms by blast
       
      next
         case False
         then have assm' : "path M p q1 \<and> target p q1 = q2 \<and> \<not> distinct (states p q1)" 
           using assm by auto
 
         have "\<exists> i1 i2 . i1 \<noteq> i2 \<and> target (take i1 p) q1 = target (take i2 p) q1 
                         \<and> i1 \<le> length p \<and> i2 \<le> length p"
         proof (rule ccontr)
           assume "\<not> (\<exists> i1 i2 . i1 \<noteq> i2 \<and> target (take i1 p) q1 = target (take i2 p) q1 
                                 \<and> i1 \<le> length p \<and> i2 \<le> length p)"
           then have "\<not> (\<exists> i1 i2 . i1 \<noteq> i2 \<and> (states p q1) ! i1 = (states p q1) ! i2 
                                   \<and> i1 \<le> length (states p q1) \<and> i2 \<le> length (states p q1))"
             by (metis (no_types, lifting) Suc_leI assm' distinct_conv_nth nat.inject 
                 scan_length scan_nth) 
     
           then have "distinct (states p q1)" 
             using non_distinct_duplicate_indices by blast 
           then show "False" 
             using assm' by auto
         qed
         then obtain i1 i2 where i_def : "i1 < i2 \<and> target (take i1 p) q1 = target (take i2 p) q1 
                                           \<and> i1 \<le> length p \<and> i2 \<le> length p" 
           by (metis nat_neq_iff)
     
         then have "path M (take i1 p) q1" 
           using assm by (metis FSM.path_append_elim append_take_drop_id)  
         moreover have "path M (drop i2 p) (target (take i2 p) q1)" 
           by (metis FSM.path_append_elim append_take_drop_id assm) 
         ultimately have "path M ((take i1 p) @ (drop i2 p)) q1 
                           \<and> (target ((take i1 p) @ (drop i2 p)) q1 = q2)" 
           using i_def assm
           by (metis FSM.path_append append_take_drop_id fold_append o_apply) 
     
         moreover have "length ((take i1 p) @ (drop i2 p)) < length p" 
           using i_def by auto
     
         ultimately have "path M ((take i1 p) @ (drop i2 p)) q1 
                           \<and> target ((take i1 p) @ (drop i2 p)) q1 = q2 
                           \<and> length ((take i1 p) @ (drop i2 p)) < length p" 
           by simp
       
         then show ?thesis 
           using assms by blast
       qed      
     qed
   qed
 
   obtain p where p_def : "path M p q1 \<and> target p q1 = q2" 
     using assms by auto
 
   let ?paths = "{p' . (path M p' q1 \<and> target p' q1 = q2 \<and> length p' \<le> length p)}"
   let ?minPath = "arg_min length (\<lambda> io . io \<in> ?paths)" 
   
   have "?paths \<noteq> empty" 
     using p_def by auto
   moreover have "finite ?paths" 
     using assms by (simp add: set_of_paths_finite) 
   ultimately have minPath_def : "?minPath \<in> ?paths \<and> (\<forall> p' \<in> ?paths . length ?minPath \<le> length p')" 
     by (meson arg_min_nat_lemma equals0I) 
   
   moreover have "distinct (q1 # states ?minPath q1)"
   proof (rule ccontr)
     assume "\<not> distinct (q1 # states ?minPath q1)"
     then have "\<exists> p' . path M p' q1 \<and> target p' q1 = q2 \<and> length p' < length ?minPath" 
       using shorten_nondistinct minPath_def by blast 
     then show "False" 
       using minPath_def using arg_min_nat_le dual_order.strict_trans1 by auto 
   qed
 
   ultimately show ?thesis by auto
 qed
 
 
 
 
 
 lemma observable_path_unique[simp] :
   assumes "io \<in> LS M q"
   and     "observable M"
   and     "path M (io || tr1) q" "length io = length tr1"
   and     "path M (io || tr2) q" "length io = length tr2"
 shows "tr1 = tr2"
 proof (rule ccontr)
   assume tr_assm : "tr1 \<noteq> tr2"
   then have state_diff : "(states (io || tr1) q ) \<noteq> (states (io || tr2) q)"
     by (metis assms(4) assms(6) map_snd_zip states_alt_def)
   show "False"
   using assms tr_assm proof (induction io arbitrary: q tr1 tr2)
     case Nil
     then show ?case using Nil 
       by simp
   next
     case (Cons io_hd io_tl)
     then obtain tr1_hd tr1_tl tr2_hd tr2_tl where tr_split : "tr1 = tr1_hd # tr1_tl 
                                                               \<and> tr2 = tr2_hd # tr2_tl"
       by (metis length_0_conv neq_Nil_conv)
 
     have p1: "path M ([io_hd] || [tr1_hd]) q"   
       using Cons.prems tr_split by auto
     have p2: "path M ([io_hd] || [tr2_hd]) q"   
       using Cons.prems tr_split by auto
     have tr_hd_eq : "tr1_hd = tr2_hd"           
       using Cons.prems unfolding observable.simps
     proof -
       assume "\<forall>t s1. succ M t s1 = {} \<or> (\<exists>s2. succ M t s1 = {s2})"
       then show ?thesis
         by (metis (no_types) p1 p2 FSM.path_cons_elim empty_iff prod.sel(1) prod.sel(2) singletonD 
             zip_Cons_Cons)
     qed
 
     then show ?thesis
       using Cons.IH Cons.prems(3) Cons.prems(4) Cons.prems(5) Cons.prems(6) Cons.prems(7) assms(2) 
             tr_split by auto 
   qed
 qed
 
 
 lemma observable_path_unique_ex[elim] : 
   assumes "observable M"
   and     "io \<in> LS M q"
 obtains tr 
 where "{ t . path M (io || t) q \<and> length io = length t } = { tr }" 
 proof -
   obtain tr where tr_def : "path M (io || tr) q" "length io = length tr" 
     using assms by auto
   then have "{ t . path M (io || t) q \<and> length io = length t } \<noteq> {}" 
     by blast
   moreover have "\<forall> t \<in> { t . path M (io || t) q \<and> length io = length t } . t = tr" 
     using assms tr_def by auto  
   ultimately show ?thesis 
-    using that by moura
+    using that by auto
 qed
 
 lemma well_formed_product[simp] :
   assumes "well_formed M1"
   and     "well_formed M2"
 shows "well_formed (product M2 M1)" (is "well_formed ?PM")
 unfolding well_formed.simps proof
   have "finite (nodes M1)" "finite (nodes M2)" 
     using assms by auto
   then have "finite (nodes M2 \<times> nodes M1)" 
     by simp
 
   moreover have "nodes ?PM \<subseteq> nodes M2 \<times> nodes M1" 
     using product_nodes assms by blast
   ultimately show "finite_FSM ?PM" 
     using infinite_subset assms by auto  
 next
   have "inputs ?PM = inputs M2 \<union> inputs M1" 
        "outputs ?PM = outputs M2 \<union> outputs M1" 
     by auto
   then show "(\<forall>s1 x y. x \<notin> inputs ?PM \<or> y \<notin> outputs ?PM \<longrightarrow> succ ?PM (x, y) s1 = {}) 
                                                               \<and> inputs ?PM \<noteq> {} \<and> outputs ?PM \<noteq> {}" 
     using assms by auto
 qed
 
 
 subsection \<open> States reached by a given IO-sequence \<close>
 
 text \<open>
 Function @{verbatim io_targets} collects all states of an FSM reached from a given state by a 
 given IO-sequence.
 Notably, for any observable FSM, this set contains at most one state.
 \<close>
 
 fun io_targets :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> 'state set" where
   "io_targets M q io = { target (io || tr) q | tr . path M (io || tr) q \<and> length io = length tr }"
 
 lemma io_target_implies_L :
   assumes "q \<in> io_targets M (initial M) io"
   shows "io \<in> L M" 
 proof -
   obtain tr where "path M (io || tr) (initial M)" 
                   "length tr = length io" 
                   "target (io || tr) (initial M) = q" 
     using assms by auto
   then show ?thesis by auto
 qed
 
 lemma io_target_from_path :
   assumes "path M (w || tr) q"
   and     "length w = length tr"
 shows "target (w || tr) q \<in> io_targets M q w"
   using assms by auto
 
 lemma io_targets_observable_singleton_ex :
   assumes "observable M"
   and     "io \<in> LS M q1"
 shows "\<exists> q2 . io_targets M q1 io = { q2 }"
 proof -
   obtain tr where tr_def : "{ t . path M (io || t) q1 \<and> length io = length t } = { tr }" 
     using assms observable_path_unique_ex by (metis (mono_tags, lifting)) 
   then have "io_targets M q1 io = { target (io || tr) q1 }" 
     by fastforce 
   then show ?thesis 
     by blast 
 qed
 
 lemma io_targets_observable_singleton_ob :
   assumes "observable M"
   and     "io \<in> LS M q1"
 obtains q2 
   where "io_targets M q1 io = { q2 }"
 proof -
   obtain tr where tr_def : "{ t . path M (io || t) q1 \<and> length io = length t } = { tr }" 
     using assms observable_path_unique_ex by (metis (mono_tags, lifting)) 
   then have "io_targets M q1 io = { target (io || tr) q1 }" 
     by fastforce 
   then show ?thesis using that by blast 
 qed
 
 lemma io_targets_elim[elim] :
   assumes "p \<in> io_targets M q io"
 obtains tr 
 where "target (io || tr) q = p \<and> path M (io || tr) q \<and> length io = length tr" 
   using assms  unfolding io_targets.simps by force 
 
 
 lemma io_targets_reachable :
   assumes "q2 \<in> io_targets M q1 io"
   shows "q2 \<in> reachable M q1" 
   using assms  unfolding io_targets.simps by blast
 
 lemma io_targets_nodes :
   assumes "q2 \<in> io_targets M q1 io"
   and     "q1 \<in> nodes M"
 shows "q2 \<in> nodes M"
   using assms by auto
 
 
 lemma observable_io_targets_split :
   assumes "observable M"
   and "io_targets M q1 (vs @ xs) = {q3}"
   and "io_targets M q1 vs = {q2}"
 shows "io_targets M q2 xs = {q3}"
 proof -
   have "vs @ xs \<in> LS M q1" 
     using assms(2) by force 
   then obtain trV trX where tr_def : 
         "path M (vs || trV) q1" "length vs = length trV"
         "path M (xs || trX) (target (vs || trV) q1)" "length xs = length trX" 
     using language_state_split[of vs xs M q1] by auto
   then have tgt_V : "target (vs || trV) q1 = q2" 
     using assms(3) by auto
   then have path_X : "path M (xs || trX) q2 \<and> length xs = length trX" 
     using tr_def by auto
 
   have tgt_all :  "target (vs @ xs || trV @ trX) q1 = q3"
   proof -
     have f1: "\<exists>cs. q3 = target (vs @ xs || cs) q1 
                     \<and> path M (vs @ xs || cs) q1 \<and> length (vs @ xs) = length cs"
       using assms(2) by auto
     have "length (vs @ xs) = length trV + length trX"
       by (simp add: tr_def(2) tr_def(4))
     then have "length (vs @ xs) = length (trV @ trX)"
       by simp
     then show ?thesis
       using f1 by (metis FSM.path_append \<open>vs @ xs \<in> LS M q1\<close> assms(1) observable_path_unique 
                     tr_def(1) tr_def(2) tr_def(3) zip_append)
   qed 
   then have "target ((vs || trV) @ (xs || trX)) q1 = q3" 
     using tr_def by simp 
   then have "target (xs || trX) q2 = q3" 
     using tgt_V by auto
   then have "q3 \<in> io_targets M q2 xs" 
     using path_X by auto
   then show ?thesis 
     by (metis (no_types) \<open>observable M\<close> path_X insert_absorb io_targets_observable_singleton_ex 
         language_state singleton_insert_inj_eq')
 qed 
 
 
 
 lemma observable_io_target_unique_target :
   assumes "observable M"
   and     "io_targets M q1 io = {q2}"
   and     "path M (io || tr) q1"
   and     "length io = length tr"
 shows "target (io || tr) q1 = q2"
   using assms by auto
   
 lemma target_in_states : 
   assumes "length io = length tr"
   and     "length io > 0"
   shows "last (states (io || tr) q) = target (io || tr) q"
 proof -
   have "0 < length tr"
     using assms(1) assms(2) by presburger
   then show ?thesis
     by (simp add: FSM.target_alt_def assms(1) states_alt_def)
 qed 
 
 lemma target_alt_def :
   assumes "length io = length tr"
   shows "length io = 0 \<Longrightarrow> target (io || tr) q = q"
         "length io > 0 \<Longrightarrow> target (io || tr) q = last tr"
 proof -
   show "length io = 0 \<Longrightarrow> target (io || tr) q = q" by simp
   show "length io > 0 \<Longrightarrow> target (io || tr) q = last tr" 
     by (metis assms last_ConsR length_greater_0_conv map_snd_zip scan_last states_alt_def) 
 qed
 
 lemma obs_target_is_io_targets :
   assumes "observable M"
   and     "path M (io || tr) q"
   and     "length io = length tr"
 shows "io_targets M q io = {target (io || tr) q}"
   by (metis assms(1) assms(2) assms(3) io_targets_observable_singleton_ex language_state 
       observable_io_target_unique_target)
 
 
 
 lemma io_target_target :
   assumes "io_targets M q1 io = {q2}"
   and     "path M (io || tr) q1"
   and     "length io = length tr"
 shows "target (io || tr) q1 = q2"
 proof -
   have "target (io || tr) q1 \<in> io_targets M q1 io" using assms(2) assms(3) by auto 
   then show ?thesis using assms(1) by blast
 qed 
 
 
 lemma index_last_take :
   assumes "i < length xs"
   shows "xs ! i = last (take (Suc i) xs)"
   by (simp add: assms take_Suc_conv_app_nth) 
 
 lemma path_last_io_target :
   assumes "path M (xs || tr) q" 
   and     "length xs = length tr"
   and     "length xs > 0"
 shows "last tr \<in> io_targets M q xs" 
 proof -
   have "last tr = target (xs || tr) q"
     by (metis assms(2) assms(3) map_snd_zip states_alt_def target_in_states)
   then show ?thesis using assms(1) assms(2) by auto
 qed
 
 
 lemma path_prefix_io_targets :
   assumes "path M (xs || tr) q" 
   and     "length xs = length tr"
   and     "length xs > 0"
 shows "last (take (Suc i) tr) \<in> io_targets M q (take (Suc i) xs)" 
 proof -
   have "path M (take (Suc i) xs || take (Suc i) tr) q" 
     by (metis (no_types) FSM.path_append_elim append_take_drop_id assms(1) take_zip) 
   then show ?thesis 
     using assms(2) assms(3) path_last_io_target by fastforce  
 qed
 
 
 lemma states_index_io_target :
   assumes "i < length xs"
   and     "path M (xs || tr) q" 
   and     "length xs = length tr"
   and     "length xs > 0"
 shows "(states (xs || tr) q) ! i \<in> io_targets M q (take (Suc i) xs)"
 proof -
   have "(states (xs || tr) q) ! i = last (take (Suc i) (states (xs || tr) q))" 
     by (metis assms(1) assms(3) map_snd_zip states_alt_def index_last_take) 
   then have "(states (xs || tr) q) ! i = last (states (take (Suc i) xs || take (Suc i) tr) q)"
     by (simp add: take_zip) 
   then have "(states (xs || tr) q) ! i = last (take (Suc i) tr)" 
     by (simp add: assms(3) states_alt_def) 
   moreover have "last (take (Suc i) tr) \<in> io_targets M q (take (Suc i) xs)" 
     by (meson assms(2) assms(3) assms(4) path_prefix_io_targets) 
   ultimately show ?thesis 
     by simp
 qed
 
 
 lemma observable_io_targets_append :
   assumes "observable M"
   and "io_targets M q1 vs = {q2}"
   and "io_targets M q2 xs = {q3}"
 shows "io_targets M q1 (vs@xs) = {q3}"
 proof -
   obtain trV where "path M (vs || trV) q1 \<and> length trV = length vs \<and> target (vs || trV) q1 = q2" 
     by (metis assms(2) io_targets_elim singletonI) 
   moreover obtain trX where "path M (xs || trX) q2 \<and> length trX = length xs 
                               \<and> target (xs || trX) q2 = q3" 
     by (metis assms(3) io_targets_elim singletonI)
   ultimately have "path M (vs @ xs || trV @ trX) q1 \<and> length (trV @ trX) = length (vs @ xs) 
                     \<and> target (vs @ xs || trV @ trX) q1 = q3" 
     by auto
   then show ?thesis 
     by (metis assms(1) obs_target_is_io_targets) 
 qed
 
 
 lemma io_path_states_prefix :
   assumes "observable M"
   and "path M (io1 || tr1) q"
   and "length tr1 = length io1"
   and "path M (io2 || tr2) q"
   and "length tr2 = length io2"
   and "prefix io1 io2"
 shows "tr1 = take (length tr1) tr2"
 proof -
   let ?tr1' = "take (length tr1) tr2"
   let ?io1' = "take (length tr1) io2"
   have "path M (?io1' || ?tr1') q"
     by (metis FSM.path_append_elim append_take_drop_id assms(4) take_zip)
   have "length ?tr1' = length ?io1'"
     using assms (5) by auto
 
   have "?io1' = io1"
   proof -
     have "\<forall>ps psa. \<not> prefix (ps::('a \<times> 'b) list) psa \<or> length ps \<le> length psa"
       using prefix_length_le by blast
     then have "length (take (length tr1) io2) = length io1"
       using assms(3) assms(6) min.absorb2 by auto
     then show ?thesis
       by (metis assms(6) min.cobounded2 min_def_raw prefix_length_prefix 
           prefix_order.dual_order.antisym take_is_prefix)
   qed
 
   show "tr1 = ?tr1'"
     by (metis \<open>length (take (length tr1) tr2) = length (take (length tr1) io2)\<close> 
         \<open>path M (take (length tr1) io2 || take (length tr1) tr2) q\<close> \<open>take (length tr1) io2 = io1\<close> 
         assms(1) assms(2) assms(3) language_state observable_path_unique)
 qed
 
   
 
 lemma observable_io_targets_suffix :
   assumes "observable M"
   and "io_targets M q1 vs = {q2}"
   and "io_targets M q1 (vs@xs) = {q3}"
 shows "io_targets M q2 xs = {q3}"
 proof -
   have "prefix vs (vs@xs)" 
     by auto
   
   obtain trV where "path M (vs || trV) q1 \<and> length trV = length vs \<and> target (vs || trV) q1 = q2" 
     by (metis assms(2) io_targets_elim singletonI)
   moreover obtain trVX where "path M (vs@xs || trVX) q1 
                                 \<and> length trVX = length (vs@xs) \<and> target (vs@xs || trVX) q1 = q3" 
     by (metis assms(3) io_targets_elim singletonI)
 
   
   ultimately have "trV = take (length trV) trVX" 
     using io_path_states_prefix[OF assms(1) _ _ _ _ \<open>prefix vs (vs@xs)\<close>, of trV q1 trVX] by auto
   show ?thesis 
     by (meson assms(1) assms(2) assms(3) observable_io_targets_split)
 qed
 
 
 lemma observable_io_target_is_singleton[simp] :
   assumes "observable M"
   and     "p \<in> io_targets M q io"
 shows "io_targets M q io = {p}" 
 proof -
   have "io \<in> LS M q" 
     using assms(2) by auto
   then obtain p' where "io_targets M q io = {p'}" 
     using assms(1) by (meson io_targets_observable_singleton_ex) 
   then show ?thesis 
     using assms(2) by simp
 qed
 
 
 lemma observable_path_prefix :
   assumes "observable M"
   and     "path M (io || tr) q"
   and     "length io = length tr"
   and     "path M (ioP || trP) q"
   and     "length ioP = length trP"
   and     "prefix ioP io" 
 shows "trP = take (length ioP) tr"
 proof -
   have ioP_def : "ioP = take (length ioP) io" 
     using assms(6) by (metis append_eq_conv_conj prefixE) 
   then have "take (length ioP) (io || tr) = take (length ioP) io || take (length ioP) tr" 
     using take_zip by blast 
   moreover have "path M (take (length ioP) (io || tr)) q" 
     using assms by (metis FSM.path_append_elim append_take_drop_id)
   ultimately have "path M (take (length ioP) io || take (length ioP) tr) q 
                     \<and> length (take (length ioP) io) = length (take (length ioP) tr)" 
     using assms(3) by auto
   then have "path M (ioP || take (length ioP) tr) q \<and> length ioP = length (take (length ioP) tr)" 
     using assms(3) using ioP_def by auto
   then show ?thesis 
     by (meson assms(1) assms(4) assms(5) language_state observable_path_unique)
 qed
 
 
 lemma io_targets_succ : 
   assumes "q2 \<in> io_targets M q1 [xy]"
   shows "q2 \<in> succ M xy q1"
 proof -
   obtain tr where tr_def : "target ([xy] || tr) q1 = q2" 
                            "path M ([xy] || tr) q1" 
                            "length [xy] = length tr"
     using assms by auto
 
   have "length tr = Suc 0"
     using \<open>length [xy] = length tr\<close> by auto
   then obtain q2' where "tr = [q2']"
     by (metis Suc_length_conv length_0_conv)
   then have "target ([xy] || tr) q1 = q2'"
     by auto
   then have "q2' = q2"
     using \<open>target ([xy] || tr) q1 = q2\<close> by simp
   then have "path M ([xy] || [q2]) q1" 
     using tr_def(2) \<open>tr = [q2']\<close> by auto
   then have "path M [(xy,q2)] q1"
     by auto
 
   show ?thesis 
   proof (cases rule: FSM.path.cases[of M "[(xy,q2)]" q1])
     case nil
     show ?case 
       using \<open>path M [(xy,q2)] q1\<close> by simp
   next
     case cons 
     show "snd (xy, q2) \<in> succ M (fst (xy, q2)) q1 \<Longrightarrow> path M [] (snd (xy, q2)) 
             \<Longrightarrow> q2 \<in> succ M xy q1" 
       by auto
   qed
 qed
 
 
 subsection \<open> D-reachability \<close>
 
 text \<open>
 A state of some FSM is d-reached (deterministically reached) by some input sequence if any sequence 
 in the language of the FSM with this input sequence reaches that state. 
 That state is then called d-reachable. 
 \<close>
 
 abbreviation  "d_reached_by M p xs q tr ys \<equiv> 
                     ((length xs = length ys \<and> length xs = length tr 
                     \<and> (path M ((xs || ys) || tr) p) \<and> target ((xs || ys) || tr) p = q) 
                     \<and> (\<forall> ys2 tr2 .  (length xs = length ys2 \<and> length xs = length tr2 
                     \<and> path M ((xs || ys2) || tr2) p) \<longrightarrow> target ((xs || ys2) || tr2) p = q))"  
 
 fun d_reaches :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> 'in list \<Rightarrow> 'state \<Rightarrow> bool" where
   "d_reaches M p xs q = (\<exists> tr ys . d_reached_by M p xs q tr ys)"
 
 fun d_reachable :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> 'state set" where
   "d_reachable M p = { q . (\<exists> xs . d_reaches M p xs q) }"
 
 
 lemma d_reaches_unique[elim] : 
   assumes "d_reaches M p xs q1"
   and    "d_reaches M p xs q2"
 shows "q1 = q2"
 using assms unfolding d_reaches.simps by blast
 
 lemma d_reaches_unique_cases[simp] : "{ q . d_reaches M (initial M) xs q } = {} 
                                       \<or> (\<exists> q2 . { q . d_reaches M (initial M) xs q } = { q2 })"
   unfolding d_reaches.simps by blast
 
 lemma d_reaches_unique_obtain[simp] :
   assumes "d_reaches M (initial M) xs q"
 shows "{ p . d_reaches M (initial M) xs p } = { q }"
   using assms unfolding d_reaches.simps by blast
 
 lemma d_reaches_io_target :
   assumes "d_reaches M p xs q"
   and     "length ys = length xs"
 shows "io_targets M p (xs || ys) \<subseteq> {q}"
 proof 
   fix q' assume "q' \<in> io_targets M p (xs || ys)"
   then obtain trQ where "path M ((xs || ys) || trQ) p \<and> length (xs || ys) = length trQ" 
     by auto
   moreover obtain trD ysD where "d_reached_by M p xs q trD ysD" using assms(1) 
     by auto
   ultimately have "target ((xs || ys) || trQ) p = q" 
     by (simp add: assms(2))
   then show "q' \<in> {q}" 
     using \<open>d_reached_by M p xs q trD ysD\<close> \<open>q' \<in> io_targets M p (xs || ys)\<close> assms(2) by auto
 qed
   
 lemma d_reachable_reachable : "d_reachable M p \<subseteq> reachable M p" 
   unfolding d_reaches.simps d_reachable.simps by blast
 
 
 
 
 subsection \<open> Deterministic state cover \<close>
 
 text \<open>
 The deterministic state cover of some FSM is a minimal set of input sequences such that every
 d-reachable state of the FSM is d-reached by a sequence in the set and the set contains the
 empty sequence (which d-reaches the initial state). 
 \<close>
 
 
 fun is_det_state_cover_ass :: "('in, 'out, 'state) FSM \<Rightarrow> ('state \<Rightarrow> 'in list) \<Rightarrow> bool" where
   "is_det_state_cover_ass M f = (f (initial M) = [] \<and> (\<forall> s \<in> d_reachable M (initial M) . 
                                                                 d_reaches M (initial M) (f s) s))"
 
 lemma det_state_cover_ass_dist : 
   assumes "is_det_state_cover_ass M f"
   and     "s1 \<in> d_reachable M (initial M)"
   and     "s2 \<in> d_reachable M (initial M)"
   and     "s1 \<noteq> s2"
 shows "\<not>(d_reaches M (initial M) (f s2) s1)"
   by (meson assms(1) assms(3) assms(4) d_reaches_unique is_det_state_cover_ass.simps)
 
 
 lemma det_state_cover_ass_diff :
   assumes "is_det_state_cover_ass M f"
   and     "s1 \<in> d_reachable M (initial M)"
   and     "s2 \<in> d_reachable M (initial M)"
   and     "s1 \<noteq> s2"
 shows "f s1 \<noteq> f s2"
   by (metis assms det_state_cover_ass_dist is_det_state_cover_ass.simps)
 
 
 fun is_det_state_cover :: "('in, 'out, 'state) FSM \<Rightarrow> 'in list set \<Rightarrow> bool" where
   "is_det_state_cover M V = (\<exists> f . is_det_state_cover_ass M f 
                                     \<and> V = image f (d_reachable M (initial M)))"
 
 lemma det_state_cover_d_reachable[elim] :
   assumes "is_det_state_cover M V"
   and     "v \<in> V"
 obtains q
 where "d_reaches M (initial M) v q"
   by (metis (no_types, opaque_lifting) assms(1) assms(2) image_iff is_det_state_cover.simps 
       is_det_state_cover_ass.elims(2))
 
 
 
 lemma det_state_cover_card[simp] :
   assumes "is_det_state_cover M V"
   and     "finite (nodes M)"
 shows   "card (d_reachable M (initial M)) = card V"
 proof -
   obtain f where f_def : "is_det_state_cover_ass M f \<and> V = image f (d_reachable M (initial M))"
     using assms unfolding is_det_state_cover.simps by blast
   then have card_f : "card V = card (image f (d_reachable M (initial M)))"
     by simp
 
   have "d_reachable M (initial M) \<subseteq> nodes M"
     unfolding d_reachable.simps d_reaches.simps using d_reachable_reachable by blast
   then have dr_finite : "finite (d_reachable M (initial M))"
     using assms infinite_super by blast 
 
   then have card_le : "card (image f (d_reachable M (initial M))) \<le> card (d_reachable M (initial M))"
     using card_image_le by blast
 
   have "card (image f (d_reachable M (initial M))) = card (d_reachable M (initial M))"
     by (meson card_image det_state_cover_ass_diff f_def inj_onI)
 
   then show ?thesis using card_f by auto
 qed
 
 lemma det_state_cover_finite :
   assumes "is_det_state_cover M V"
   and     "finite (nodes M)"
 shows "finite V"
 proof -
   have "d_reachable M (initial M) \<subseteq> nodes M"
     by auto 
   show "finite V" using det_state_cover_card[OF assms]
     by (metis \<open>d_reachable M (initial M) \<subseteq> nodes M\<close> assms(1) assms(2) finite_imageI infinite_super 
         is_det_state_cover.simps)    
 qed
 
 
 lemma det_state_cover_initial :
   assumes "is_det_state_cover M V"
   shows   "[] \<in> V"
 proof -
   have "d_reached_by M (initial M) [] (initial M) [] []"
     by (simp add: FSM.nil)
   then have "d_reaches M (initial M) [] (initial M)" 
     by auto
   
   have "initial M \<in> d_reachable M (initial M)"
     by (metis (no_types) \<open>d_reaches M (initial M) [] (initial M)\<close> d_reachable.simps mem_Collect_eq)
   then show ?thesis
     by (metis (no_types, lifting) assms image_iff is_det_state_cover.elims(2) 
         is_det_state_cover_ass.simps) 
 qed
 
 lemma det_state_cover_empty : 
   assumes "is_det_state_cover M V"
   shows "[] \<in> V"
 proof -
   obtain f where f_def : "is_det_state_cover_ass M f \<and> V = f ` d_reachable M (initial M)" 
     using assms by auto
   then have "f (initial M) = []" 
     by auto
   moreover have "initial M \<in> d_reachable M (initial M)" 
   proof -
     have "d_reaches M (initial M) [] (initial M)" 
       by auto
     then show ?thesis 
       by (metis d_reachable.simps mem_Collect_eq) 
   qed
   moreover have "f (initial M) \<in> V" 
     using f_def calculation by blast
   ultimately show ?thesis 
     by auto
 qed
 
 
 
 
 subsection \<open> IO reduction \<close>
 
 text \<open>
 An FSM is a reduction of another, if its language is a subset of the language of the latter FSM.
 \<close>
 
 
 fun io_reduction :: "('in, 'out, 'state) FSM \<Rightarrow> ('in, 'out, 'state) FSM 
                       \<Rightarrow> bool" (infix "\<preceq>" 200) 
   where 
   "M1 \<preceq> M2 = (LS M1 (initial M1) \<subseteq> LS M2 (initial M2))"
 
 
 lemma language_state_inclusion_of_state_reached_by_same_sequence : 
   assumes "LS M1 q1 \<subseteq> LS M2 q2"
   and     "observable M1"
   and     "observable M2"
   and     "io_targets M1 q1 io = { q1t }"
   and     "io_targets M2 q2 io = { q2t }"
 shows "LS M1 q1t \<subseteq> LS M2 q2t"
 proof 
   fix x assume "x \<in> LS M1 q1t" 
   obtain q1x where "io_targets M1 q1t x = {q1x}"
     by (meson \<open>x \<in> LS M1 q1t\<close> assms(2) io_targets_observable_singleton_ex) 
   have "io \<in> LS M1 q1" 
     using assms(4) by auto
   have "io@x \<in> LS M1 q1" 
     using observable_io_targets_append[OF assms(2) \<open>io_targets M1 q1 io = { q1t }\<close> 
           \<open>io_targets M1 q1t x = {q1x}\<close>]
     by (metis io_targets_elim language_state singletonI) 
   then have "io@x \<in> LS M2 q2" 
     using assms(1) by blast
   then obtain q2x where "io_targets M2 q2 (io@x) = {q2x}"
     by (meson assms(3) io_targets_observable_singleton_ex)
   show "x \<in> LS M2 q2t"
     using observable_io_targets_split[OF assms(3) \<open>io_targets M2 q2 (io @ x) = {q2x}\<close> assms(5)] 
     by auto
 qed
 
 
 
 
 subsection \<open> Language subsets for input sequences \<close>
 
 text \<open>
 The following definitions describe restrictions of languages to only those IO-sequences that 
 exhibit a certain input sequence or whose input sequence is contained in a given set of
 input sequences.
 This allows to define the notion that some FSM is a reduction of another over a given set of
 input sequences, but not necessarily over the entire language of the latter FSM.
 \<close>
 
 fun language_state_for_input :: 
   "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> 'in list \<Rightarrow> ('in \<times> 'out) list set" where
   "language_state_for_input M q xs = {(xs || ys) | ys . (length xs = length ys \<and> (xs || ys) \<in> LS M q)}"
 
 fun language_state_for_inputs  :: 
   "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> 'in list set \<Rightarrow> ('in \<times> 'out) list set" 
     ("(LS\<^sub>i\<^sub>n _ _ _)" [1000,1000,1000]) where
   "language_state_for_inputs  M q ISeqs = {(xs || ys) | xs ys . (xs \<in> ISeqs 
                                                                   \<and> length xs = length ys 
                                                                   \<and> (xs || ys) \<in> LS M q)}"
 
 abbreviation "L\<^sub>i\<^sub>n M TS \<equiv> LS\<^sub>i\<^sub>n M (initial M) TS"
 
 abbreviation  "io_reduction_on M1 TS M2 \<equiv> (L\<^sub>i\<^sub>n M1 TS \<subseteq> L\<^sub>i\<^sub>n M2 TS)" 
 notation 
   io_reduction_on ("(_ \<preceq>\<lbrakk>_\<rbrakk> _)" [1000,0,0] 61)
 notation  (latex output)
   io_reduction_on ("(_ \<preceq>\<^bsub>_\<^esub> _)" [1000,0,0] 61)
 
 
 lemma language_state_for_input_alt_def :
   "language_state_for_input M q xs = LS\<^sub>i\<^sub>n M q {xs}"
   unfolding language_state_for_input.simps language_state_for_inputs.simps by blast
 
 lemma language_state_for_inputs_alt_def :
   "LS\<^sub>i\<^sub>n M q ISeqs = \<Union> (image (language_state_for_input M q) ISeqs)" 
   by auto
 
 lemma language_state_for_inputs_in_language_state :
   "LS\<^sub>i\<^sub>n M q T \<subseteq> language_state M q"
   unfolding language_state_for_inputs.simps language_state_def
   by blast 
 
 lemma language_state_for_inputs_map_fst :
   assumes "io \<in> language_state M q"
   and     "map fst io \<in> T"
 shows "io \<in> LS\<^sub>i\<^sub>n M q T"
 proof -
   let ?xs = "map fst io"
   let ?ys = "map snd io"
   have "?xs \<in> T \<and> length ?xs = length ?ys \<and> ?xs || ?ys \<in> language_state M q" 
     using assms(2,1) by auto
   then have "?xs || ?ys \<in> LS\<^sub>i\<^sub>n M q T" 
     unfolding language_state_for_inputs.simps by blast 
   then show ?thesis 
     by simp
 qed 
 
 lemma language_state_for_inputs_nonempty :
   assumes "set xs \<subseteq> inputs M"
   and     "completely_specified M"
   and     "q \<in> nodes M"
 shows "LS\<^sub>i\<^sub>n M q {xs} \<noteq> {}"
 using assms proof (induction xs arbitrary: q)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   then have "x \<in> inputs M" 
     by simp
   then obtain y q' where x_step : "q' \<in> succ M (x,y) q" 
     using Cons(3,4) unfolding completely_specified.simps by blast
   then have "path M ([(x,y)] || [q']) q \<and> length [q] = length [(x,y)]" 
             "target ([(x,y)] || [q']) q = q'" 
     by auto
   then have "q' \<in> nodes M" 
     using Cons(4) by (metis FSM.nodes_target)            
   then have "LS\<^sub>i\<^sub>n M q' {xs} \<noteq> {}" 
     using Cons.prems Cons.IH by auto
   then obtain ys where "length xs = length ys \<and> (xs || ys) \<in> LS M q'" 
     by auto
   then obtain tr where "path M ((xs || ys) || tr) q' \<and> length tr = length (xs || ys)" 
     by auto
   then have "path M ([(x,y)] @ (xs || ys) || [q'] @ tr) q 
               \<and> length ([q'] @ tr) = length ([(x,y)] @ (xs || ys))" 
     by (simp add: FSM.path.intros(2) x_step)
   then have "path M ((x#xs || y#ys) || [q'] @ tr) q \<and> length ([q'] @ tr) = length (x#xs || y#ys)" 
     by auto
   then have "(x#xs || y#ys) \<in> LS M q" 
     by (metis language_state)
   moreover have "length (x#xs) = length (y#ys)" 
     by (simp add: \<open>length xs = length ys \<and> xs || ys \<in> LS M q'\<close>) 
   ultimately have "(x#xs || y#ys) \<in> LS\<^sub>i\<^sub>n M q {x # xs}" 
     unfolding language_state_for_inputs.simps by blast
   then show ?case by blast
 qed
 
 lemma language_state_for_inputs_map_fst_contained :
   assumes "vs \<in> LS\<^sub>i\<^sub>n M q V"
 shows "map fst vs \<in> V" 
 proof -
   have "(map fst vs) || (map snd vs) = vs" 
     by auto
   then have "(map fst vs) || (map snd vs) \<in> LS\<^sub>i\<^sub>n M q V" 
     using assms by auto
   then show ?thesis by auto
 qed
 
 lemma language_state_for_inputs_empty : 
   assumes "[] \<in> V"
   shows "[] \<in> LS\<^sub>i\<^sub>n M q V"
 proof -
   have "[] \<in> language_state_for_input M q []" by auto
   then show ?thesis using language_state_for_inputs_alt_def by (metis UN_I assms) 
 qed
 
 lemma language_state_for_input_empty[simp] : 
   "language_state_for_input M q [] = {[]}"
 by auto
 
 
 lemma language_state_for_input_take :
   assumes "io \<in> language_state_for_input M q xs"
 shows "take n io \<in> language_state_for_input M q (take n xs)" 
 proof -
   obtain ys where "io = xs || ys" "length xs = length ys" "xs || ys \<in> language_state M q" 
     using assms by auto
   then obtain p where "length p = length xs" "path M ((xs || ys) || p) q "
     by auto 
   then have "path M (take n ((xs || ys) || p)) q"
     by (metis FSM.path_append_elim append_take_drop_id) 
   then have "take n (xs || ys) \<in> language_state M q"
     by (simp add: \<open>length p = length xs\<close> \<open>length xs = length ys\<close> language_state take_zip)
   then have "(take n xs) || (take n ys) \<in> language_state M q"
     by (simp add: take_zip) 
   
   have "take n io = (take n xs) || (take n ys)"
     using \<open>io = xs || ys\<close> take_zip by blast 
   moreover have "length (take n xs) = length (take n ys)"
     by (simp add: \<open>length xs = length ys\<close>) 
   ultimately show ?thesis 
     using \<open>(take n xs) || (take n ys) \<in> language_state M q\<close> 
     unfolding language_state_for_input.simps by blast
 qed
 
 lemma language_state_for_inputs_prefix :
   assumes "vs@xs \<in> L\<^sub>i\<^sub>n M1 {vs'@xs'}"
   and "length vs = length vs'"
 shows "vs \<in> L\<^sub>i\<^sub>n M1 {vs'}"
 proof -
   have "vs@xs \<in> L M1"
     using assms(1) by auto
   then have "vs \<in> L M1"
     by (meson language_state_prefix) 
   then have "vs \<in> L\<^sub>i\<^sub>n M1 {map fst vs}"
     by (meson insertI1 language_state_for_inputs_map_fst)
   moreover have "vs' = map fst vs"
     by (metis append_eq_append_conv assms(1) assms(2) language_state_for_inputs_map_fst_contained 
         length_map map_append singletonD)
   ultimately show ?thesis 
     by blast
 qed
 
 lemma language_state_for_inputs_union : 
   shows "LS\<^sub>i\<^sub>n M q T1 \<union> LS\<^sub>i\<^sub>n M q T2 = LS\<^sub>i\<^sub>n M q (T1 \<union> T2)"
   unfolding language_state_for_inputs.simps by blast
 
 lemma io_reduction_on_subset :
   assumes "io_reduction_on M1 T M2"
   and     "T' \<subseteq> T"
 shows "io_reduction_on M1 T' M2"
 proof (rule ccontr)
   assume "\<not> io_reduction_on M1 T' M2"
   then obtain xs' where "xs' \<in> T'" "\<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}"
   proof -
     have f1: "\<forall>ps P Pa. (ps::('a \<times> 'b) list) \<notin> P \<or> \<not> P \<subseteq> Pa \<or> ps \<in> Pa"
       by blast
     obtain pps :: "('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list" where
       "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> x0) = (pps x0 x1 \<in> x1 \<and> pps x0 x1 \<notin> x0)"
       by moura
     then have f2: "\<forall>P Pa. pps Pa P \<in> P \<and> pps Pa P \<notin> Pa \<or> P \<subseteq> Pa"
       by (meson subsetI)
     have f3: "\<forall>ps f c A. (ps::('a \<times> 'b) list) \<notin> LS\<^sub>i\<^sub>n f (c::'c) A \<or> map fst ps \<in> A"
       by (meson language_state_for_inputs_map_fst_contained)
     then have "L\<^sub>i\<^sub>n M1 T' \<subseteq> L\<^sub>i\<^sub>n M1 T"
       using f2 by (meson assms(2) language_state_for_inputs_in_language_state 
                     language_state_for_inputs_map_fst set_rev_mp)
     then show ?thesis
       using f3 f2 f1 by (meson \<open>\<not> io_reduction_on M1 T' M2\<close> assms(1) 
                           language_state_for_inputs_in_language_state 
                           language_state_for_inputs_map_fst)
   qed 
   then have "xs' \<in> T" 
     using assms(2) by blast
 
   have "\<not> io_reduction_on M1 T M2"
   proof -
     have f1: "\<forall>as. as \<notin> T' \<or> as \<in> T"
       using assms(2) by auto
     obtain pps :: "('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list" where
       "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> x0) = (pps x0 x1 \<in> x1 \<and> pps x0 x1 \<notin> x0)"
       by moura
     then have "\<forall>P Pa. (\<not> P \<subseteq> Pa \<or> (\<forall>ps. ps \<notin> P \<or> ps \<in> Pa)) 
                       \<and> (P \<subseteq> Pa \<or> pps Pa P \<in> P \<and> pps Pa P \<notin> Pa)"
       by blast
     then show ?thesis
       using f1 by (meson \<open>\<not> io_reduction_on M1 T' M2\<close> language_state_for_inputs_in_language_state 
                     language_state_for_inputs_map_fst language_state_for_inputs_map_fst_contained)
   qed 
 
   then show "False" 
     using assms(1) by auto
 qed
 
 subsection \<open> Sequences to failures \<close>
 
 text \<open>
 A sequence to a failure for FSMs @{verbatim M1} and @{verbatim M2} is a sequence such that any 
 proper prefix of it is contained in the languages of both @{verbatim M1} and @{verbatim M2}, while 
 the sequence itself is contained only in the language of A.
 
 That is, if a sequence to a failure for @{verbatim M1} and @{verbatim M2} exists, then 
 @{verbatim M1} is not a reduction of @{verbatim M2}.
 \<close>
 
 
 fun sequence_to_failure :: 
   "('in,'out,'state) FSM \<Rightarrow> ('in,'out,'state) FSM \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> bool" where
   "sequence_to_failure M1 M2 xs = (
     (butlast xs) \<in> (language_state M2 (initial M2) \<inter> language_state M1 (initial M1))
     \<and> xs \<in> (language_state M1 (initial M1) - language_state M2 (initial M2)))"
 
 
 lemma sequence_to_failure_ob :
   assumes "\<not> M1 \<preceq> M2"
   and     "well_formed M1"
   and     "well_formed M2"  
 obtains io
 where "sequence_to_failure M1 M2 io"
 proof -
   let ?diff = "{ io . io \<in> language_state M1 (initial M1) \<and> io \<notin> language_state M2 (initial M2)}"
   have "?diff \<noteq> empty" 
     using assms by auto
   moreover  obtain io where io_def[simp] : "io = arg_min length (\<lambda> io . io \<in> ?diff)" 
     using assms by auto
   ultimately have io_diff : "io \<in> ?diff" 
     using assms by (meson all_not_in_conv arg_min_natI) 
 
   then have "io \<noteq> []" 
     using assms io_def language_state by auto 
   then obtain io_init io_last where io_split[simp] : "io = io_init @ [io_last]" 
     by (metis append_butlast_last_id) 
 
   have io_init_inclusion : "io_init \<in> language_state M1 (initial M1) 
                             \<and> io_init \<in> language_state M2 (initial M2)"
   proof (rule ccontr)
     assume assm : "\<not> (io_init \<in> language_state M1 (initial M1) 
                         \<and> io_init \<in> language_state M2 (initial M2))"
 
     have "io_init @ [io_last] \<in> language_state M1 (initial M1)" 
       using io_diff io_split by auto
     then have "io_init \<in> language_state M1 (initial M1)" 
       by (meson language_state language_state_split) 
     moreover have "io_init \<notin> language_state M2 (initial M2)" 
       using assm calculation by auto
     ultimately have "io_init \<in> ?diff" 
       by auto 
     moreover have "length io_init < length io" 
       using io_split by auto 
     ultimately have "io \<noteq> arg_min length (\<lambda> io . io \<in> ?diff)"
     proof -
       have "\<exists>ps. ps \<in> {ps \<in> language_state M1 (initial M1). 
                               ps \<notin> language_state M2 (initial M2)} \<and> \<not> length io \<le> length ps"
         using \<open>io_init \<in> {io\<in> language_state M1 (initial M1). io \<notin> language_state M2 (initial M2)}\<close>
               \<open>length io_init < length io\<close> linorder_not_less 
         by blast
       then show ?thesis
         by (meson arg_min_nat_le)
     qed
     then show "False" using io_def by simp
   qed
 
   then have "sequence_to_failure M1 M2 io" 
     using io_split io_diff by auto
   then show ?thesis 
     using that by auto  
 qed
 
 lemma sequence_to_failure_succ :
   assumes "sequence_to_failure M1 M2 io"
   shows "\<forall> q \<in> io_targets M2 (initial M2) (butlast io) . succ M2 (last io) q = {}"
 proof
   have "io \<noteq> []"
     using assms by auto
   fix q assume "q \<in> io_targets M2 (initial M2) (butlast io)"
   then obtain tr where "q = target (butlast io || tr) (initial M2)"
                  and   "path M2 (butlast io || tr) (initial M2)"
                  and   "length (butlast io) = length tr" 
     unfolding io_targets.simps by auto
   
   show "succ M2 (last io) q = {}"
   proof (rule ccontr)
     assume "succ M2 (last io) q \<noteq> {}"
     then obtain q' where "q' \<in> succ M2 (last io) q"
       by blast
     then have "path M2 [(last io, q')] (target (butlast io || tr) (initial M2))" 
       using \<open>q = target (butlast io || tr) (initial M2)\<close> by auto
 
     have "path M2 ((butlast io || tr) @ [(last io, q')]) (initial M2)"
       using \<open>path M2 (butlast io || tr) (initial M2)\<close> 
             \<open>path M2 [(last io, q')] (target (butlast io || tr) (initial M2))\<close> by auto
 
     have "butlast io @ [last io] = io"
       by (meson \<open>io \<noteq> []\<close> append_butlast_last_id)
 
     have "path M2 (io || (tr@[q'])) (initial M2)"
     proof -
       have "path M2 ((butlast io || tr) @ ([last io] || [q'])) (initial M2)"
         by (simp add: FSM.path_append \<open>path M2 (butlast io || tr) (initial M2)\<close> 
               \<open>path M2 [(last io, q')] (target (butlast io || tr) (initial M2))\<close>)
       then show ?thesis
         by (metis (no_types) \<open>butlast io @ [last io] = io\<close> 
               \<open>length (butlast io) = length tr\<close> zip_append)
     qed
     
     have "io \<in> L M2"
     proof -
       have "length tr + (0 + Suc 0) = length io"
         by (metis \<open>butlast io @ [last io] = io\<close> \<open>length (butlast io) = length tr\<close> 
             length_append list.size(3) list.size(4))
       then show ?thesis
         using \<open>path M2 (io || tr @ [q']) (initial M2)\<close> by fastforce
     qed
     then show "False" 
       using assms by auto
   qed
 qed
 
 lemma sequence_to_failure_non_nil : 
   assumes "sequence_to_failure M1 M2 xs"
   shows "xs \<noteq> []" 
 proof 
   assume "xs = []"
   then have "xs \<in> L M1 \<inter> L M2" 
     by auto
   then show "False" using assms by auto
 qed
 
 lemma sequence_to_failure_from_arbitrary_failure :
   assumes "vs@xs \<in> L M1 - L M2"
     and "vs \<in> L M2 \<inter> L M1"
 shows "\<exists> xs' . prefix xs' xs \<and> sequence_to_failure M1 M2 (vs@xs')"
 using assms proof (induction xs rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x xs)
 
   have "vs @ xs \<in> L M1"
     using snoc.prems(1) by (metis Diff_iff append.assoc language_state_prefix) 
 
   show ?case
   proof (cases "vs@xs \<in> L M2")
     case True
     have "butlast (vs@xs@[x]) \<in> L M2 \<inter> L M1" 
       using True \<open>vs @ xs \<in> L M1\<close> by (simp add: butlast_append) 
     then show ?thesis
       using sequence_to_failure.simps snoc.prems by blast
   next
     case False
     then have "vs@xs \<in> L M1 - L M2"
       using \<open>vs @ xs \<in> L M1\<close> by blast
     then obtain xs' where "prefix xs' xs" "sequence_to_failure M1 M2 (vs@xs')"
       using snoc.prems(2) snoc.IH by blast
     then show ?thesis
       using prefix_snoc by auto 
   qed 
 qed  
 
 
 text \<open>
 The following lemma shows that if @{verbatim M1} is not a reduction of @{verbatim M2}, then a 
 minimal sequence to a failure exists that is of length at most the number of states in 
 @{verbatim M1} times the number of states in @{verbatim M2}. 
 \<close>
 
 lemma sequence_to_failure_length :
   assumes "well_formed M1"
   and     "well_formed M2"
   and     "observable M1"
   and     "observable M2"
   and     "\<not> M1 \<preceq> M2"
   shows "\<exists> xs . sequence_to_failure M1 M2 xs \<and> length xs \<le> |M2| * |M1|"
 proof -
 
   obtain seq where "sequence_to_failure M1 M2 seq" 
     using assms sequence_to_failure_ob by blast
   then have "seq \<noteq> []" 
     by auto
 
   let ?bls = "butlast seq"
   have "?bls \<in> L M1" "?bls \<in> L M2" 
     using \<open>sequence_to_failure M1 M2 seq\<close> by auto
 
 
   then obtain tr1b tr2b where 
     "path M1 (?bls || tr1b) (initial M1)"
     "length tr1b = length ?bls"
     "path M2 (?bls || tr2b) (initial M2)"
     "length ?bls = length tr2b"
     by fastforce
   then have "length tr2b = length tr1b" 
     by auto
 
   let ?PM = "product M2 M1"
   have "well_formed ?PM" 
     using well_formed_product[OF assms(1,2)] by assumption
   
   have "path ?PM (?bls || tr2b || tr1b) (initial M2, initial M1)" 
     using product_path[OF \<open>length ?bls = length tr2b\<close> \<open>length tr2b = length tr1b\<close>, 
                        of M2 M1 "initial M2" "initial M1"]
     using \<open>path M1 (butlast seq || tr1b) (initial M1)\<close> 
           \<open>path M2 (butlast seq || tr2b) (initial M2)\<close> 
     by blast
 
   let ?q1b = "target (?bls || tr1b) (initial M1)"
   let ?q2b = "target (?bls || tr2b) (initial M2)"
 
    
   have "io_targets M2 (initial M2) ?bls = {?q2b}"
     by (metis \<open>length (butlast seq) = length tr2b\<close> \<open>path M2 (butlast seq || tr2b) (initial M2)\<close> 
         assms(4) obs_target_is_io_targets)
   have "io_targets M1 (initial M1) ?bls = {?q1b}"
     by (metis \<open>length tr1b = length (butlast seq)\<close> \<open>path M1 (butlast seq || tr1b) (initial M1)\<close> 
         assms(3) obs_target_is_io_targets)
 
 
 
   have "(?q2b, ?q1b) \<in> reachable (product M2 M1) (initial M2, initial M1)"
   proof -
     have "target (butlast seq || tr2b || tr1b) (initial M2, initial M1) 
             \<in> reachable (product M2 M1) (initial M2, initial M1)"
       using \<open>path (product M2 M1) (butlast seq || tr2b || tr1b) (initial M2, initial M1)\<close> by blast
     then show ?thesis
       using \<open>length (butlast seq) = length tr2b\<close> \<open>length tr2b = length tr1b\<close> by auto
   qed
 
   
 
   have "(initial M2, initial M1) \<in> nodes (product M2 M1)"
     by (simp add: FSM.nodes.initial) 
 
   obtain p where repFreePath : "path (product M2 M1) p (initial M2, initial M1) \<and>
         target p (initial M2, initial M1) =
         (?q2b,?q1b)"
         "distinct ((initial M2, initial M1) # states p (initial M2, initial M1))" 
     using reaching_path_without_repetition[OF \<open>well_formed ?PM\<close> 
           \<open>(?q2b, ?q1b) \<in> reachable (product M2 M1) (initial M2, initial M1)\<close> 
           \<open>(initial M2, initial M1) \<in> nodes (product M2 M1)\<close>] 
     by blast
   
   then have "set (states p (initial M2, initial M1)) \<subseteq> nodes ?PM"
     by (simp add: FSM.nodes_states \<open>(initial M2, initial M1) \<in> nodes (product M2 M1)\<close>) 
   moreover have "(initial M2, initial M1) \<notin> set (states p (initial M2, initial M1))" 
     using \<open>distinct ((initial M2, initial M1) # states p (initial M2, initial M1))\<close> by auto
   ultimately have "set (states p (initial M2, initial M1)) \<subseteq> nodes ?PM - {(initial M2,initial M1)}"
     by blast
   moreover have "finite (nodes ?PM)" 
     using \<open>well_formed ?PM\<close> by auto
   ultimately have "card (set (states p (initial M2, initial M1))) < card (nodes ?PM)"
     by (metis \<open>(initial M2, initial M1) \<in> nodes (product M2 M1)\<close> 
         \<open>(initial M2, initial M1) \<notin> set (states p (initial M2, initial M1))\<close> 
         \<open>set (states p (initial M2, initial M1)) \<subseteq> nodes (product M2 M1)\<close> 
         psubsetI psubset_card_mono)
 
   moreover have "card (set (states p (initial M2, initial M1))) 
                   = length (states p (initial M2, initial M1))"
     using distinct_card repFreePath(2) by fastforce
   ultimately have "length (states p (initial M2, initial M1)) < |?PM|"
     by linarith
   then have "length p < |?PM|" 
     by auto
  
 
 
   let ?p1 = "map (snd \<circ> snd) p"
   let ?p2 = "map (fst \<circ> snd) p"
   let ?pIO = "map fst p"
 
   have "p = ?pIO || ?p2 || ?p1" 
     by (metis map_map zip_map_fst_snd)
 
 
   have "path M2 (?pIO || ?p2) (initial M2)"  
        "path M1 (?pIO || ?p1) (initial M1)" 
     using product_path[of ?pIO ?p2 ?p1 M2 M1] 
     using \<open>p = ?pIO || ?p2 || ?p1\<close> repFreePath(1) by auto
 
   have "(?q2b, ?q1b) = (target (?pIO || ?p2 || ?p1) (initial M2, initial M1))" 
     using \<open>p = ?pIO || ?p2 || ?p1\<close> repFreePath(1) by auto
 
   then have "?q2b = target (?pIO || ?p2) (initial M2)" 
             "?q1b = target (?pIO || ?p1) (initial M1)" 
     by auto
 
   have "io_targets M2 (initial M2) ?pIO = {?q2b}"
     by (metis \<open>path M2 (map fst p || map (fst \<circ> snd) p) (initial M2)\<close> 
         \<open>target (?bls || tr2b) (initial M2) = target (map fst p || map (fst \<circ> snd) p) (initial M2)\<close> 
         assms(4) length_map obs_target_is_io_targets)
 
   have "io_targets M1 (initial M1) ?pIO = {?q1b}"
     by (metis \<open>path M1 (map fst p || map (snd \<circ> snd) p) (initial M1)\<close> 
         \<open>target (?bls || tr1b) (initial M1) = target (map fst p || map (snd \<circ> snd) p) (initial M1)\<close> 
         assms(3) length_map obs_target_is_io_targets)
 
     
   
   have "seq \<in> L M1" "seq \<notin> L M2"
     using \<open>sequence_to_failure M1 M2 seq\<close> by auto
 
   have "io_targets M1 (initial M1) ?bls = {?q1b}"
     by (metis \<open>length tr1b = length (butlast seq)\<close> \<open>path M1 (butlast seq || tr1b) (initial M1)\<close> 
         assms(3) obs_target_is_io_targets)
   
   obtain q1s where "io_targets M1 (initial M1) seq = {q1s}"
     by (meson \<open>seq \<in> L M1\<close> assms(3) io_targets_observable_singleton_ob)
   
 
   moreover have "seq = (butlast seq)@[last seq]"
     using \<open>seq \<noteq> []\<close> by auto
   ultimately have "io_targets M1 (initial M1) ((butlast seq)@[last seq]) = {q1s}" 
     by auto
   
 
   have "io_targets M1 ?q1b [last seq] = {q1s}"
     using observable_io_targets_suffix[OF assms(3) \<open>io_targets M1 (initial M1) ?bls = {?q1b}\<close> 
           \<open>io_targets M1 (initial M1) ((butlast seq)@[last seq]) = {q1s}\<close>] by assumption
   then obtain tr1s where "q1s = target ([last seq] || tr1s) ?q1b" 
                          "path M1 ([last seq] || tr1s) ?q1b" 
                          "length [last seq] = length tr1s"
     by auto
 
   have "path M1 ([last seq] || [q1s]) ?q1b"
     by (metis (no_types) \<open>length [last seq] = length tr1s\<close> 
         \<open>path M1 ([last seq] || tr1s) (target (butlast seq || tr1b) (initial M1))\<close> 
         \<open>q1s = target ([last seq] || tr1s) (target (butlast seq || tr1b) (initial M1))\<close> 
         append_Nil append_butlast_last_id butlast.simps(2) length_butlast length_greater_0_conv 
         not_Cons_self2 target_alt_def(2))
   then have "q1s \<in> succ M1 (last seq) ?q1b" 
     by auto
 
   have "succ M2 (last seq) ?q2b = {}"
   proof (rule ccontr)
     assume "succ M2 (last seq) (target (butlast seq || tr2b) (initial M2)) \<noteq> {}"
     then obtain q2f where "q2f \<in> succ M2 (last seq) ?q2b"
       by blast
     then have "target ([last seq] || [q2f]) ?q2b = q2f" 
               "path M2 ([last seq] || [q2f]) ?q2b" 
               "length [q2f] = length [last seq]" 
       by auto
     then have "q2f \<in> io_targets M2 ?q2b [last seq]" 
       by (metis io_target_from_path)
     then have "io_targets M2 ?q2b [last seq] = {q2f}" 
       using assms(4) by (meson observable_io_target_is_singleton)
 
     
     have "io_targets M2 (initial M2) (butlast seq @ [last seq]) = {q2f}"
       using observable_io_targets_append[OF assms(4) \<open>io_targets M2 (initial M2) ?bls = {?q2b}\<close> 
             \<open>io_targets M2 ?q2b [last seq] = {q2f}\<close>] by assumption
     then have "seq \<in> L M2" 
       using \<open>seq = butlast seq @ [last seq]\<close> by auto
     then show "False"
       using \<open>seq \<notin> L M2\<close> by blast 
   qed
 
   have "?pIO \<in> L M1" "?pIO \<in> L M2" 
     using \<open>path M1 (?pIO || ?p1) (initial M1)\<close> \<open>path M2 (?pIO || ?p2) (initial M2)\<close> by auto
   then have "butlast (?pIO@[last seq]) \<in> L M1 \<inter> L M2"
     by auto
 
   have "?pIO@[last seq] \<in> L M1" 
     using observable_io_targets_append[OF assms(3) \<open>io_targets M1 (initial M1) ?pIO = {?q1b}\<close> 
           \<open>io_targets M1 ?q1b [last seq] = {q1s}\<close>] 
     by (metis all_not_in_conv insert_not_empty io_targets_elim language_state)
            
   moreover have "?pIO@[last seq] \<notin> L M2"
   proof
     assume "?pIO@[last seq] \<in> L M2"
     then obtain q2f where "io_targets M2 (initial M2) (?pIO@[last seq]) = {q2f}"
       by (meson assms(4) io_targets_observable_singleton_ob)
       
     have "io_targets M2 ?q2b [last seq] = {q2f}"
       using observable_io_targets_split[OF assms(4) 
             \<open>io_targets M2 (initial M2) (?pIO@[last seq]) = {q2f}\<close> 
             \<open>io_targets M2 (initial M2) (map fst p) = {?q2b}\<close>] by assumption
 
     then have "q2f \<in> succ M2 (last seq) ?q2b" 
       by (simp add: io_targets_succ)
     then show "False"
       using \<open>succ M2 (last seq) ?q2b = {}\<close> by auto
   qed
 
   ultimately have "?pIO@[last seq] \<in> L M1 - L M2"
     by auto
 
 
   have "sequence_to_failure M1 M2 (?pIO@[last seq])"
     using \<open>butlast (?pIO@[last seq]) \<in> L M1 \<inter> L M2\<close> \<open>?pIO@[last seq] \<in> L M1 - L M2\<close> by auto
 
   have "length (?pIO@[last seq]) = Suc (length ?pIO)"
     by auto
   then have "length (?pIO@[last seq]) \<le> |?PM|"
     using \<open>length p < |?PM|\<close> by auto
 
   
   have "card (nodes M2 \<times> nodes M1) \<le> |M2| * |M1|"
     by (simp add: card_cartesian_product)
   
   have "finite (nodes M2 \<times> nodes M1)"
   proof
     show "finite (nodes M2)" 
       using assms by auto
     show "finite (nodes M1)" 
       using assms by auto
   qed
     
   have "|?PM| \<le> |M2| * |M1|" 
     by (meson \<open>card (nodes M2 \<times> nodes M1) \<le> |M2| * |M1|\<close> \<open>finite (nodes M2 \<times> nodes M1)\<close> 
         card_mono dual_order.trans product_nodes)
 
   then have "length (?pIO@[last seq]) \<le> |M2| * |M1|"
     using \<open>length (?pIO@[last seq]) \<le> |?PM|\<close> by auto
 
   then have "sequence_to_failure M1 M2 (?pIO@[last seq]) \<and> length (?pIO@[last seq]) \<le> |M2| * |M1|" 
     using \<open>sequence_to_failure M1 M2 (?pIO@[last seq])\<close> by auto
   then show ?thesis
     by blast
 qed
 
 
 
 subsection \<open> Minimal sequence to failure extending \<close>
 
 text \<open>
 A minimal sequence to a failure extending some some set of IO-sequences is a sequence to a failure
 of minimal length such that a prefix of that sequence is contained in the set.
 \<close>
 
 
 fun minimal_sequence_to_failure_extending :: 
   "'in list set \<Rightarrow> ('in,'out,'state) FSM \<Rightarrow> ('in,'out,'state) FSM \<Rightarrow> ('in \<times> 'out) list 
     \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> bool" where
   "minimal_sequence_to_failure_extending V M1 M2 v' io = (
    v' \<in> L\<^sub>i\<^sub>n M1 V \<and> sequence_to_failure M1 M2 (v' @ io) 
               \<and> \<not> (\<exists> io' . \<exists> w' \<in> L\<^sub>i\<^sub>n M1 V . sequence_to_failure M1 M2 (w' @ io') 
                                                             \<and> length io' < length io))"
 
 lemma minimal_sequence_to_failure_extending_det_state_cover_ob :
   assumes "well_formed M1"
   and     "well_formed M2"
   and     "observable M2"
   and     "is_det_state_cover M2 V"
   and     "\<not> M1 \<preceq> M2"
 obtains vs xs
 where "minimal_sequence_to_failure_extending V M1 M2 vs xs" 
 proof -
   \<comment> \<open>set of all IO-sequences that extend some reaction of M1 to V to a failure\<close>
   let ?exts = "{xs. \<exists>vs' \<in> L\<^sub>i\<^sub>n M1 V. sequence_to_failure M1 M2 (vs'@xs)}"
   
   \<comment> \<open>arbitrary sequence to failure\<close>
   \<comment> \<open>must be contained in ?exts as V contains the empty sequence\<close>
   obtain stf where "sequence_to_failure M1 M2 stf"
     using assms sequence_to_failure_ob by blast
   then have "sequence_to_failure M1 M2 ([] @ stf)" 
     by simp
   moreover have "[] \<in> L\<^sub>i\<^sub>n M1 V"
     by (meson assms(4) det_state_cover_initial language_state_for_inputs_empty)
   ultimately have "stf \<in> ?exts"
     by blast
 
   \<comment> \<open>the minimal length sequence of ?exts\<close>
   \<comment> \<open>is a minimal sequence to a failure extending V by construction\<close>
   let ?xsMin = "arg_min length (\<lambda>xs. xs \<in> ?exts)"
   have xsMin_def : "?xsMin \<in> ?exts 
                     \<and> (\<forall>xs \<in> ?exts. length  ?xsMin \<le> length xs)"
     by (metis (no_types, lifting) \<open>stf \<in> ?exts\<close> arg_min_nat_lemma) 
   then obtain vs where "vs \<in> L\<^sub>i\<^sub>n M1 V 
                         \<and> sequence_to_failure M1 M2 (vs @ ?xsMin)"
     by blast
   moreover have "\<not>(\<exists>xs . \<exists>ws \<in> L\<^sub>i\<^sub>n M1 V. sequence_to_failure M1 M2 (ws@xs) 
                                          \<and> length xs < length ?xsMin)"
     using leD xsMin_def by blast
   ultimately have "minimal_sequence_to_failure_extending V M1 M2 vs ?xsMin" 
     by auto
   then show ?thesis 
     using that by auto
 qed
   
 lemma mstfe_prefix_input_in_V :
   assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
   shows "(map fst vs) \<in> V"
 proof -
   have "vs \<in> L\<^sub>i\<^sub>n M1 V" 
     using assms by auto
   then show ?thesis 
     using language_state_for_inputs_map_fst_contained by auto
 qed
 
 
 
 
 subsection \<open> Complete test suite derived from the product machine \<close>
 
 text \<open>
 The classical result of testing FSMs for language inclusion :
 Any failure can be observed by a sequence of length at
 most n*m where n is the number of states of the reference 
 model (here FSM @{verbatim M2}) and m is an upper bound on the number
 of states of the SUT (here FSM @{verbatim M1}).
 \<close>
 
 lemma product_suite_soundness :
   assumes "well_formed M1"
   and     "well_formed M2"
   and     "observable M1"
   and     "observable M2"
   and     "inputs M2 = inputs M1"
   and     "|M1| \<le> m "
 shows     "\<not> M1 \<preceq> M2 \<longrightarrow> \<not> M1 \<preceq>\<lbrakk>{xs . set xs \<subseteq> inputs M2 \<and> length xs \<le> |M2| * m}\<rbrakk> M2" 
   (is "\<not> M1 \<preceq> M2 \<longrightarrow> \<not> M1 \<preceq>\<lbrakk>?TS\<rbrakk> M2")
 proof 
   assume "\<not> M1 \<preceq> M2"
   obtain stf where "sequence_to_failure M1 M2 stf \<and> length stf \<le> |M2| * |M1|"
     using sequence_to_failure_length[OF assms(1-4) \<open>\<not> M1 \<preceq> M2\<close>] by blast
   then have "sequence_to_failure M1 M2 stf" "length stf \<le> |M2| * |M1|"
     by auto
 
   then have "stf \<in> L M1"
     by auto
   let ?xs = "map fst stf"
   have "set ?xs \<subseteq> inputs M1"
     by (meson \<open>stf \<in> L M1\<close> assms(1) language_state_inputs)
   then have "set ?xs \<subseteq> inputs M2"
     using assms(5) by auto
  
   have "length ?xs \<le> |M2| * |M1|"
     using \<open>length stf \<le> |M2| * |M1|\<close> by auto 
   have "length ?xs \<le> |M2| * m"
   proof -
     show ?thesis
       by (metis (no_types) \<open>length (map fst stf) \<le> |M2| * |M1|\<close> \<open>|M1| \<le> m\<close> 
           dual_order.trans mult.commute mult_le_mono1)
   qed 
 
   have "stf \<in> L\<^sub>i\<^sub>n M1 {?xs}"
     by (meson \<open>stf \<in> L M1\<close> insertI1 language_state_for_inputs_map_fst)
   have "?xs \<in> ?TS" 
     using \<open>set ?xs \<subseteq> inputs M2\<close> \<open>length ?xs \<le> |M2| * m\<close> by blast
   have "stf \<in> L\<^sub>i\<^sub>n M1 ?TS"
     by (metis (no_types, lifting) \<open>map fst stf \<in> {xs. set xs \<subseteq> inputs M2 \<and> length xs \<le> |M2| * m}\<close> 
         \<open>stf \<in> L M1\<close> language_state_for_inputs_map_fst) 
 
   have "stf \<notin> L M2"
     using \<open>sequence_to_failure M1 M2 stf\<close> by auto
   then have "stf \<notin> L\<^sub>i\<^sub>n M2 ?TS"
     by auto 
     
 
   show "\<not> M1 \<preceq>\<lbrakk>?TS\<rbrakk> M2"
     using \<open>stf \<in> L\<^sub>i\<^sub>n M1 ?TS\<close> \<open>stf \<notin> L\<^sub>i\<^sub>n M2 ?TS\<close> by blast
 qed
 
 
 lemma product_suite_completeness :
   assumes "well_formed M1"
   and     "well_formed M2"
   and     "observable M1"
   and     "observable M2"
   and     "inputs M2 = inputs M1"
   and     "|M1| \<le> m "
 shows     "M1 \<preceq> M2 \<longleftrightarrow> M1 \<preceq>\<lbrakk>{xs . set xs \<subseteq> inputs M2 \<and> length xs \<le> |M2| * m}\<rbrakk> M2" 
   (is "M1 \<preceq> M2 \<longleftrightarrow> M1 \<preceq>\<lbrakk>?TS\<rbrakk> M2")
 proof 
   show "M1 \<preceq> M2 \<Longrightarrow> M1 \<preceq>\<lbrakk>?TS\<rbrakk> M2" \<comment> \<open>soundness holds trivially\<close>
     unfolding language_state_for_inputs.simps io_reduction.simps by blast
   show "M1 \<preceq>\<lbrakk>?TS\<rbrakk> M2 \<Longrightarrow> M1 \<preceq> M2"
     using product_suite_soundness[OF assms] by auto
 qed
 
 
 end
\ No newline at end of file
diff --git a/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Model.thy b/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Model.thy
--- a/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Model.thy
+++ b/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Model.thy
@@ -1,9074 +1,9074 @@
 (*  Title:      Stateful_Protocol_Model.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\<open>Stateful Protocol Model\<close>
 theory Stateful_Protocol_Model
   imports Stateful_Protocol_Composition_and_Typing.Stateful_Compositionality
           Transactions Term_Abstraction
 begin
 
 subsection \<open>Locale Setup\<close>
 locale stateful_protocol_model =
   fixes arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   assumes Ana\<^sub>f_assm1: "\<forall>f. let (K, M) = Ana\<^sub>f f in (\<forall>k \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K).
       is_Fun k \<longrightarrow> (is_Fu (the_Fun k)) \<and> length (args k) = arity\<^sub>f (the_Fu (the_Fun k)))"
     and Ana\<^sub>f_assm2: "\<forall>f. let (K, M) = Ana\<^sub>f f in \<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K) \<union> set M. i < arity\<^sub>f f"
     and public\<^sub>f_assm: "\<forall>f. arity\<^sub>f f > (0::nat) \<longrightarrow> public\<^sub>f f"
     and \<Gamma>\<^sub>f_assm: "\<forall>f. arity\<^sub>f f = (0::nat) \<longrightarrow> \<Gamma>\<^sub>f f \<noteq> None"
     and label_witness_assm: "label_witness1 \<noteq> label_witness2"
 begin
 
 lemma Ana\<^sub>f_assm1_alt: 
   assumes "Ana\<^sub>f f = (K,M)" "k \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)"
   shows "(\<exists>x. k = Var x) \<or> (\<exists>h T. k = Fun (Fu h) T \<and> length T = arity\<^sub>f h)"
 proof (cases k)
   case (Fun g T)
   let ?P = "\<lambda>k. is_Fun k \<longrightarrow> is_Fu (the_Fun k) \<and> length (args k) = arity\<^sub>f (the_Fu (the_Fun k))"
   let ?Q = "\<lambda>K M. \<forall>k \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K). ?P k"
 
   have "?Q (fst (Ana\<^sub>f f)) (snd (Ana\<^sub>f f))" using Ana\<^sub>f_assm1 split_beta[of ?Q "Ana\<^sub>f f"] by meson
   hence "?Q K M" using assms(1) by simp
   hence "?P k" using assms(2) by blast
   thus ?thesis using Fun by (cases g) auto
 qed simp
 
 lemma Ana\<^sub>f_assm2_alt:
   assumes "Ana\<^sub>f f = (K,M)" "i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K) \<union> set M"
   shows "i < arity\<^sub>f f"
 using Ana\<^sub>f_assm2 assms by fastforce
 
 
 subsection \<open>Definitions\<close>
 fun arity where
   "arity (Fu f) = arity\<^sub>f f"
 | "arity (Set s) = arity\<^sub>s s"
 | "arity (Val _) = 0"
 | "arity (Abs _) = 0"
 | "arity Pair = 2"
 | "arity (Attack _) = 0"
 | "arity OccursFact = 2"
 | "arity OccursSec = 0"
 | "arity (PubConst _ _) = 0"
 
 fun public where
   "public (Fu f) = public\<^sub>f f"
 | "public (Set s) = (arity\<^sub>s s > 0)"
 | "public (Val n) = False"
 | "public (Abs _) = False"
 | "public Pair = True"
 | "public (Attack _) = False"
 | "public OccursFact = True"
 | "public OccursSec = False"
 | "public (PubConst _ _) = True"
 
 fun Ana where
   "Ana (Fun (Fu f) T) = (
     if arity\<^sub>f f = length T \<and> arity\<^sub>f f > 0
     then let (K,M) = Ana\<^sub>f f in (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M)
     else ([], []))"
 | "Ana _ = ([], [])"
 
 definition \<Gamma>\<^sub>v where
   "\<Gamma>\<^sub>v v \<equiv> (
     if (\<forall>t \<in> subterms (fst v).
           case t of (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T | _ \<Rightarrow> True)
     then fst v
     else TAtom Bottom)"
 
 fun \<Gamma> where
   "\<Gamma> (Var v) = \<Gamma>\<^sub>v v"
 | "\<Gamma> (Fun f T) = (
     if arity f = 0
     then case f of
       (Fu g) \<Rightarrow> TAtom (case \<Gamma>\<^sub>f g of Some a \<Rightarrow> Atom a | None \<Rightarrow> Bottom)
     | (Val _) \<Rightarrow> TAtom Value
     | (Abs _) \<Rightarrow> TAtom AbsValue
     | (Set _) \<Rightarrow> TAtom SetType
     | (Attack _) \<Rightarrow> TAtom AttackType
     | OccursSec \<Rightarrow> TAtom OccursSecType
     | (PubConst a _) \<Rightarrow> TAtom a
     | _ \<Rightarrow> TAtom Bottom
     else TComp f (map \<Gamma> T))"
 
 lemma \<Gamma>_consts_simps[simp]:
   "arity\<^sub>f g = 0 \<Longrightarrow> \<Gamma> (Fun (Fu g) []::('fun,'atom,'sets,'lbl) prot_term)
                     = TAtom (case \<Gamma>\<^sub>f g of Some a \<Rightarrow> Atom a | None \<Rightarrow> Bottom)"
   "\<Gamma> (Fun (Val n) []::('fun,'atom,'sets,'lbl) prot_term) = TAtom Value"
   "\<Gamma> (Fun (Abs b) []::('fun,'atom,'sets,'lbl) prot_term) = TAtom AbsValue"
   "arity\<^sub>s s = 0 \<Longrightarrow> \<Gamma> (Fun (Set s) []::('fun,'atom,'sets,'lbl) prot_term) = TAtom SetType"
   "\<Gamma> (Fun (Attack x) []::('fun,'atom,'sets,'lbl) prot_term) = TAtom AttackType"
   "\<Gamma> (Fun OccursSec []::('fun,'atom,'sets,'lbl) prot_term) = TAtom OccursSecType"
   "\<Gamma> (Fun (PubConst a t) []::('fun,'atom,'sets,'lbl) prot_term) = TAtom a"
 by simp+
 
 lemma \<Gamma>_Fu_simps[simp]:
   "arity\<^sub>f f \<noteq> 0 \<Longrightarrow> \<Gamma> (Fun (Fu f) T) = TComp (Fu f) (map \<Gamma> T)" (is "?A1 \<Longrightarrow> ?A2")
   "arity\<^sub>f f = 0 \<Longrightarrow> \<Gamma>\<^sub>f f = Some a \<Longrightarrow> \<Gamma> (Fun (Fu f) T) = TAtom (Atom a)" (is "?B1 \<Longrightarrow> ?B2 \<Longrightarrow> ?B3")
   "arity\<^sub>f f = 0 \<Longrightarrow> \<Gamma>\<^sub>f f = None \<Longrightarrow> \<Gamma> (Fun (Fu f) T) = TAtom Bottom" (is "?C1 \<Longrightarrow> ?C2 \<Longrightarrow> ?C3")
   "\<Gamma> (Fun (Fu f) T) \<noteq> TAtom Value" (is ?D)
   "\<Gamma> (Fun (Fu f) T) \<noteq> TAtom AttackType" (is ?E)
   "\<Gamma> (Fun (Fu f) T) \<noteq> TAtom OccursSecType" (is ?F)
 proof -
   show "?A1 \<Longrightarrow> ?A2" by simp
   show "?B1 \<Longrightarrow> ?B2 \<Longrightarrow> ?B3" by simp
   show "?C1 \<Longrightarrow> ?C2 \<Longrightarrow> ?C3" by simp
   show ?D by (cases "\<Gamma>\<^sub>f f") simp_all
   show ?E by (cases "\<Gamma>\<^sub>f f") simp_all
   show ?F by (cases "\<Gamma>\<^sub>f f") simp_all
 qed
 
 lemma \<Gamma>_Set_simps[simp]:
   "arity\<^sub>s s \<noteq> 0 \<Longrightarrow> \<Gamma> (Fun (Set s) T) = TComp (Set s) (map \<Gamma> T)"
   "\<Gamma> (Fun (Set s) T) = TAtom SetType \<or> \<Gamma> (Fun (Set s) T) = TComp (Set s) (map \<Gamma> T)"
   "\<Gamma> (Fun (Set s) T) \<noteq> TAtom Value"
   "\<Gamma> (Fun (Set s) T) \<noteq> TAtom (Atom a)"
   "\<Gamma> (Fun (Set s) T) \<noteq> TAtom AttackType"
   "\<Gamma> (Fun (Set s) T) \<noteq> TAtom OccursSecType"
   "\<Gamma> (Fun (Set s) T) \<noteq> TAtom Bottom"
 by auto
 
 
 subsection \<open>Locale Interpretations\<close>
 lemma Ana_Fu_cases:
   assumes "Ana (Fun f T) = (K,M)"
     and "f = Fu g"
     and "Ana\<^sub>f g = (K',M')"
   shows "(K,M) = (if arity\<^sub>f g = length T \<and> arity\<^sub>f g > 0
                   then (K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M')
                   else ([],[]))" (is ?A)
     and "(K,M) = (K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M') \<or> (K,M) = ([],[])" (is ?B)
 proof -
   show ?A using assms by (cases "arity\<^sub>f g = length T \<and> arity\<^sub>f g > 0") auto
   thus ?B by metis
 qed
 
 lemma Ana_Fu_intro:
   assumes "arity\<^sub>f f = length T" "arity\<^sub>f f > 0"
     and "Ana\<^sub>f f = (K',M')"
   shows "Ana (Fun (Fu f) T) = (K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M')"
 using assms by simp
 
 lemma Ana_Fu_elim:
   assumes "Ana (Fun f T) = (K,M)"
     and "f = Fu g"
     and "Ana\<^sub>f g = (K',M')"
     and "(K,M) \<noteq> ([],[])"
   shows "arity\<^sub>f g = length T" (is ?A)
     and "(K,M) = (K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M')" (is ?B)
 proof -
   show ?A using assms by force
   moreover have "arity\<^sub>f g > 0" using assms by force
   ultimately show ?B using assms by auto
 qed
 
 lemma Ana_nonempty_inv:
   assumes "Ana t \<noteq> ([],[])"
   shows "\<exists>f T. t = Fun (Fu f) T \<and> arity\<^sub>f f = length T \<and> arity\<^sub>f f > 0 \<and>
                (\<exists>K M. Ana\<^sub>f f = (K, M) \<and> Ana t = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M))"
 using assms
 proof (induction t rule: Ana.induct)
   case (1 f T)
   hence *: "arity\<^sub>f f = length T" "0 < arity\<^sub>f f"
            "Ana (Fun (Fu f) T) = (case Ana\<^sub>f f of (K, M) \<Rightarrow> (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M))"
     using Ana.simps(1)[of f T] unfolding Let_def by metis+
 
   obtain K M where **: "Ana\<^sub>f f = (K, M)" by (metis surj_pair)
   hence "Ana (Fun (Fu f) T) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M)" using *(3) by simp
   thus ?case using ** *(1,2) by blast
 qed simp_all
 
 lemma assm1:
   assumes "Ana t = (K,M)"
   shows "fv\<^sub>s\<^sub>e\<^sub>t (set K) \<subseteq> fv t"
 using assms
 proof (induction t rule: term.induct)
   case (Fun f T)
   have aux: "fv\<^sub>s\<^sub>e\<^sub>t (set K \<cdot>\<^sub>s\<^sub>e\<^sub>t (!) T) \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t (set T)"
     when K: "\<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K). i < length T"
     for K::"(('fun,'atom,'sets,'lbl) prot_fun, nat) term list"
   proof
     fix x assume "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K \<cdot>\<^sub>s\<^sub>e\<^sub>t (!) T)"
-    then obtain k where k: "k \<in> set K" "x \<in> fv (k \<cdot> (!) T)" by moura
+    then obtain k where k: "k \<in> set K" "x \<in> fv (k \<cdot> (!) T)" by auto
     have "\<forall>i \<in> fv k. i < length T" using K k(1) by simp
     thus "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set T)"
       by (metis (no_types, lifting) k(2) contra_subsetD fv_set_mono image_subsetI nth_mem
                                     subst_apply_fv_unfold)
   qed
 
   { fix g assume f: "f = Fu g" and K: "K \<noteq> []"
-    obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by moura
+    obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by force
     have "(K, M) \<noteq> ([], [])" using K by simp
     hence "(K, M) = (K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M')" "arity\<^sub>f g = length T"
       using Ana_Fu_cases(1)[OF Fun.prems f *]
       by presburger+
     hence ?case using aux[of K'] Ana\<^sub>f_assm2_alt[OF *] by auto
   } thus ?case using Fun by (cases f) fastforce+
 qed simp
 
 lemma assm2:
   assumes "Ana t = (K,M)"
   and "\<And>g S'. Fun g S' \<sqsubseteq> t \<Longrightarrow> length S' = arity g"
   and "k \<in> set K"
   and "Fun f T' \<sqsubseteq> k"
   shows "length T' = arity f"
 using assms
 proof (induction t rule: term.induct)
   case (Fun g T)
   obtain h where 2: "g = Fu h"
     using Fun.prems(1,3) by (cases g) auto
-  obtain K' M' where 1: "Ana\<^sub>f h = (K',M')" by moura
+  obtain K' M' where 1: "Ana\<^sub>f h = (K',M')" by force
   have "(K,M) \<noteq> ([],[])" using Fun.prems(3) by auto
   hence "(K,M) = (K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) M')"
         "\<And>i. i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K') \<union> set M' \<Longrightarrow> i < length T"
     using Ana_Fu_cases(1)[OF Fun.prems(1) 2 1] Ana\<^sub>f_assm2_alt[OF 1]
     by presburger+
   hence "K = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T" and 3: "\<forall>i\<in>fv\<^sub>s\<^sub>e\<^sub>t (set K'). i < length T" by simp_all
-  then obtain k' where k': "k' \<in> set K'" "k = k' \<cdot> (!) T" using Fun.prems(3) by moura
+  then obtain k' where k': "k' \<in> set K'" "k = k' \<cdot> (!) T" using Fun.prems(3) by force
   hence 4: "Fun f T' \<in> subterms (k' \<cdot> (!) T)" "fv k' \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t (set K')"
     using Fun.prems(4) by auto
   show ?case
   proof (cases "\<exists>i \<in> fv k'. Fun f T' \<in> subterms (T ! i)")
     case True
     hence "Fun f T' \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set T)" using k' Fun.prems(4) 3 by auto
     thus ?thesis using Fun.prems(2) by auto
   next
     case False
     then obtain S where "Fun f S \<in> subterms k'" "Fun f T' = Fun f S \<cdot> (!) T"
       using k'(2) Fun.prems(4) subterm_subst_not_img_subterm by force
     thus ?thesis using Ana\<^sub>f_assm1_alt[OF 1, of "Fun f S"] k'(1) by (cases f) auto
   qed
 qed simp
 
 lemma assm4:
   assumes "Ana (Fun f T) = (K, M)"
   shows "set M \<subseteq> set T"
 using assms
 proof (cases f)
   case (Fu g)
-  obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by moura
+  obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by force
   have "M = [] \<or> (arity\<^sub>f g = length T \<and> M = map ((!) T) M')"
     using Ana_Fu_cases(1)[OF assms Fu *]
     by (meson prod.inject)
   thus ?thesis using Ana\<^sub>f_assm2_alt[OF *] by auto
 qed auto
 
 lemma assm5: "Ana t = (K,M) \<Longrightarrow> K \<noteq> [] \<or> M \<noteq> [] \<Longrightarrow> Ana (t \<cdot> \<delta>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>, M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>)"
 proof (induction t rule: term.induct)
   case (Fun f T) thus ?case
   proof (cases f)
     case (Fu g)
-    obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by moura
+    obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by force
     have **: "K = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T" "M = map ((!) T) M'"
              "arity\<^sub>f g = length T" "\<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K') \<union> set M'. i < arity\<^sub>f g" "0 < arity\<^sub>f g"
       using Fun.prems(2) Ana_Fu_cases(1)[OF Fun.prems(1) Fu *] Ana\<^sub>f_assm2_alt[OF *]
       by (meson prod.inject)+
 
     have ***: "\<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K'). i < length T" "\<forall>i \<in> set M'. i < length T" using **(3,4) by auto
     
     have "K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta> = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) (map (\<lambda>t. t \<cdot> \<delta>) T)"
          "M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta> = map ((!) (map (\<lambda>t. t \<cdot> \<delta>) T)) M'"
       using subst_idx_map[OF ***(2), of \<delta>]
             subst_idx_map'[OF ***(1), of \<delta>]
             **(1,2)
       by fast+
     thus ?thesis using Fu * **(3,5) by auto
   qed auto
 qed simp
 
 sublocale intruder_model arity public Ana
 apply unfold_locales
 by (metis assm1, metis assm2, rule Ana.simps, metis assm4, metis assm5)
 
 adhoc_overloading INTRUDER_SYNTH intruder_synth
 adhoc_overloading INTRUDER_DEDUCT intruder_deduct
 
 lemma assm6: "arity c = 0 \<Longrightarrow> \<exists>a. \<forall>X. \<Gamma> (Fun c X) = TAtom a" by (cases c) auto
 
 lemma assm7: "0 < arity f \<Longrightarrow> \<Gamma> (Fun f T) = TComp f (map \<Gamma> T)" by auto
 
 lemma assm8: "infinite {c. \<Gamma> (Fun c []::('fun,'atom,'sets,'lbl) prot_term) = TAtom a \<and> public c}"
   (is "?P a")
 proof -
   let ?T = "\<lambda>f. (range f)::('fun,'atom,'sets,'lbl) prot_fun set"
   let ?A = "\<lambda>f. \<forall>x::nat \<in> UNIV. \<forall>y::nat \<in> UNIV. (f x = f y) = (x = y)"
   let ?B = "\<lambda>f. \<forall>x::nat \<in> UNIV. f x \<in> ?T f"
   let ?C = "\<lambda>f. \<forall>y::('fun,'atom,'sets,'lbl) prot_fun \<in> ?T f. \<exists>x \<in> UNIV. y = f x"
   let ?D = "\<lambda>f b. ?T f \<subseteq> {c. \<Gamma> (Fun c []::('fun,'atom,'sets,'lbl) prot_term) = TAtom b \<and> public c}"
 
   have sub_lmm: "?P b" when "?A f" "?C f" "?C f" "?D f b" for b f
   proof -
     have "\<exists>g::nat \<Rightarrow> ('fun,'atom,'sets,'lbl) prot_fun. bij_betw g UNIV (?T f)"
       using bij_betwI'[of UNIV f "?T f"] that(1,2,3) by blast
     hence "infinite (?T f)" by (metis nat_not_finite bij_betw_finite)
     thus ?thesis using infinite_super[OF that(4)] by blast
   qed
 
   show ?thesis
   proof (cases a)
     case (Atom b) thus ?thesis using sub_lmm[of "PubConst (Atom b)" a] by force
   next
     case Value thus ?thesis using sub_lmm[of "PubConst Value" a] by force
   next
     case SetType thus ?thesis using sub_lmm[of "PubConst SetType" a] by fastforce
   next
     case AttackType thus ?thesis using sub_lmm[of "PubConst AttackType" a] by fastforce
   next
     case Bottom thus ?thesis using sub_lmm[of "PubConst Bottom" a] by fastforce
   next
     case OccursSecType thus ?thesis using sub_lmm[of "PubConst OccursSecType" a] by fastforce
   next
     case AbsValue thus ?thesis using sub_lmm[of "PubConst AbsValue" a] by force
   qed
 qed
 
 lemma assm9: "TComp f T \<sqsubseteq> \<Gamma> t \<Longrightarrow> arity f > 0"
 proof (induction t rule: term.induct)
   case (Var x)
   hence "\<Gamma> (Var x) \<noteq> TAtom Bottom" by force
   hence "\<forall>t \<in> subterms (fst x). case t of
             TComp f T \<Rightarrow> arity f > 0 \<and> arity f = length T
           | _ \<Rightarrow> True"
     using Var \<Gamma>.simps(1)[of x] unfolding \<Gamma>\<^sub>v_def by meson
   thus ?case using Var by (fastforce simp add: \<Gamma>\<^sub>v_def)
 next
   case (Fun g S)
   have "arity g \<noteq> 0" using Fun.prems Var_subtermeq assm6 by force
   thus ?case using Fun by (cases "TComp f T = TComp g (map \<Gamma> S)") auto
 qed
 
 lemma assm10: "wf\<^sub>t\<^sub>r\<^sub>m (\<Gamma> (Var x))"
 unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by (auto simp add: \<Gamma>\<^sub>v_def)
 
 lemma assm11: "arity f > 0 \<Longrightarrow> public f" using public\<^sub>f_assm by (cases f) auto
 
 lemma assm12: "\<Gamma> (Var (\<tau>, n)) = \<Gamma> (Var (\<tau>, m))" by (simp add: \<Gamma>\<^sub>v_def)
 
 lemma assm13: "arity c = 0 \<Longrightarrow> Ana (Fun c T) = ([],[])" by (cases c) simp_all
 
 lemma assm14:
   assumes "Ana (Fun f T) = (K,M)"
   shows "Ana (Fun f T \<cdot> \<delta>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>, M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>)"
 proof -
   show ?thesis
   proof (cases "(K, M) = ([],[])")
     case True
     { fix g assume f: "f = Fu g"
-      obtain K' M' where "Ana\<^sub>f g = (K',M')" by moura
+      obtain K' M' where "Ana\<^sub>f g = (K',M')" by force
       hence ?thesis using assms f True by auto
     } thus ?thesis using True assms by (cases f) auto
   next
     case False
     then obtain g where **: "f = Fu g" using assms by (cases f) auto
-    obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by moura
+    obtain K' M' where *: "Ana\<^sub>f g = (K',M')" by force
     have ***: "K = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T" "M = map ((!) T) M'" "arity\<^sub>f g = length T"
               "\<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K') \<union> set M'. i < arity\<^sub>f g"
       using Ana_Fu_cases(1)[OF assms ** *] False Ana\<^sub>f_assm2_alt[OF *]
       by (meson prod.inject)+
     have ****: "\<forall>i\<in>fv\<^sub>s\<^sub>e\<^sub>t (set K'). i < length T" "\<forall>i\<in>set M'. i < length T" using ***(3,4) by auto
     have "K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta> = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) (map (\<lambda>t. t \<cdot> \<delta>) T)"
          "M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta> = map ((!) (map (\<lambda>t. t \<cdot> \<delta>) T)) M'"
       using subst_idx_map[OF ****(2), of \<delta>]
             subst_idx_map'[OF ****(1), of \<delta>]
             ***(1,2)
       by auto
     thus ?thesis using assms * ** ***(3) by auto
   qed
 qed
 
 sublocale labeled_stateful_typing' arity public Ana \<Gamma> Pair label_witness1 label_witness2
   apply unfold_locales
   subgoal by (metis assm6)
   subgoal by (metis assm7)
   subgoal by (metis assm9)
   subgoal by (rule assm10)
   subgoal by (metis assm12)
   subgoal by (metis assm13)
   subgoal by (metis assm14)
   subgoal by (rule label_witness_assm)
   subgoal by (rule arity.simps(5))
   subgoal by (metis assm14)
   subgoal by (metis assm8)
   subgoal by (metis assm11)
   done
 
 
 subsection \<open>The Protocol Transition System, Defined in Terms of the Reachable Constraints\<close>
 definition transaction_decl_subst where
   "transaction_decl_subst (\<xi>::('fun,'atom,'sets,'lbl) prot_subst) T \<equiv>
     subst_domain \<xi> = fst ` set (transaction_decl T ()) \<and>
     (\<forall>(x,cs) \<in> set (transaction_decl T ()). \<exists>c \<in> cs.
       \<xi> x = Fun (Fu c) [] \<and>
       arity (Fu c::('fun,'atom,'sets,'lbl) prot_fun) = 0) \<and>
     wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<xi>"
 
 definition transaction_fresh_subst where
   "transaction_fresh_subst \<sigma> T M \<equiv>
     subst_domain \<sigma> = set (transaction_fresh T) \<and>
     (\<forall>t \<in> subst_range \<sigma>. \<exists>c. t = Fun c [] \<and> \<not>public c \<and> arity c = 0) \<and>
     (\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t M) \<and>
     (\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)) \<and>
     wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<sigma> \<and> inj_on \<sigma> (subst_domain \<sigma>)"
 
 (* NB: We need the protocol P as a parameter for this definition---even though we will only apply \<alpha>
        to a single transaction T of P---because we have to ensure that \<alpha>(fv(T)) is disjoint from
        the bound variables of P and \<A>. *)
 definition transaction_renaming_subst where
   "transaction_renaming_subst \<alpha> P X \<equiv>
     \<exists>n \<ge> max_var_set (\<Union>(vars_transaction ` set P) \<union> X). \<alpha> = var_rename n"
 
 definition (in intruder_model) constraint_model where
   "constraint_model \<I> \<A> \<equiv> 
     constr_sem_stateful \<I> (unlabel \<A>) \<and>
     interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I> \<and>
     wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
 
 definition (in typed_model) welltyped_constraint_model where
   "welltyped_constraint_model \<I> \<A> \<equiv> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I> \<and> constraint_model \<I> \<A>"
 
 text \<open>
   The set of symbolic constraints reachable in any symbolic run of the protocol \<open>P\<close>.
   
   \<open>\<xi>\<close> instantiates the "declared variables" of transaction \<open>T\<close> with ground terms.
   \<open>\<sigma>\<close> instantiates the fresh variables of transaction \<open>T\<close> with fresh terms.
   \<open>\<alpha>\<close> is a variable-renaming whose range consists of fresh variables.
 \<close>
 inductive_set reachable_constraints::
   "('fun,'atom,'sets,'lbl) prot \<Rightarrow> ('fun,'atom,'sets,'lbl) prot_constr set"
   for P::"('fun,'atom,'sets,'lbl) prot"
 where
   init[simp]:
   "[] \<in> reachable_constraints P"
 | step:
   "\<lbrakk>\<A> \<in> reachable_constraints P;
     T \<in> set P;
     transaction_decl_subst \<xi> T;
     transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>);
     transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)
    \<rbrakk> \<Longrightarrow> \<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<in> reachable_constraints P"
 
 
 subsection \<open>Minor Lemmata\<close>
 lemma \<Gamma>\<^sub>v_TAtom[simp]: "\<Gamma>\<^sub>v (TAtom a, n) = TAtom a"
 unfolding \<Gamma>\<^sub>v_def by simp
 
 lemma \<Gamma>\<^sub>v_TAtom':
   assumes "a \<noteq> Bottom"
   shows "\<Gamma>\<^sub>v (\<tau>, n) = TAtom a \<longleftrightarrow> \<tau> = TAtom a"
 proof
   assume "\<Gamma>\<^sub>v (\<tau>, n) = TAtom a"
   thus "\<tau> = TAtom a" by (metis (no_types, lifting) assms \<Gamma>\<^sub>v_def fst_conv term.inject(1)) 
 qed simp
 
 lemma \<Gamma>\<^sub>v_TAtom_inv:
   "\<Gamma>\<^sub>v x = TAtom (Atom a) \<Longrightarrow> \<exists>m. x = (TAtom (Atom a), m)"
   "\<Gamma>\<^sub>v x = TAtom Value \<Longrightarrow> \<exists>m. x = (TAtom Value, m)"
   "\<Gamma>\<^sub>v x = TAtom SetType \<Longrightarrow> \<exists>m. x = (TAtom SetType, m)"
   "\<Gamma>\<^sub>v x = TAtom AttackType \<Longrightarrow> \<exists>m. x = (TAtom AttackType, m)"
   "\<Gamma>\<^sub>v x = TAtom OccursSecType \<Longrightarrow> \<exists>m. x = (TAtom OccursSecType, m)"
 by (metis \<Gamma>\<^sub>v_TAtom' surj_pair prot_atom.distinct(7),
     metis \<Gamma>\<^sub>v_TAtom' surj_pair prot_atom.distinct(18),
     metis \<Gamma>\<^sub>v_TAtom' surj_pair prot_atom.distinct(26),
     metis \<Gamma>\<^sub>v_TAtom' surj_pair prot_atom.distinct(32),
     metis \<Gamma>\<^sub>v_TAtom' surj_pair prot_atom.distinct(38))
 
 lemma \<Gamma>\<^sub>v_TAtom'':
   "(fst x = TAtom (Atom a)) = (\<Gamma>\<^sub>v x = TAtom (Atom a))" (is "?A = ?A'")
   "(fst x = TAtom Value) = (\<Gamma>\<^sub>v x = TAtom Value)" (is "?B = ?B'")
   "(fst x = TAtom SetType) = (\<Gamma>\<^sub>v x = TAtom SetType)" (is "?C = ?C'")
   "(fst x = TAtom AttackType) = (\<Gamma>\<^sub>v x = TAtom AttackType)" (is "?D = ?D'")
   "(fst x = TAtom OccursSecType) = (\<Gamma>\<^sub>v x = TAtom OccursSecType)" (is "?E = ?E'")
 proof -
   have 1: "?A \<Longrightarrow> ?A'" "?B \<Longrightarrow> ?B'" "?C \<Longrightarrow> ?C'" "?D \<Longrightarrow> ?D'" "?E \<Longrightarrow> ?E'"
     by (metis \<Gamma>\<^sub>v_TAtom prod.collapse)+
 
   have 2: "?A' \<Longrightarrow> ?A" "?B' \<Longrightarrow> ?B" "?C' \<Longrightarrow> ?C" "?D' \<Longrightarrow> ?D" "?E' \<Longrightarrow> ?E"
     using \<Gamma>\<^sub>v_TAtom \<Gamma>\<^sub>v_TAtom_inv(1) apply fastforce
     using \<Gamma>\<^sub>v_TAtom \<Gamma>\<^sub>v_TAtom_inv(2) apply fastforce
     using \<Gamma>\<^sub>v_TAtom \<Gamma>\<^sub>v_TAtom_inv(3) apply fastforce
     using \<Gamma>\<^sub>v_TAtom \<Gamma>\<^sub>v_TAtom_inv(4) apply fastforce
     using \<Gamma>\<^sub>v_TAtom \<Gamma>\<^sub>v_TAtom_inv(5) by fastforce
 
   show "?A = ?A'" "?B = ?B'" "?C = ?C'" "?D = ?D'" "?E = ?E'"
     using 1 2 by metis+
 qed
 
 lemma \<Gamma>\<^sub>v_Var_image:
   "\<Gamma>\<^sub>v ` X = \<Gamma> ` Var ` X"
 by force
 
 lemma \<Gamma>_Fu_const:
   assumes "arity\<^sub>f g = 0"
   shows "\<exists>a. \<Gamma> (Fun (Fu g) T) = TAtom (Atom a)"
 proof -
   have "\<Gamma>\<^sub>f g \<noteq> None" using assms \<Gamma>\<^sub>f_assm by blast
   thus ?thesis using assms by force
 qed
 
 lemma Fun_Value_type_inv:
   fixes T::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes "\<Gamma> (Fun f T) = TAtom Value"
   shows "(\<exists>n. f = Val n) \<or> (\<exists>bs. f = Abs bs) \<or> (\<exists>n. f = PubConst Value n)"
 proof -
   have *: "arity f = 0" by (metis const_type_inv assms) 
   show ?thesis  using assms
   proof (cases f)
     case (Fu g)
     hence "arity\<^sub>f g = 0" using * by simp
     hence False using Fu \<Gamma>_Fu_const[of g T] assms by auto
     thus ?thesis by metis
   next
     case (Set s)
     hence "arity\<^sub>s s = 0" using * by simp
     hence False using Set assms by auto
     thus ?thesis by metis
   qed simp_all
 qed
 
 lemma Ana\<^sub>f_keys_not_val_terms:
   assumes "Ana\<^sub>f f = (K, T)"
     and "k \<in> set K"
     and "g \<in> funs_term k"
   shows "\<not>is_Val g"
     and "\<not>is_PubConstValue g"
     and "\<not>is_Abs g"
 proof -
   { assume "is_Val g"
     then obtain n S where *: "Fun (Val n) S \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)"
       using assms(2) funs_term_Fun_subterm[OF assms(3)]
       by (cases g) auto
     hence False using Ana\<^sub>f_assm1_alt[OF assms(1) *] by simp
   } moreover {
     assume "is_PubConstValue g"
     then obtain n S where *: "Fun (PubConst Value n) S \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)"
       using assms(2) funs_term_Fun_subterm[OF assms(3)]
       unfolding is_PubConstValue_def by (cases g) auto
     hence False using Ana\<^sub>f_assm1_alt[OF assms(1) *] by simp
   } moreover {
     assume "is_Abs g"
     then obtain a S where *: "Fun (Abs a) S \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)"
       using assms(2) funs_term_Fun_subterm[OF assms(3)]
       by (cases g) auto
     hence False using Ana\<^sub>f_assm1_alt[OF assms(1) *] by simp
   } ultimately show "\<not>is_Val g" "\<not>is_PubConstValue g" "\<not>is_Abs g" by metis+
 qed
 
 lemma Ana\<^sub>f_keys_not_pairs:
   assumes "Ana\<^sub>f f = (K, T)"
     and "k \<in> set K"
     and "g \<in> funs_term k"
   shows "g \<noteq> Pair"
 proof
   assume "g = Pair"
   then obtain S where *: "Fun Pair S \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)"
     using assms(2) funs_term_Fun_subterm[OF assms(3)]
     by (cases g) auto
   show False using Ana\<^sub>f_assm1_alt[OF assms(1) *] by simp
 qed
 
 lemma Ana_Fu_keys_funs_term_subset:
   fixes K::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes "Ana (Fun (Fu f) S) = (K, T)"
     and "Ana\<^sub>f f = (K', T')"
   shows "\<Union>(funs_term ` set K) \<subseteq> \<Union>(funs_term ` set K') \<union> funs_term (Fun (Fu f) S)"
 proof -
   { fix k assume k: "k \<in> set K"
     then obtain k' where k':
         "k' \<in> set K'" "k = k' \<cdot> (!) S" "arity\<^sub>f f = length S"
         "subterms k' \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t (set K')"
       using assms Ana_Fu_elim[OF assms(1) _ assms(2)] by fastforce
 
     have 1: "funs_term k' \<subseteq> \<Union>(funs_term ` set K')" using k'(1) by auto
 
     have "i < length S" when "i \<in> fv k'" for i
       using that Ana\<^sub>f_assm2_alt[OF assms(2), of i] k'(1,3)
       by auto
     hence 2: "funs_term (S ! i) \<subseteq> funs_term (Fun (Fu f) S)" when "i \<in> fv k'" for i
       using that by force
   
     have "funs_term k \<subseteq> \<Union>(funs_term ` set K') \<union> funs_term (Fun (Fu f) S)"
       using funs_term_subst[of k' "(!) S"] k'(2) 1 2 by fast
   } thus ?thesis by blast
 qed
 
 lemma Ana_Fu_keys_not_pubval_terms:
   fixes k::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "Ana (Fun (Fu f) S) = (K, T)"
     and "Ana\<^sub>f f = (K', T')"
     and "k \<in> set K"
     and "\<forall>g \<in> funs_term (Fun (Fu f) S). \<not>is_PubConstValue g"
   shows "\<forall>g \<in> funs_term k. \<not>is_PubConstValue g"
 using assms(3,4) Ana\<^sub>f_keys_not_val_terms(1,2)[OF assms(2)]
       Ana_Fu_keys_funs_term_subset[OF assms(1,2)]
 by blast
 
 lemma Ana_Fu_keys_not_abs_terms:
   fixes k::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "Ana (Fun (Fu f) S) = (K, T)"
     and "Ana\<^sub>f f = (K', T')"
     and "k \<in> set K"
     and "\<forall>g \<in> funs_term (Fun (Fu f) S). \<not>is_Abs g"
   shows "\<forall>g \<in> funs_term k. \<not>is_Abs g"
 using assms(3,4) Ana\<^sub>f_keys_not_val_terms(3)[OF assms(2)]
       Ana_Fu_keys_funs_term_subset[OF assms(1,2)]
 by blast
 
 lemma Ana_Fu_keys_not_pairs:
   fixes k::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "Ana (Fun (Fu f) S) = (K, T)"
     and "Ana\<^sub>f f = (K', T')"
     and "k \<in> set K"
     and "\<forall>g \<in> funs_term (Fun (Fu f) S). g \<noteq> Pair"
   shows "\<forall>g \<in> funs_term k. g \<noteq> Pair"
 using assms(3,4) Ana\<^sub>f_keys_not_pairs[OF assms(2)]
       Ana_Fu_keys_funs_term_subset[OF assms(1,2)]
 by blast
 
 lemma Ana_Fu_keys_length_eq:
   assumes "length T = length S"
   shows "length (fst (Ana (Fun (Fu f) T))) = length (fst (Ana (Fun (Fu f) S)))"
 proof (cases "arity\<^sub>f f = length T \<and> arity\<^sub>f f > 0")
   case True thus ?thesis using assms by (cases "Ana\<^sub>f f") auto
 next
   case False thus ?thesis using assms by force
 qed
 
 lemma Ana_key_PubConstValue_subterm_in_term: 
   fixes k::"('fun,'atom,'sets,'lbl) prot_term"
   assumes KR: "Ana t = (K, R)"
     and k: "k \<in> set K"
     and n: "Fun (PubConst Value n) [] \<sqsubseteq> k"
   shows "Fun (PubConst Value n) [] \<sqsubseteq> t"
 proof (cases t)
   case (Var x) thus ?thesis using KR k n by force
 next
   case (Fun f ts)
   note t = this
   then obtain g where f: "f = Fu g" using KR k by (cases f) auto
   obtain K' R' where KR': "Ana\<^sub>f g = (K', R')" by fastforce
 
   have K: "K = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) ts"
     using k Ana_Fu_elim(2)[OF KR[unfolded t] f KR'] by force
 
   obtain k' where k': "k' \<in> set K'" "k = k' \<cdot> (!) ts" using k K by auto
 
   have 0: "\<not>(Fun (PubConst Value n) [] \<sqsubseteq> k')"
   proof
     assume *: "Fun (PubConst Value n) [] \<sqsubseteq> k'"
     have **: "PubConst Value n \<in> funs_term k'"
       using funs_term_Fun_subterm'[OF *] by (cases k') auto
     show False
       using Ana\<^sub>f_keys_not_val_terms(2)[OF KR' k'(1) **]
       unfolding is_PubConstValue_def by force
   qed
   hence "\<exists>i \<in> fv k'. Fun (PubConst Value n) [] \<sqsubseteq> ts ! i"
     by (metis n const_subterm_subst_var_obtain k'(2))
   then obtain i where i: "i \<in> fv k'" "Fun (PubConst Value n) [] \<sqsubseteq> ts ! i" by blast
 
   have "i < length ts"
     using i(1) KR' k'(1) Ana\<^sub>f_assm2_alt[OF KR', of i]
           Ana_Fu_elim(1)[OF KR[unfolded t] f KR'] k
     by fastforce
   thus ?thesis using i(2) unfolding t by force
 qed
 
 lemma deduct_occurs_in_ik:
   fixes t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes t: "M \<turnstile> occurs t"
     and M: "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t M. OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
            "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t M. OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
            "Fun OccursSec [] \<notin> M"
   shows "occurs t \<in> M"
 using private_fun_deduct_in_ik''[of M OccursFact "[Fun OccursSec [], t]" OccursSec] t M 
 by fastforce
 
 lemma deduct_val_const_swap:
   fixes \<theta> \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta> \<turnstile> t \<cdot> \<theta>"
     and "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. (\<exists>n. \<theta> x = Fun (Val n) []) \<or> (\<exists>n. \<theta> x = Fun (PubConst Value n) [])"
     and "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. (\<exists>n. \<sigma> x = Fun (Val n) [])"
     and "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. (\<exists>n. \<theta> x = Fun (PubConst Value n) []) \<longrightarrow> \<sigma> x \<in> M \<union> N"
     and "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. (\<exists>n. \<theta> x = Fun (Val n) []) \<longrightarrow> \<theta> x = \<sigma> x"
     and "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. \<forall>y \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. \<theta> x = \<theta> y \<longleftrightarrow> \<sigma> x = \<sigma> y"
     and "\<forall>n. \<not>(Fun (PubConst Value n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t insert t M)"
   shows "(M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N \<turnstile> t \<cdot> \<sigma>"
 proof -
   obtain n where n: "intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) n (t \<cdot> \<theta>)"
     using assms(1) deduct_num_if_deduct by blast
   hence "\<exists>m \<le> n. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) m (t \<cdot> \<sigma>)" using assms(2-)
   proof (induction n arbitrary: t rule: nat_less_induct)
     case (1 n)
     note prems = "1.prems"
     note IH = "1.IH"
 
     show ?case
     proof (cases "t \<cdot> \<theta> \<in> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>")
       case True
       note 2 = this
       have 3: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. \<exists>c. \<theta> x = Fun c []"
               "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t. \<exists>c. \<sigma> x = Fun c []"
         using prems(2,3) by (blast, blast)
       have "t \<cdot> \<sigma> \<in> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
         using subst_const_swap_eq_mem[OF 2 _ 3 prems(6)] prems(2,5,7) by metis
       thus ?thesis using intruder_deduct_num.AxiomN by auto
     next
       case False
       then obtain n' where n: "n = Suc n'" using prems(1) deduct_zero_in_ik by (cases n) fast+
 
       have M_subterms_eq:
           "subterms\<^sub>s\<^sub>e\<^sub>t (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) = subterms\<^sub>s\<^sub>e\<^sub>t M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>"
           "subterms\<^sub>s\<^sub>e\<^sub>t (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = subterms\<^sub>s\<^sub>e\<^sub>t M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
         subgoal using prems(2) subterms_subst''[of M \<theta>] by blast
         subgoal using prems(3) subterms_subst''[of M \<sigma>] by blast
         done
 
       from deduct_inv[OF prems(1)] show ?thesis
       proof (elim disjE)
         assume "t \<cdot> \<theta> \<in> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>" thus ?thesis using False by argo
       next
         assume "\<exists>f ts. t \<cdot> \<theta> = Fun f ts \<and> public f \<and> length ts = arity f \<and>
                      (\<forall>t \<in> set ts. \<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l t)"
         then obtain f ts where t:
             "t \<cdot> \<theta> = Fun f ts" "public f" "length ts = arity f"
             "\<forall>t \<in> set ts. \<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l t"
           by blast
   
         show ?thesis
         proof (cases t)
           case (Var x)
           hence ts: "ts = []" and f: "\<exists>c. f = PubConst Value c"
             using t(1,2) prems(2) by (force, auto)
           have "\<sigma> x \<in> M \<union> N" using prems(4) Var f ts t(1) by auto
           moreover have "fv (\<sigma> x) = {}" using prems(3) Var by auto
           hence "\<sigma> x \<in> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>" when "\<sigma> x \<in> M" using that subst_ground_ident[of "\<sigma> x" \<sigma>] by force
           ultimately have "\<sigma> x \<in> (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N" by fast
           thus ?thesis using intruder_deduct_num.AxiomN Var by force
         next
           case (Fun g ss)
           hence f: "f = g" and ts: "ts = ss \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" using t(1) by auto
   
           have ss: "\<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l (s \<cdot> \<theta>)" when s: "s \<in> set ss" for s
             using t(4) ts s by auto
   
           have IH': "\<exists>l < n. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l (s \<cdot> \<sigma>)"
             when s: "s \<in> set ss" for s
           proof -
             obtain l where l: "l < n" "intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l (s \<cdot> \<theta>)"
               using ss s by blast
             
             have *: "fv s \<subseteq> fv t" "subterms\<^sub>s\<^sub>e\<^sub>t (insert s M) \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t (insert t M)"
               using s unfolding Fun f ts by auto
 
             have "\<exists>l' \<le> l. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l' (s \<cdot> \<sigma>)"
             proof -
               have "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv s.
                       (\<exists>n. \<theta> x = Fun (Val n) []) \<or> (\<exists>n. \<theta> x = Fun (PubConst Value n) [])"
                    "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv s. \<exists>n. \<sigma> x = Fun (Val n) []"
                    "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv s. (\<exists>n. \<theta> x = Fun (PubConst Value n) []) \<longrightarrow> \<sigma> x \<in> M \<union> N"
                    "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv s. (\<exists>n. \<theta> x = Fun (Val n) []) \<longrightarrow> \<theta> x = \<sigma> x"
                    "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv s. \<forall>y \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv s. \<theta> x = \<theta> y \<longleftrightarrow> \<sigma> x = \<sigma> y"
                    "\<forall>n. Fun (PubConst Value n) [] \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (insert s M)"
                 subgoal using prems(2) *(1) by blast
                 subgoal using prems(3) *(1) by blast
                 subgoal using prems(4) *(1) by blast
                 subgoal using prems(5) *(1) by blast
                 subgoal using prems(6) *(1) by blast
                 subgoal using prems(7) *(2) by blast
                 done
               thus ?thesis using IH l by presburger
             qed
             then obtain l' where l': "l' \<le> l" "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l' (s \<cdot> \<sigma>)"
               by blast
 
             have "l' < n" using l'(1) l(1) by linarith
             thus ?thesis using l'(2) by blast
           qed
   
           have g: "length (ss \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>) = arity g" "public g"
             using t(2,3) unfolding f ts by auto
 
           let ?P = "\<lambda>s l. l < n \<and> intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l s"
           define steps where "steps \<equiv> \<lambda>s. SOME l. ?P s l"
   
           have 2: "steps (s \<cdot> \<sigma>) < n" "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) (steps (s \<cdot> \<sigma>)) (s \<cdot> \<sigma>)"
             when s: "s \<in> set ss" for s
             using someI_ex[OF IH'[OF s]] unfolding steps_def by (blast, blast)
   
           have 3: "Suc (Max (insert 0 (steps ` set (ss \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)))) \<le> n"
           proof (cases "ss = []")
             case True show ?thesis unfolding True n by simp
           next
             case False thus ?thesis
               using 2 Max_nat_finite_lt[of "set (ss \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)" steps n] by (simp add: Suc_leI)
           qed
   
           show ?thesis
             using intruder_deduct_num.ComposeN[OF g, of "(M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N" steps] 2(2) 3
             unfolding Fun by auto
         qed
       next
         assume "\<exists>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>).
                   (\<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l s) \<and>
                   (\<forall>k \<in> set (fst (Ana s)). \<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l k) \<and>
                   t \<cdot> \<theta> \<in> set (snd (Ana s))"
         then obtain s l
             where s:
               "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>"
               "\<forall>k \<in> set (fst (Ana s)). \<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l k"
               "t \<cdot> \<theta> \<in> set (snd (Ana s))"
             and l: "l < n" "intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l s"
           by (metis (no_types, lifting) M_subterms_eq(1))
 
         obtain u where u: "u \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t M" "s = u \<cdot> \<theta>" using s(1) by blast
 
         have u_fv: "fv u \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M" by (metis fv_subset_subterms u(1))
 
         have "\<nexists>x. u = Var x"
         proof
           assume "\<exists>x. u = Var x"
           then obtain x where x: "u = Var x" by blast
           then obtain c where c: "s = Fun c []" using u prems(2) u_fv by auto
           thus False using s(3) Ana_subterm by (cases "Ana s") force
         qed
         then obtain f ts where u': "u = Fun f ts" by (cases u) auto
 
         obtain K R where KR: "Ana u = (K,R)" by (metis surj_pair)
 
         have KR': "Ana s = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>, R \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)"
           using KR Ana_subst'[OF KR[unfolded u'], of \<theta>] unfolding u(2) u' by blast
         hence s': 
             "\<forall>k \<in> set K. \<exists>l < n. intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) l (k \<cdot> \<theta>)"
             "t \<cdot> \<theta> \<in> set (R \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)"
           using s(2,3) by auto
 
         have IH1: "\<exists>l < n. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l (u \<cdot> \<sigma>)"
         proof -
           have "subterms u \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t M" using u(1) subterms_subset by auto
           hence "subterms\<^sub>s\<^sub>e\<^sub>t (insert u M) = subterms\<^sub>s\<^sub>e\<^sub>t M" by blast
           hence *: "subterms\<^sub>s\<^sub>e\<^sub>t (insert u M) \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t (insert t M)" by auto
 
           have "\<exists>l' \<le> l. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l' (u \<cdot> \<sigma>)"
           proof -
             have "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv u.
                     (\<exists>n. \<theta> x = Fun (Val n) []) \<or> (\<exists>n. \<theta> x = Fun (PubConst Value n) [])"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv u. \<exists>n. \<sigma> x = Fun (Val n) []"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv u. (\<exists>n. \<theta> x = Fun (PubConst Value n) []) \<longrightarrow> \<sigma> x \<in> M \<union> N"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv u. (\<exists>n. \<theta> x = Fun (Val n) []) \<longrightarrow> \<theta> x = \<sigma> x"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv u. \<forall>y \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv u. \<theta> x = \<theta> y \<longleftrightarrow> \<sigma> x = \<sigma> y"
                  "\<forall>n. Fun (PubConst Value n) [] \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (insert u M)"
               subgoal using prems(2) u_fv by blast
               subgoal using prems(3) u_fv by blast
               subgoal using prems(4) u_fv by blast
               subgoal using prems(5) u_fv by blast
               subgoal using prems(6) u_fv by blast
               subgoal using prems(7) * by blast
               done
             thus ?thesis using IH l unfolding u(2) by presburger
           qed
           then obtain l' where l': "l' \<le> l" "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l' (u \<cdot> \<sigma>)"
             by blast
 
           have "l' < n" using l'(1) l(1) by linarith
           thus ?thesis using l'(2) by blast
         qed
 
         have IH2: "\<exists>l < n. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l (k \<cdot> \<sigma>)" when k: "k \<in> set K" for k
           using k IH prems(2-) Ana\<^sub>f_keys_not_val_terms s'(1) KR u(1)
         proof -
           have *: "fv k \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M" using k KR Ana_keys_fv u(1) fv_subset_subterms by blast
 
           have **: "Fun (PubConst Value n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t M" when "Fun (PubConst Value n) [] \<sqsubseteq> k" for n
             using in_subterms_subset_Union[OF u(1)]
                   Ana_key_PubConstValue_subterm_in_term[OF KR k that]
             by fast
 
           obtain lk where lk: "lk < n" "intruder_deduct_num (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>) lk (k \<cdot> \<theta>)"
             using s'(1) k by fast
 
           have "\<exists>l' \<le> lk. intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l' (k \<cdot> \<sigma>)"
           proof -
             have "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv k.
                     (\<exists>n. \<theta> x = Fun (Val n) []) \<or> (\<exists>n. \<theta> x = Fun (PubConst Value n) [])"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv k. \<exists>n. \<sigma> x = Fun (Val n) []"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv k. (\<exists>n. \<theta> x = Fun (PubConst Value n) []) \<longrightarrow> \<sigma> x \<in> M \<union> N"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv k. (\<exists>n. \<theta> x = Fun (Val n) []) \<longrightarrow> \<theta> x = \<sigma> x"
                  "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv k. \<forall>y \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv k. \<theta> x = \<theta> y \<longleftrightarrow> \<sigma> x = \<sigma> y"
                  "\<forall>n. Fun (PubConst Value n) [] \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (insert k M)"
               subgoal using prems(2) * by blast
               subgoal using prems(3) * by blast
               subgoal using prems(4) * by blast
               subgoal using prems(5) * by blast
               subgoal using prems(6) * by blast
               subgoal using prems(7) ** by blast
               done
             thus ?thesis using IH lk by presburger
           qed
           then obtain lk' where lk': "lk' \<le> lk" "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) lk' (k \<cdot> \<sigma>)"
             by blast
 
           have "lk' < n" using lk'(1) lk(1) by linarith
           thus ?thesis using lk'(2) by blast
         qed
 
         have KR'': "Ana (u \<cdot> \<sigma>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>, R \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)"
           using Ana_subst' KR unfolding u' by blast
 
         obtain r where r: "r \<in> set R" "t \<cdot> \<theta> = r \<cdot> \<theta>"
           using s'(2) by fastforce
 
         have r': "t \<cdot> \<sigma> \<in> set (R \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)"
         proof -
           have r_subterm_u: "r \<sqsubseteq> u" using r(1) KR Ana_subterm by blast
 
           have r_fv: "fv r \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M"
             by (meson r_subterm_u u(1) fv_subset_subterms in_mono in_subterms_subset_Union)
 
           have t_subterms_M: "subterms t \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t (insert t M)"
             by blast
 
           have r_subterm_M: "subterms r \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t (insert t M)"
             using subterms_subset[OF r_subterm_u] in_subterms_subset_Union[OF u(1)]
             by (auto intro: subterms\<^sub>s\<^sub>e\<^sub>t_mono)
 
           have *: "\<forall>x \<in> fv t \<union> fv r. \<theta> x = \<sigma> x \<or> \<not>(\<theta> x \<sqsubseteq> t) \<and> \<not>(\<theta> x \<sqsubseteq> r)"
           proof
             fix x assume "x \<in> fv t \<union> fv r"
             hence "x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv t" using r_fv by blast
             thus "\<theta> x = \<sigma> x \<or> \<not>(\<theta> x \<sqsubseteq> t) \<and> \<not>(\<theta> x \<sqsubseteq> r)"
               using prems(2,5,7) r_subterm_M t_subterms_M
               by (metis (no_types, opaque_lifting) in_mono)
           qed
 
           have **: "\<forall>x \<in> fv t \<union> fv r. \<exists>c. \<theta> x = Fun c []"
                    "\<forall>x \<in> fv t \<union> fv r. \<exists>c. \<sigma> x = Fun c []"
                    "\<forall>x \<in> fv t \<union> fv r. \<forall>y \<in> fv t \<union> fv r. \<theta> x = \<theta> y \<longleftrightarrow> \<sigma> x = \<sigma> y"
             subgoal using prems(2) r_fv by blast
             subgoal using prems(3) r_fv by blast
             subgoal using prems(6) r_fv by blast
             done
           
           have "t \<cdot> \<sigma> = r \<cdot> \<sigma>" by (rule subst_const_swap_eq'[OF r(2) * **])
           thus ?thesis using r(1) by simp
         qed
 
         obtain l1 where l1: "l1 < n" "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l1 (u \<cdot> \<sigma>)"
           using IH1 by blast
 
         let ?P = "\<lambda>s l. l < n \<and> intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) l s"
         define steps where "steps \<equiv> \<lambda>s. SOME l. ?P s l"
 
         have 2: "steps (k \<cdot> \<sigma>) < n" "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) (steps (k \<cdot> \<sigma>)) (k \<cdot> \<sigma>)"
           when k: "k \<in> set K" for k
           using someI_ex[OF IH2[OF k]] unfolding steps_def by (blast, blast)
 
         have 3: "Suc (Max (insert l1 (steps ` set (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)))) \<le> n"
         proof (cases "K = []")
           case True show ?thesis using l1(1) unfolding True n by simp
         next
           case False thus ?thesis
             using l1(1) 2 Max_nat_finite_lt[of "set (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)" steps n] by (simp add: Suc_leI)
         qed
 
         have IH2': "intruder_deduct_num ((M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<union> N) (steps k) k"
           when k: "k \<in> set (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>)" for k
           using IH2 k 2 by auto
 
         show ?thesis
           using l1(1) intruder_deduct_num.DecomposeN[OF l1(2) KR'' IH2' r'] 3 by fast
       qed
     qed
   qed
   thus ?thesis using deduct_if_deduct_num by blast
 qed
 
 lemma constraint_model_Nil:
   assumes I: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
   shows "constraint_model I []"
 using I unfolding constraint_model_def by simp
 
 lemma welltyped_constraint_model_Nil:
   assumes I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
   shows "welltyped_constraint_model I []"
 using I(1) constraint_model_Nil[OF I(2,3)] unfolding welltyped_constraint_model_def by simp
 
 lemma constraint_model_prefix:
   assumes "constraint_model I (A@B)"
   shows "constraint_model I A"
 by (metis assms strand_sem_append_stateful unlabel_append constraint_model_def)
 
 lemma welltyped_constraint_model_prefix:
   assumes "welltyped_constraint_model I (A@B)"
   shows "welltyped_constraint_model I A"
 by (metis assms constraint_model_prefix welltyped_constraint_model_def)
 
 lemma welltyped_constraint_model_deduct_append:
   assumes "welltyped_constraint_model I A"
     and "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> s \<cdot> I"
   shows "welltyped_constraint_model I (A@[(l,send\<langle>[s]\<rangle>)])"
 using assms strand_sem_append_stateful[of "{}" "{}" "unlabel A" _ I]
 unfolding welltyped_constraint_model_def constraint_model_def by simp
 
 lemma welltyped_constraint_model_deduct_split:
   assumes "welltyped_constraint_model I (A@[(l,send\<langle>[s]\<rangle>)])"
   shows "welltyped_constraint_model I A"
     and "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> s \<cdot> I"
 using assms strand_sem_append_stateful[of "{}" "{}" "unlabel A" _ I]
 unfolding welltyped_constraint_model_def constraint_model_def by simp_all
 
 lemma welltyped_constraint_model_deduct_iff:
   "welltyped_constraint_model I (A@[(l,send\<langle>[s]\<rangle>)]) \<longleftrightarrow>
     welltyped_constraint_model I A \<and> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> s \<cdot> I"
 by (metis welltyped_constraint_model_deduct_append welltyped_constraint_model_deduct_split)  
 
 lemma welltyped_constraint_model_attack_if_receive_attack:
   assumes I: "welltyped_constraint_model \<I> \<A>"
     and rcv_attack: "receive\<langle>ts\<rangle> \<in> set (unlabel \<A>)" "attack\<langle>n\<rangle> \<in> set ts"
   shows "welltyped_constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 proof -
   have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> attack\<langle>n\<rangle>"
     using rcv_attack in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of "attack\<langle>n\<rangle>" "unlabel \<A>"]
           ideduct_subst[OF intruder_deduct.Axiom[of "attack\<langle>n\<rangle>" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"], of \<I>]
     by auto
   thus ?thesis
     using I strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "[send\<langle>[attack\<langle>n\<rangle>]\<rangle>]" \<I>]
     unfolding welltyped_constraint_model_def constraint_model_def by auto
 qed
 
 lemma constraint_model_Val_is_Value_term:
   assumes "welltyped_constraint_model I A"
     and "t \<cdot> I = Fun (Val n) []"
   shows "t = Fun (Val n) [] \<or> (\<exists>m. t = Var (TAtom Value, m))"
 proof -
   have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" using assms(1) unfolding welltyped_constraint_model_def by simp
   moreover have "\<Gamma> (Fun (Val n) []) = TAtom Value" by auto
   ultimately have *: "\<Gamma> t = TAtom Value" by (metis (no_types) assms(2) wt_subst_trm'')
 
   show ?thesis
   proof (cases t)
     case (Var x)
     obtain \<tau> m where x: "x = (\<tau>, m)" by (metis surj_pair)
     have "\<Gamma>\<^sub>v x = TAtom Value" using * Var by auto
     hence "\<tau> = TAtom Value" using x \<Gamma>\<^sub>v_TAtom'[of Value \<tau> m] by simp
     thus ?thesis using x Var by metis
   next
     case (Fun f T) thus ?thesis using assms(2) by auto
   qed
 qed
 
 lemma wellformed_transaction_sem_receives:
   fixes T::"('fun,'atom,'sets,'lbl) prot_transaction"
   assumes T_valid: "wellformed_transaction T"
     and \<I>: "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I>"
     and s: "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   shows "\<forall>t \<in> set ts. IK \<turnstile> t \<cdot> \<I>"
 proof -
   let ?R = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?S = "\<lambda>A. unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?S' = "?S (transaction_receive T)"
 
   obtain l B s where B:
       "(l,send\<langle>ts\<rangle>) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
       "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     using s dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2)[of ts "transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain_subst[of "send\<langle>ts\<rangle>" "transaction_receive T" \<theta>]
     by blast
 
   have 1: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>])) = unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@[send\<langle>ts\<rangle>]"
     using B(1) unlabel_append dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst singleton_lst_proj(4)
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_snoc subst_lsst_append subst_lsst_singleton
     by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps)
 
   have "strand_sem_stateful IK DB ?S' \<I>"
     using \<I> strand_sem_append_stateful[of IK DB _ _ \<I>] transaction_dual_subst_unfold[of T \<theta>]
     by fastforce
   hence "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@[send\<langle>ts\<rangle>]) \<I>"
     using B 1 unfolding prefix_def unlabel_def
     by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def map_append strand_sem_append_stateful) 
   hence t_deduct: "\<forall>t \<in> set ts. IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<turnstile> t \<cdot> \<I>"
     using strand_sem_append_stateful[of IK DB "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" "[send\<langle>ts\<rangle>]" \<I>]
     by simp
 
   have "\<forall>s \<in> set (unlabel (transaction_receive T)). \<exists>t. s = receive\<langle>t\<rangle>"
     using T_valid wellformed_transaction_unlabel_cases(1)[OF T_valid] by auto
   moreover { fix A::"('fun,'atom,'sets,'lbl) prot_strand" and \<theta>
     assume "\<forall>s \<in> set (unlabel A). \<exists>t. s = receive\<langle>t\<rangle>"
     hence "\<forall>s \<in> set (unlabel (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)). \<exists>t. s = receive\<langle>t\<rangle>"
     proof (induction A)
       case (Cons a A) thus ?case using subst_lsst_cons[of a A \<theta>] by (cases a) auto
     qed simp
     hence "\<forall>s \<in> set (unlabel (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)). \<exists>t. s = receive\<langle>t\<rangle>"
       by (simp add: list.pred_set is_Receive_def)
     hence "\<forall>s \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))). \<exists>t. s = send\<langle>t\<rangle>"
       by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_memberD dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_inv(2) unlabel_in unlabel_mem_has_label)
   }
   ultimately have "\<forall>s \<in> set ?R. \<exists>ts. s = send\<langle>ts\<rangle>" by simp
   hence "ik\<^sub>s\<^sub>s\<^sub>t ?R = {}" unfolding unlabel_def ik\<^sub>s\<^sub>s\<^sub>t_def by fast
   hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) = {}"
     using B(2) 1 ik\<^sub>s\<^sub>s\<^sub>t_append dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append
     by (metis (no_types, lifting) Un_empty map_append prefix_def unlabel_def) 
   thus ?thesis using t_deduct by simp
 qed
 
 lemma wellformed_transaction_sem_pos_checks:
   assumes T_valid: "wellformed_transaction T"
     and \<I>: "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I>"
   shows "\<langle>ac: t \<in> u\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<Longrightarrow> (t \<cdot> \<I>, u \<cdot> \<I>) \<in> DB"
     and "\<langle>ac: t \<doteq> u\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<Longrightarrow> t \<cdot> \<I> = u \<cdot> \<I>"
 proof -
   let ?s = "\<langle>ac: t \<in> u\<rangle>"
   let ?s' = "\<langle>ac: t \<doteq> u\<rangle>"
   let ?C = "set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?R = "transaction_receive T@transaction_checks T"
   let ?R' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?S = "\<lambda>A. unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?S' = "?S (transaction_receive T)@?S (transaction_checks T)"
   let ?P = "\<lambda>a. is_Receive a \<or> is_Check_or_Assignment a"
   let ?Q = "\<lambda>a. is_Send a \<or> is_Check_or_Assignment a"
   let ?dbupd = "\<lambda>B. dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I> DB"
 
   have s_in: "?s \<in> ?C \<Longrightarrow> ?s \<in> set (unlabel (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
              "?s' \<in> ?C \<Longrightarrow> ?s' \<in> set (unlabel (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     using subst_lsst_append[of "transaction_receive T"]
           unlabel_append[of "transaction_receive T"]
     by auto
 
   have 1: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>])) = unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@[s']"
     when B: "(l,s') = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)" "s' = \<langle>ac: t \<in> u\<rangle> \<or> s' = \<langle>ac: t \<doteq> u\<rangle>"
     for l s s' and B::"('fun,'atom,'sets,'lbl) prot_strand"
     using B unlabel_append dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst singleton_lst_proj(4)
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_snoc subst_lsst_append subst_lsst_singleton
     by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps)
 
 
   have 2: "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@[s']) \<I>"
     when B: "(l,s') = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
             "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
             "s' = \<langle>ac: t \<in> u\<rangle> \<or> s' = \<langle>ac: t \<doteq> u\<rangle>"
     for l s s' and B::"('fun,'atom,'sets,'lbl) prot_strand"
   proof -
     have "strand_sem_stateful IK DB ?S' \<I>"
       using \<I> strand_sem_append_stateful[of IK DB _ _ \<I>] transaction_dual_subst_unfold[of T \<theta>]
       by fastforce
     thus ?thesis
       using B(2) 1[OF B(1,3)] strand_sem_append_stateful subst_lsst_append
       unfolding prefix_def unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by (metis (no_types) map_append)
   qed
 
   have s_sem:
       "?s \<in> ?C \<Longrightarrow> (l,?s) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>) \<Longrightarrow> (t \<cdot> \<I>, u \<cdot> \<I>) \<in> ?dbupd B"
       "?s' \<in> ?C \<Longrightarrow> (l,?s') = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>) \<Longrightarrow> t \<cdot> \<I> = u \<cdot> \<I>"
     when B: "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     for l s and B::"('fun,'atom,'sets,'lbl) prot_strand"
     using 2[OF _ B] strand_sem_append_stateful[of IK DB "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" _ \<I>]
     by (fastforce, fastforce)
 
   have 3: "\<forall>a \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))). \<not>is_Insert a \<and> \<not>is_Delete a"
     when B: "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     for l s and B::"('fun,'atom,'sets,'lbl) prot_strand"
   proof -
     have "\<forall>a \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))). ?Q a"
     proof
       fix a assume a: "a \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
   
       have "?P a" when a: "a \<in> set (unlabel ?R)" for a
         using a wellformed_transaction_unlabel_cases(1,2)[OF T_valid]
         unfolding unlabel_def by fastforce
       hence "?P a" when a: "a \<in> set (unlabel (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" for a
         using a stateful_strand_step_cases_subst(2,11)[of _ \<theta>] subst_lsst_unlabel[of ?R \<theta>]
         unfolding subst_apply_stateful_strand_def by auto
       hence B_P: "\<forall>a \<in> set (unlabel (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)). ?P a"
         using unlabel_mono[OF set_mono_prefix[OF append_prefixD[OF B]]]  by blast
   
       obtain l where "(l,a) \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
         using a by (meson unlabel_mem_has_label)
       then obtain b where b: "(l,b) \<in> set (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,b) = (l,a)"
         using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_memberD by blast
       hence "?P b" using B_P unfolding unlabel_def by fastforce
       thus "?Q a" using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_inv[OF b(2)] by (cases b) auto
     qed
     thus ?thesis by fastforce
   qed
 
   show "(t \<cdot> \<I>, u \<cdot> \<I>) \<in> DB" when s: "?s \<in> ?C"
   proof -
     obtain l B s where B:
         "(l,?s) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
         "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
       using s_in(1)[OF s] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(6)[of _ t u]
             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain_subst[of ?s ?R \<theta>]
       by blast
 
     show ?thesis
       using 3[OF B(2)] s_sem(1)[OF B(2) s B(1)]
             dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" \<I> DB]
       by simp
   qed
 
   show "t \<cdot> \<I> = u \<cdot> \<I>" when s: "?s' \<in> ?C"
   proof -
     obtain l B s where B:
         "(l,?s') = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
         "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
       using s_in(2)[OF s] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(3)[of _ t u]
             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain_subst[of ?s' ?R \<theta>]
       by blast
 
     show ?thesis
       using 3[OF B(2)] s_sem(2)[OF B(2) s B(1)]
             dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" \<I> DB]
       by simp
   qed
 qed
 
 lemma wellformed_transaction_sem_neg_checks:
   assumes T_valid: "wellformed_transaction T"
     and \<I>: "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I>"
     and "NegChecks X F G \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   shows "negchecks_model \<I> DB X F G"
 proof -
   let ?s = "NegChecks X F G"
   let ?R = "transaction_receive T@transaction_checks T"
   let ?R' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?S = "\<lambda>A. unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?S' = "?S (transaction_receive T)@?S (transaction_checks T)"
   let ?P = "\<lambda>a. is_Receive a \<or> is_Check_or_Assignment a"
   let ?Q = "\<lambda>a. is_Send a \<or> is_Check_or_Assignment a"
   let ?U = "\<lambda>\<delta>. subst_domain \<delta> = set X \<and> ground (subst_range \<delta>)"
 
   have s: "?s \<in> set (unlabel (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     using assms(3) subst_lsst_append[of "transaction_receive T"]
           unlabel_append[of "transaction_receive T"]
     by auto
 
   obtain l B s where B:
       "(l,?s) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ((l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
       "prefix ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]) (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     using s dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(7)[of X F G]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_in_set_prefix_obtain_subst[of ?s ?R \<theta>]
     by blast
 
   have 1: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@[(l,s) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>])) = unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@[?s]"
     using B(1) unlabel_append dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst singleton_lst_proj(4)
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_snoc subst_lsst_append subst_lsst_singleton
     by (metis (no_types, lifting) subst_apply_labeled_stateful_strand_step.simps)
 
   have "strand_sem_stateful IK DB ?S' \<I>"
     using \<I> strand_sem_append_stateful[of IK DB _ _ \<I>] transaction_dual_subst_unfold[of T \<theta>]
     by fastforce
   hence "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@[?s]) \<I>"
     using B 1 strand_sem_append_stateful subst_lsst_append
     unfolding prefix_def unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def
     by (metis (no_types) map_append)
   hence s_sem: "negchecks_model \<I> (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I> DB) X F G"
     using strand_sem_append_stateful[of IK DB "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" "[?s]" \<I>]
     by fastforce
 
   have "\<forall>a \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))). ?Q a"
   proof
     fix a assume a: "a \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
 
     have "?P a" when a: "a \<in> set (unlabel ?R)" for a
       using a wellformed_transaction_unlabel_cases(1,2,3)[OF T_valid]
       unfolding unlabel_def by fastforce
     hence "?P a" when a: "a \<in> set (unlabel (?R \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" for a
       using a stateful_strand_step_cases_subst(2,11)[of _ \<theta>] subst_lsst_unlabel[of ?R \<theta>]
       unfolding subst_apply_stateful_strand_def by auto
     hence B_P: "\<forall>a \<in> set (unlabel (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)). ?P a"
       using unlabel_mono[OF set_mono_prefix[OF append_prefixD[OF B(2)]]]
       by blast
 
     obtain l where "(l,a) \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using a by (meson unlabel_mem_has_label)
     then obtain b where b: "(l,b) \<in> set (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,b) = (l,a)"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_memberD by blast
     hence "?P b" using B_P unfolding unlabel_def by fastforce
     thus "?Q a" using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_inv[OF b(2)] by (cases b) auto
   qed
   hence "\<forall>a \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))). \<not>is_Insert a \<and> \<not>is_Delete a" by fastforce
   thus ?thesis using dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (B \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" \<I> DB] s_sem by simp
 qed
 
 lemma wellformed_transaction_sem_neg_checks':
   assumes T_valid: "wellformed_transaction T"
     and \<I>: "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I>"
     and c: "NegChecks X [] [(t,u)] \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   shows "\<forall>\<delta>. subst_domain \<delta> = set X \<and> ground (subst_range \<delta>) \<longrightarrow> (t \<cdot> \<delta> \<cdot> \<I>, u \<cdot> \<delta> \<cdot> \<I>) \<notin> DB" (is ?A)
     and "X = [] \<Longrightarrow> (t \<cdot> \<I>, u \<cdot> \<I>) \<notin> DB" (is "?B \<Longrightarrow> ?B'")
 proof -
   show ?A
     using wellformed_transaction_sem_neg_checks[OF T_valid \<I> c]
     unfolding negchecks_model_def by auto
   moreover have "\<delta> = Var" "t \<cdot> \<delta> = t"
     when "subst_domain \<delta> = set []" for t and \<delta>::"('fun, 'atom, 'sets, 'lbl) prot_subst"
     using that by auto
   moreover have "subst_domain Var = set []" "range_vars Var = {}"
     by simp_all
   ultimately show "?B \<Longrightarrow> ?B'" unfolding range_vars_alt_def by metis
 qed
 
 lemma wellformed_transaction_sem_iff:
   fixes T \<theta>
   defines "A \<equiv> unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     and "rm \<equiv> \<lambda>X. rm_vars (set X)"
   assumes T: "wellformed_transaction T"
     and I: " interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
   shows "strand_sem_stateful M D A I \<longleftrightarrow> (
     (\<forall>l ts. (l,receive\<langle>ts\<rangle>) \<in> set (transaction_receive T) \<longrightarrow> (\<forall>t \<in> set ts. M \<turnstile> t \<cdot> \<theta> \<cdot> I)) \<and>
     (\<forall>l ac t s. (l,\<langle>ac: t \<doteq> s\<rangle>) \<in> set (transaction_checks T) \<longrightarrow> t \<cdot> \<theta> \<cdot> I = s \<cdot> \<theta> \<cdot> I) \<and>
     (\<forall>l ac t s. (l,\<langle>ac: t \<in> s\<rangle>) \<in> set (transaction_checks T) \<longrightarrow> (t \<cdot> \<theta> \<cdot> I, s \<cdot> \<theta> \<cdot> I) \<in> D) \<and>
     (\<forall>l X F G. (l,\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>) \<in> set (transaction_checks T) \<longrightarrow>
       (\<forall>\<delta>. subst_domain \<delta> = set X \<and> ground (subst_range \<delta>) \<longrightarrow>
             (\<exists>(t,s) \<in> set F. t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I \<noteq> s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<or>
             (\<exists>(t,s) \<in> set G. (t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I, s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<notin> D))))"
     (is "?A \<longleftrightarrow> ?B")
 proof
   note 0 = A_def transaction_dual_subst_unlabel_unfold
   note 1 = wellformed_transaction_sem_receives[OF T, of M D \<theta> I, unfolded A_def[symmetric]]
            wellformed_transaction_sem_pos_checks[OF T, of M D \<theta> I, unfolded A_def[symmetric]]
            wellformed_transaction_sem_neg_checks[OF T, of M D \<theta> I, unfolded A_def[symmetric]]
   note 2 = stateful_strand_step_subst_inI[OF unlabel_in]
   note 3 = unlabel_subst
   note 4 = strand_sem_append_stateful[of M D _ _ I]
 
   let ?C = "\<lambda>T. unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   let ?P = "\<lambda>X \<delta>. subst_domain \<delta> = set X \<and> ground (subst_range \<delta>)"
   let ?sem = "\<lambda>M D T. strand_sem_stateful M D (?C T) I"
   let ?negchecks = "\<lambda>X F G. \<forall>\<delta>. ?P X \<delta> \<longrightarrow>
                                  (\<exists>(t,s) \<in> set F. t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I \<noteq> s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<or>
                                  (\<exists>(t,s) \<in> set G. (t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I, s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<notin> D)"
 
   have "list_all is_Receive (unlabel (transaction_receive T))"
        "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
        "list_all is_Update (unlabel (transaction_updates T))"
        "list_all is_Send (unlabel (transaction_send T))"
     using T unfolding wellformed_transaction_def by (blast, blast, blast, blast)
   hence 5: "list_all is_Send (?C (transaction_receive T))"
            "list_all is_Check_or_Assignment (?C (transaction_checks T))"
            "list_all is_Update (?C (transaction_updates T))"
            "list_all is_Receive (?C (transaction_send T))"
     by (metis (no_types) subst_sst_list_all(2) unlabel_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(1),
         metis (no_types) subst_sst_list_all(11) unlabel_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(11),
         metis (no_types) subst_sst_list_all(10) unlabel_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(10),
         metis (no_types) subst_sst_list_all(1) unlabel_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(2))
   
   have "\<forall>a \<in> set (?C (transaction_receive T)). \<not>is_Receive a \<and> \<not>is_Insert a \<and> \<not>is_Delete a"
        "\<forall>a \<in> set (?C (transaction_checks T)). \<not>is_Receive a \<and> \<not>is_Insert a \<and> \<not>is_Delete a"
     using 5(1,2) unfolding list_all_iff by (blast,blast)
   hence 6:
       "M \<union> (ik\<^sub>s\<^sub>s\<^sub>t (?C (transaction_receive T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = M"
       "dbupd\<^sub>s\<^sub>s\<^sub>t (?C (transaction_receive T)) I D = D"
       "M \<union> (ik\<^sub>s\<^sub>s\<^sub>t (?C (transaction_checks T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = M"
       "dbupd\<^sub>s\<^sub>s\<^sub>t (?C (transaction_checks T)) I D = D"
     by (metis ik\<^sub>s\<^sub>s\<^sub>t_snoc_no_receive_empty sup_bot.right_neutral, metis dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd,
         metis ik\<^sub>s\<^sub>s\<^sub>t_snoc_no_receive_empty sup_bot.right_neutral, metis dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd)
 
   have ?B when A: ?A
   proof -
     have "M \<turnstile> t \<cdot> \<theta> \<cdot> I"
       when "(l, receive\<langle>ts\<rangle>) \<in> set (transaction_receive T)" "t \<in> set ts" for l ts t
       using that(2) 1(1)[OF A, of "ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"] 2(2)[OF that(1)] unfolding 3 by auto
     moreover have "t \<cdot> \<theta> \<cdot> I = s \<cdot> \<theta> \<cdot> I"
       when "(l, \<langle>ac: t \<doteq> s\<rangle>) \<in> set (transaction_checks T)" for l ac t s
       using 1(3)[OF A] 2(3)[OF that] unfolding 3 by blast
     moreover have "(t \<cdot> \<theta> \<cdot> I, s \<cdot> \<theta> \<cdot> I) \<in> D"
       when "(l, \<langle>ac: t \<in> s\<rangle>) \<in> set (transaction_checks T)" for l ac t s
       using 1(2)[OF A] 2(6)[OF that] unfolding 3 by blast
     moreover have "?negchecks X F G"
       when "(l, \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>) \<in> set (transaction_checks T)" for l X F G
       using 1(4)[OF A 2(7)[OF that, of \<theta>, unfolded 3]]
       unfolding negchecks_model_def rm_def subst_apply_pairs_def by fastforce
     ultimately show ?B by blast
   qed
   thus "?A \<Longrightarrow> ?B" by fast
 
   have ?A when B: ?B
   proof -
     have 7: "\<forall>t \<in> set ts. M \<turnstile> t \<cdot> I" when ts: "send\<langle>ts\<rangle> \<in> set (?C (transaction_receive T))" for ts
     proof -
       obtain l ss where "(l,receive\<langle>ss\<rangle>) \<in> set (transaction_receive T)" "ts = ss \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"
         by (metis ts dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2) subst_lsst_memD(1) unlabel_mem_has_label)
       thus ?thesis using B by auto
     qed
 
     have 8: "t \<cdot> I = s \<cdot> I" when ts: "\<langle>ac: t \<doteq> s\<rangle> \<in> set (?C (transaction_checks T))" for ac t s
     proof -
       obtain l t' s' where "(l,\<langle>ac: t' \<doteq> s'\<rangle>) \<in> set (transaction_checks T)" "t = t' \<cdot> \<theta>" "s = s' \<cdot> \<theta>"
         by (metis ts dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(3) subst_lsst_memD(3) unlabel_mem_has_label)
       thus ?thesis using B by auto
     qed
 
     have 9: "(t \<cdot> I, s \<cdot> I) \<in> D" when ts: "\<langle>ac: t \<in> s\<rangle> \<in> set (?C (transaction_checks T))" for ac t s
     proof -
       obtain l t' s' where "(l,\<langle>ac: t' \<in> s'\<rangle>) \<in> set (transaction_checks T)" "t = t' \<cdot> \<theta>" "s = s' \<cdot> \<theta>"
         by (metis ts dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(6) subst_lsst_memD(6) unlabel_mem_has_label)
       thus ?thesis using B by auto
     qed
 
     have 10: "negchecks_model I D X F G"
       when ts: "\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> \<in> set (?C (transaction_checks T))" for X F G
     proof -
       obtain l F' G' where *:
           "(l,\<forall>X\<langle>\<or>\<noteq>: F' \<or>\<notin>: G'\<rangle>) \<in> set (transaction_checks T)"
           "F = F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<theta>" "G = G' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<theta>"
         using unlabel_mem_has_label[OF iffD2[OF dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(7) ts]]
               subst_lsst_memD(7)[of _ X F G "transaction_checks T" \<theta>]
         by fast
 
       have "?negchecks X F' G'" using *(1) B by blast
       moreover have "\<exists>(t,s) \<in> set F. t \<cdot> \<delta> \<circ>\<^sub>s I \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s I"
         when "(t,s) \<in> set F'" "t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I \<noteq> s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I" for \<delta> t s
         using that unfolding rm_def *(2) subst_apply_pairs_def by force
       moreover have "\<exists>(t,s) \<in> set G. (t,s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s I \<notin> D"
         when "(t,s) \<in> set G'" "(t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I, s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<notin> D" for \<delta> t s
         using that unfolding rm_def *(3) subst_apply_pairs_def by force
       ultimately show ?thesis
         unfolding negchecks_model_def by auto
     qed
     
     have "?sem M D (transaction_receive T)"
       using 7 strand_sem_stateful_if_sends_deduct[OF 5(1)] by blast
     moreover have "?sem M D (transaction_checks T)"
       using 8 9 10 strand_sem_stateful_if_checks[OF 5(2)] by blast
     moreover have "?sem M D (transaction_updates T)" for M D
       using 5(3) strand_sem_stateful_if_no_send_or_check unfolding list_all_iff by blast
     moreover have "?sem M D (transaction_send T)" for M D
       using 5(4) strand_sem_stateful_if_no_send_or_check unfolding list_all_iff by blast
     ultimately show ?thesis
       using 4[of "?C (transaction_receive T)"
                  "?C (transaction_checks T)@?C (transaction_updates T)@?C (transaction_send T)"]
             4[of "?C (transaction_checks T)" "?C (transaction_updates T)@?C (transaction_send T)"]
             4[of "?C (transaction_updates T)" "?C (transaction_send T)"]
       unfolding 0 6 by blast
   qed
   thus "?B \<Longrightarrow> ?A" by fast
 qed
 
 lemma wellformed_transaction_unlabel_sem_iff:
   fixes T \<theta>
   defines "A \<equiv> unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     and "rm \<equiv> \<lambda>X. rm_vars (set X)"
   assumes T: "wellformed_transaction T"
     and I: " interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
   shows "strand_sem_stateful M D A I \<longleftrightarrow> (
     (\<forall>ts. receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T)) \<longrightarrow> (\<forall>t \<in> set ts. M \<turnstile> t \<cdot> \<theta> \<cdot> I)) \<and>
     (\<forall>ac t s. \<langle>ac: t \<doteq> s\<rangle> \<in> set (unlabel (transaction_checks T)) \<longrightarrow> t \<cdot> \<theta> \<cdot> I = s \<cdot> \<theta> \<cdot> I) \<and>
     (\<forall>ac t s. \<langle>ac: t \<in> s\<rangle> \<in> set (unlabel (transaction_checks T)) \<longrightarrow> (t \<cdot> \<theta> \<cdot> I, s \<cdot> \<theta> \<cdot> I) \<in> D) \<and>
     (\<forall>X F G. \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> \<in> set (unlabel (transaction_checks T)) \<longrightarrow>
       (\<forall>\<delta>. subst_domain \<delta> = set X \<and> ground (subst_range \<delta>) \<longrightarrow>
             (\<exists>(t,s) \<in> set F. t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I \<noteq> s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<or>
             (\<exists>(t,s) \<in> set G. (t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I, s \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I) \<notin> D))))"
 using wellformed_transaction_sem_iff[OF T I, of M D \<theta>]
       unlabel_in[of _ _ "transaction_receive T"] unlabel_mem_has_label[of _ "transaction_receive T"]
       unlabel_in[of _ _ "transaction_checks T"] unlabel_mem_has_label[of _ "transaction_checks T"]
 unfolding A_def[symmetric] rm_def by meson
 
 lemma dual_transaction_ik_is_transaction_send'':
   fixes \<delta> \<I>::"('a,'b,'c,'d) prot_subst"
   assumes "wellformed_transaction T"
   shows "(ik\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>))) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a =
          (trms\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a" (is "?A = ?B")
 using dual_transaction_ik_is_transaction_send[OF assms]
       subst_lsst_unlabel[of "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)" \<delta>]
       ik\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))" \<delta>]
       dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of "transaction_strand T" \<delta>]
 by (auto simp add: abs_apply_terms_def)
 
 lemma while_prot_terms_fun_mono:
   "mono (\<lambda>M'. M \<union> \<Union>(subterms ` M') \<union> \<Union>((set \<circ> fst \<circ> Ana) ` M'))"
 unfolding mono_def by fast
 
 lemma while_prot_terms_SMP_overapprox:
   fixes M::"('fun,'atom,'sets,'lbl) prot_terms"
   assumes N_supset: "M \<union> \<Union>(subterms ` N) \<union> \<Union>((set \<circ> fst \<circ> Ana) ` N) \<subseteq> N"
     and Value_vars_only: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t N. \<Gamma>\<^sub>v x = TAtom Value"
   shows "SMP M \<subseteq> {a \<cdot> \<delta> | a \<delta>. a \<in> N \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)}"
 proof -
   define f where "f \<equiv> \<lambda>M'. M \<union> \<Union>(subterms ` M') \<union> \<Union>((set \<circ> fst \<circ> Ana) ` M')"
   define S where "S \<equiv> {a \<cdot> \<delta> | a \<delta>. a \<in> N \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)}"
 
   note 0 = Value_vars_only
   
   have "t \<in> S" when "t \<in> SMP M" for t
   using that
   proof (induction t rule: SMP.induct)
     case (MP t)
     hence "t \<in> N" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)" using N_supset by auto
     hence "t \<cdot> Var \<in> S" unfolding S_def by blast
     thus ?case by simp
   next
     case (Subterm t t')
     then obtain \<delta> a where a: "a \<cdot> \<delta> = t" "a \<in> N" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)"
       by (auto simp add: S_def)
     hence "\<forall>x \<in> fv a. \<exists>\<tau>. \<Gamma> (Var x) = TAtom \<tau>" using 0 by auto
     hence *: "\<forall>x \<in> fv a. (\<exists>f. \<delta> x = Fun f []) \<or> (\<exists>y. \<delta> x = Var y)"
       using a(3) TAtom_term_cases[OF wf_trm_subst_rangeD[OF a(4)]]
       by (metis wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def)
     obtain b where b: "b \<cdot> \<delta> = t'" "b \<in> subterms a"
       using subterms_subst_subterm[OF *, of t'] Subterm.hyps(2) a(1)
       by fast
     hence "b \<in> N" using N_supset a(2) by blast
     thus ?case using a b(1) unfolding S_def by blast
   next
     case (Substitution t \<theta>)
     then obtain \<delta> a where a: "a \<cdot> \<delta> = t" "a \<in> N" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)"
       by (auto simp add: S_def)
     have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<delta> \<circ>\<^sub>s \<theta>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\<delta> \<circ>\<^sub>s \<theta>))"
       by (fact wt_subst_compose[OF a(3) Substitution.hyps(2)],
           fact wf_trms_subst_compose[OF a(4) Substitution.hyps(3)])
     moreover have "t \<cdot> \<theta> = a \<cdot> \<delta> \<circ>\<^sub>s \<theta>" using a(1) subst_subst_compose[of a \<delta> \<theta>] by simp
     ultimately show ?case using a(2) unfolding S_def by blast
   next
     case (Ana t K T k)
     then obtain \<delta> a where a: "a \<cdot> \<delta> = t" "a \<in> N" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)"
       by (auto simp add: S_def)
-    obtain Ka Ta where a': "Ana a = (Ka,Ta)" by moura
+    obtain Ka Ta where a': "Ana a = (Ka,Ta)" by force
     have *: "K = Ka \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>"
     proof (cases a)
       case (Var x)
       then obtain g U where gU: "t = Fun g U"
         using a(1) Ana.hyps(2,3) Ana_var
         by (cases t) simp_all
       have "\<Gamma> (Var x) = TAtom Value" using Var a(2) 0 by auto
       hence "\<Gamma> (Fun g U) = TAtom Value"
         using a(1,3) Var gU wt_subst_trm''[OF a(3), of a]
         by argo
       thus ?thesis using gU Fun_Value_type_inv Ana.hyps(2,3) by fastforce  
     next
       case (Fun g U) thus ?thesis using a(1) a' Ana.hyps(2) Ana_subst'[of g U] by simp
     qed
     then obtain ka where ka: "k = ka \<cdot> \<delta>" "ka \<in> set Ka" using Ana.hyps(3) by auto
     have "ka \<in> set ((fst \<circ> Ana) a)" using ka(2) a' by simp
     hence "ka \<in> N" using a(2) N_supset by auto
     thus ?case using ka a(3,4) unfolding S_def by blast
   qed
   thus ?thesis unfolding S_def by blast
 qed
 
 
 subsection \<open>Admissible Transactions\<close>
 definition admissible_transaction_checks where
   "admissible_transaction_checks T \<equiv>
     \<forall>x \<in> set (unlabel (transaction_checks T)).
       (is_InSet x \<longrightarrow>
           is_Var (the_elem_term x) \<and> is_Fun_Set (the_set_term x) \<and>
           fst (the_Var (the_elem_term x)) = TAtom Value) \<and>
       (is_NegChecks x \<longrightarrow>
           bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p x = [] \<and>
           ((the_eqs x = [] \<and> length (the_ins x) = 1) \<or>
            (the_ins x = [] \<and> length (the_eqs x) = 1))) \<and>
       (is_NegChecks x \<and> the_eqs x = [] \<longrightarrow> (let h = hd (the_ins x) in
           is_Var (fst h) \<and> is_Fun_Set (snd h) \<and>
           fst (the_Var (fst h)) = TAtom Value))"
 
 definition admissible_transaction_updates where
   "admissible_transaction_updates T \<equiv>
     \<forall>x \<in> set (unlabel (transaction_updates T)).
       is_Update x \<and> is_Var (the_elem_term x) \<and> is_Fun_Set (the_set_term x) \<and>
       fst (the_Var (the_elem_term x)) = TAtom Value"
 
 definition admissible_transaction_terms where
   "admissible_transaction_terms T \<equiv>
     wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) \<and>
     (\<forall>f \<in> \<Union>(funs_term ` trms_transaction T).
       \<not>is_Val f \<and> \<not>is_Abs f \<and> \<not>is_PubConst f \<and> f \<noteq> Pair) \<and>
     (\<forall>r \<in> set (unlabel (transaction_strand T)).
       (\<exists>f \<in> \<Union>(funs_term ` (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r)). is_Attack f) \<longrightarrow>
         transaction_fresh T = [] \<and>
         is_Send r \<and> length (the_msgs r) = 1 \<and> is_Fun_Attack (hd (the_msgs r)))"
 
 definition admissible_transaction_send_occurs_form where
   "admissible_transaction_send_occurs_form T \<equiv> (
     let snds = transaction_send T;
         frsh = transaction_fresh T
     in \<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t snds. OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t \<longrightarrow>
         (\<exists>x \<in> set frsh. t = occurs (Var x))
 )"
 
 definition admissible_transaction_occurs_checks where
   "admissible_transaction_occurs_checks T \<equiv> (
     let occ_in = \<lambda>x S. occurs (Var x) \<in> set (the_msgs (hd (unlabel S)));
         rcvs = transaction_receive T;
         snds = transaction_send T;
         frsh = transaction_fresh T;
         fvs = fv_transaction T
     in admissible_transaction_send_occurs_form T \<and>
        ((\<exists>x \<in> fvs - set frsh. fst x = TAtom Value) \<longrightarrow> (
           rcvs \<noteq> [] \<and> is_Receive (hd (unlabel rcvs)) \<and>
           (\<forall>x \<in> fvs - set frsh. fst x = TAtom Value \<longrightarrow> occ_in x rcvs))) \<and>
        (frsh \<noteq> [] \<longrightarrow> (
           snds \<noteq> [] \<and> is_Send (hd (unlabel snds)) \<and>
           (\<forall>x \<in> set frsh. occ_in x snds)))
 )"
 
 definition admissible_transaction_no_occurs_msgs where
   "admissible_transaction_no_occurs_msgs T \<equiv> (
     let no_occ = \<lambda>t. is_Fun t \<longrightarrow> the_Fun t \<noteq> OccursFact;
         rcvs = transaction_receive T;
         snds = transaction_send T
     in list_all (\<lambda>a. is_Receive (snd a) \<longrightarrow> list_all no_occ (the_msgs (snd a))) rcvs \<and>
        list_all (\<lambda>a. is_Send (snd a)    \<longrightarrow> list_all no_occ (the_msgs (snd a))) snds
 )"
 
 definition admissible_transaction' where
   "admissible_transaction' T \<equiv> (
     wellformed_transaction T \<and>
     transaction_decl T () = [] \<and>
     list_all (\<lambda>x. fst x = TAtom Value) (transaction_fresh T) \<and>
     (\<forall>x \<in> vars_transaction T. is_Var (fst x) \<and> (the_Var (fst x) = Value)) \<and>
     bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) = {} \<and>
     set (transaction_fresh T) \<subseteq>
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (filter (is_Insert \<circ> snd) (transaction_updates T)) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<and>
     (\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
      \<forall>y \<in> fv_transaction T - set (transaction_fresh T).
       x \<noteq> y \<longrightarrow> \<langle>Var x != Var y\<rangle> \<in> set (unlabel (transaction_checks T)) \<or>
                 \<langle>Var y != Var x\<rangle> \<in> set (unlabel (transaction_checks T))) \<and>
     fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) - set (transaction_fresh T)
       \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
     (\<forall>r \<in> set (unlabel (transaction_checks T)).
       is_Equality r \<longrightarrow> fv (the_rhs r) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)) \<and>
     fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<subseteq>
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union>
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (filter (\<lambda>s. is_InSet (snd s) \<and> the_check (snd s) = Assign) (transaction_checks T)) \<and>
     list_all (\<lambda>a. is_Receive (snd a) \<longrightarrow> the_msgs (snd a) \<noteq> []) (transaction_receive T) \<and>
     list_all (\<lambda>a. is_Send (snd a) \<longrightarrow> the_msgs (snd a) \<noteq> []) (transaction_send T) \<and>
     admissible_transaction_checks T \<and>
     admissible_transaction_updates T \<and>
     admissible_transaction_terms T \<and>
     admissible_transaction_send_occurs_form T
 )"
 
 definition admissible_transaction where
   "admissible_transaction T \<equiv>
     admissible_transaction' T \<and>
     admissible_transaction_no_occurs_msgs T"
 
 definition has_initial_value_producing_transaction where
   "has_initial_value_producing_transaction P \<equiv>
     let f = \<lambda>s.
       list_all (\<lambda>T. list_all (\<lambda>a. ((is_Delete a \<or> is_InSet a) \<longrightarrow> the_set_term a \<noteq> \<langle>s\<rangle>\<^sub>s) \<and>
                                   (is_NegChecks a \<longrightarrow> list_all (\<lambda>(_,t). t \<noteq> \<langle>s\<rangle>\<^sub>s) (the_ins a)))
                              (unlabel (transaction_checks T@transaction_updates T)))
                P
     in list_ex (\<lambda>T.
         length (transaction_fresh T) = 1 \<and> transaction_receive T = [] \<and>
         transaction_checks T = [] \<and> length (transaction_send T) = 1 \<and>
         (let x = hd (transaction_fresh T); a = hd (transaction_send T); u = transaction_updates T
          in is_Send (snd a) \<and> Var x \<in> set (the_msgs (snd a)) \<and>
             fv\<^sub>s\<^sub>e\<^sub>t (set (the_msgs (snd a))) = {x} \<and>
             (u \<noteq> [] \<longrightarrow> (
               let b = hd u; c = snd b
               in tl u = [] \<and> is_Insert c \<and> the_elem_term c = Var x \<and>
                  is_Fun_Set (the_set_term c) \<and> f (the_Set (the_Fun (the_set_term c))))))
        ) P"
 
 
 lemma admissible_transaction_is_wellformed_transaction:
   assumes "admissible_transaction' T"
   shows "wellformed_transaction T"
     and "admissible_transaction_checks T"
     and "admissible_transaction_updates T"
     and "admissible_transaction_terms T"
     and "admissible_transaction_send_occurs_form T"
 using assms unfolding admissible_transaction'_def by blast+
 
 lemma admissible_transaction_no_occurs_msgsE:
   assumes T: "admissible_transaction' T" "admissible_transaction_no_occurs_msgs T"
   shows "\<forall>ts. send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T)) \<or>
               receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T)) \<longrightarrow>
                 (\<forall>t s. t \<in> set ts \<longrightarrow> t \<noteq> occurs s)"
 proof -
   note 1 = admissible_transaction_is_wellformed_transaction(1)[OF T(1)]
 
   have 2: "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
     when "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))" for ts
     using wellformed_transaction_strand_unlabel_memberD(8)[OF 1 that] by fast
 
   have 3: "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))"
     when "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))" for ts
     using wellformed_transaction_strand_unlabel_memberD(1)[OF 1 that] by fast
 
   show ?thesis
     using T(2) 2 3 wellformed_transaction_unlabel_cases(1,4)[OF 1]
     unfolding admissible_transaction_no_occurs_msgs_def Let_def list_all_iff
     by (metis sndI stateful_strand_step.discI(1,2) stateful_strand_step.sel(1,2)
               term.discI(2) term.sel(2) unlabel_mem_has_label)
 qed
 
 lemma admissible_transactionE:
   assumes T: "admissible_transaction' T"
   shows "transaction_decl T () = []" (is ?A)
     and "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value" (is ?B)
     and "\<forall>x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T). \<Gamma>\<^sub>v x = TAtom Value" (is ?C)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) = {}" (is ?D1)
     and "fv_transaction T \<inter> bvars_transaction T = {}" (is ?D2)
     and "set (transaction_fresh T) \<subseteq>
           fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (filter (is_Insert \<circ> snd) (transaction_updates T)) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       (is ?E)
     and "set (transaction_fresh T) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       (is ?F)
     and "\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
          \<forall>y \<in> fv_transaction T - set (transaction_fresh T).
           x \<noteq> y \<longrightarrow> \<langle>Var x != Var y\<rangle> \<in> set (unlabel (transaction_checks T)) \<or>
                     \<langle>Var y != Var x\<rangle> \<in> set (unlabel (transaction_checks T))"
       (is ?G)
     and "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T).
           x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<or>
           (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> x \<in> fv t \<union> fv s)"
       (is ?H)
     and "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) - set (transaction_fresh T) \<subseteq>
           fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
       (is ?I)
     and "\<forall>x \<in> set (unlabel (transaction_checks T)).
           is_Equality x \<longrightarrow> fv (the_rhs x) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
       (is ?J) (* TODO: why do we need this requirement? *)
     and "set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {}" (is ?K1)
     and "set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = {}" (is ?K2)
     and "list_all (\<lambda>x. fst x = Var Value) (transaction_fresh T)" (is ?K3)
     and "\<forall>x \<in> vars_transaction T. \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x" (is ?K4)
     and "\<forall>l ts. (l,receive\<langle>ts\<rangle>) \<in> set (transaction_receive T) \<longrightarrow> ts \<noteq> []" (is ?L1)
     and "\<forall>l ts. (l,send\<langle>ts\<rangle>) \<in> set (transaction_send T) \<longrightarrow> ts \<noteq> []" (is ?L2)
 proof -
   show ?A ?D1 ?D2 ?G ?I ?J ?K3
     using T unfolding admissible_transaction'_def
     by (blast, blast, blast, blast, blast, blast, blast)
 
   have "list_all (\<lambda>a. is_Receive (snd a) \<longrightarrow> the_msgs (snd a) \<noteq> []) (transaction_receive T)"
        "list_all (\<lambda>a. is_Send (snd a) \<longrightarrow> the_msgs (snd a) \<noteq> []) (transaction_send T)"
     using T unfolding admissible_transaction'_def by auto
   thus ?L1 ?L2 unfolding list_all_iff by (force,force)
 
   have "list_all (\<lambda>x. fst x = Var Value) (transaction_fresh T)"
        "\<forall>x\<in>vars_transaction T. is_Var (fst x) \<and> the_Var (fst x) = Value"
     using T unfolding admissible_transaction'_def by (blast, blast)
   thus ?B ?C ?K4 using \<Gamma>\<^sub>v_TAtom''(2) unfolding list_all_iff by (blast, force, force)
 
   show ?E using T unfolding admissible_transaction'_def by argo
   thus ?F unfolding unlabel_def by auto
 
   show ?K1 ?K2
     using T unfolding admissible_transaction'_def wellformed_transaction_def by (argo, argo)
 
   let ?selects = "filter (\<lambda>s. is_InSet (snd s) \<and> the_check (snd s) = Assign) (transaction_checks T)"
 
   show ?H
   proof
     fix x assume "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
     hence "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<or> x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?selects"
       using T unfolding admissible_transaction'_def by blast
     thus "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<or>
           (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> x \<in> fv t \<union> fv s)"
     proof
       assume "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?selects"
       then obtain r where r: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p r" "r \<in> set (unlabel (transaction_checks T))"
                              "is_InSet r" "the_check r = Assign"
         unfolding unlabel_def by force
       thus ?thesis by (cases r) auto
     qed simp
   qed
 qed
 
 lemma admissible_transactionE':
   assumes T: "admissible_transaction T"
   shows "admissible_transaction' T" (is ?A)
     and "admissible_transaction_no_occurs_msgs T" (is ?B)
     and "\<forall>ts. send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T)) \<or>
               receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T)) \<longrightarrow>
                 (\<forall>t s. t \<in> set ts \<longrightarrow> t \<noteq> occurs s)"
       (is ?C)
 proof -
   show 0: ?A ?B using T unfolding admissible_transaction_def by (blast, blast)
   show ?C using admissible_transaction_no_occurs_msgsE[OF 0] by blast
 qed
 
 lemma transaction_inserts_are_Value_vars:
   assumes T_valid: "wellformed_transaction T"
     and "admissible_transaction_updates T"
     and "insert\<langle>t,s\<rangle> \<in> set (unlabel (transaction_strand T))"
   shows "\<exists>n. t = Var (TAtom Value, n)"
     and "\<exists>u. s = Fun (Set u) []"
 proof -
   let ?x = "insert\<langle>t,s\<rangle>"
 
   have "?x \<in> set (unlabel (transaction_updates T))"
     using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]    
     by (auto simp add: transaction_strand_def unlabel_def)
   hence *: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
            "is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
            "is_Set (the_Fun (the_set_term ?x))"
     using assms(2) unfolding admissible_transaction_updates_def is_Fun_Set_def by fastforce+
   
   show "\<exists>n. t = Var (TAtom Value, n)" using *(1,2) by (cases t) auto
   show "\<exists>u. s = Fun (Set u) []" using *(3,4,5) unfolding is_Set_def by (cases s) auto
 qed
 
 lemma transaction_deletes_are_Value_vars:
   assumes T_valid: "wellformed_transaction T"
     and "admissible_transaction_updates T"
     and "delete\<langle>t,s\<rangle> \<in> set (unlabel (transaction_strand T))"
   shows "\<exists>n. t = Var (TAtom Value, n)"
     and "\<exists>u. s = Fun (Set u) []"
 proof -
   let ?x = "delete\<langle>t,s\<rangle>"
 
   have "?x \<in> set (unlabel (transaction_updates T))"
     using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]    
     by (auto simp add: transaction_strand_def unlabel_def)
   hence *: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
            "is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
            "is_Set (the_Fun (the_set_term ?x))"
     using assms(2) unfolding admissible_transaction_updates_def is_Fun_Set_def by fastforce+
   
   show "\<exists>n. t = Var (TAtom Value, n)" using *(1,2) by (cases t) auto
   show "\<exists>u. s = Fun (Set u) []" using *(3,4,5) unfolding is_Set_def by (cases s) auto
 qed
 
 lemma transaction_selects_are_Value_vars:
   assumes T_valid: "wellformed_transaction T"
     and "admissible_transaction_checks T"
     and "select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_strand T))"
   shows "\<exists>n. t = Var (TAtom Value, n) \<and> (TAtom Value, n) \<notin> set (transaction_fresh T)" (is ?A)
     and "\<exists>u. s = Fun (Set u) []" (is ?B)
 proof -
   let ?x = "select\<langle>t,s\<rangle>"
 
   have *: "?x \<in> set (unlabel (transaction_checks T))"
     using assms(3) wellformed_transaction_unlabel_cases[OF T_valid, of ?x]    
     by (auto simp add: transaction_strand_def unlabel_def)
   
   have **: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
            "is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
            "is_Set (the_Fun (the_set_term ?x))"
     using * assms(2) unfolding admissible_transaction_checks_def is_Fun_Set_def by fastforce+
 
   have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
     using * by force
   hence ***: "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x \<inter> set (transaction_fresh T) = {}"
     using T_valid unfolding wellformed_transaction_def by fast
 
   show ?A using **(1,2) *** by (cases t) auto
   show ?B using **(3,4,5) unfolding is_Set_def by (cases s) auto
 qed
 
 lemma transaction_inset_checks_are_Value_vars:
   assumes T_valid: "admissible_transaction' T"
     and t: "\<langle>t in s\<rangle> \<in> set (unlabel (transaction_strand T))"
   shows "\<exists>n. t = Var (TAtom Value, n) \<and> (TAtom Value, n) \<notin> set (transaction_fresh T)" (is ?A)
     and "\<exists>u. s = Fun (Set u) []" (is ?B)
 proof -
   let ?x = "\<langle>t in s\<rangle>"
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_valid]
   note T_adm_checks = admissible_transaction_is_wellformed_transaction(2)[OF T_valid]
 
   have *: "?x \<in> set (unlabel (transaction_checks T))"
     using t wellformed_transaction_unlabel_cases[OF T_wf, of ?x]
     unfolding transaction_strand_def unlabel_def by fastforce
   
   have **: "is_Var (the_elem_term ?x)" "fst (the_Var (the_elem_term ?x)) = TAtom Value"
            "is_Fun (the_set_term ?x)" "args (the_set_term ?x) = []"
            "is_Set (the_Fun (the_set_term ?x))"
     using * T_adm_checks unfolding admissible_transaction_checks_def is_Fun_Set_def by fastforce+
 
   have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
     using * by force
   hence ***: "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x \<inter> set (transaction_fresh T) = {}"
     using T_wf unfolding wellformed_transaction_def by fast
 
   show ?A using **(1,2) *** by (cases t) auto
   show ?B using **(3,4,5) unfolding is_Set_def by (cases s) auto
 qed
 
 lemma transaction_notinset_checks_are_Value_vars:
   assumes T_adm: "admissible_transaction' T"
     and FG: "\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> \<in> set (unlabel (transaction_strand T))"
     and t: "(t,s) \<in> set G"
   shows "\<exists>n. t = Var (TAtom Value, n) \<and> (TAtom Value, n) \<notin> set (transaction_fresh T)" (is ?A)
     and "\<exists>u. s = Fun (Set u) []" (is ?B)
     and "F = []" (is ?C)
     and "G = [(t,s)]" (is ?D)
 proof -
   let ?x = "\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>"
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
   note T_adm_checks = admissible_transaction_is_wellformed_transaction(2)[OF T_adm]
 
   have 0: "?x \<in> set (unlabel (transaction_checks T))"
     using FG wellformed_transaction_unlabel_cases[OF T_wf, of ?x]    
     by (auto simp add: transaction_strand_def unlabel_def)
   hence 1: "F = [] \<and> length G = 1"
     using T_adm_checks t unfolding admissible_transaction_checks_def by fastforce
   hence "hd G = (t,s)" using t by (cases "the_ins ?x") auto
   hence **: "is_Var t" "fst (the_Var t) = TAtom Value" "is_Fun s" "args s = []" "is_Set (the_Fun s)"
     using 1 Set.bspec[OF T_adm_checks[unfolded admissible_transaction_checks_def] 0]
     unfolding is_Fun_Set_def by auto
 
   show ?C using 1 by blast
   show ?D using 1 t by force
 
   have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
        "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x) \<subseteq> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
     using 0 by force+
   moreover have
       "set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {}"
       "set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = {}"
     using T_wf unfolding wellformed_transaction_def by fast+
   ultimately have
       "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x \<inter> set (transaction_fresh T) = {}"
       "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p ?x) \<inter> set (transaction_fresh T) = {}"
     using admissible_transactionE(7)[OF T_adm]
           wellformed_transaction_wf\<^sub>s\<^sub>s\<^sub>t(2)[OF T_wf]
           fv_transaction_unfold[of T] bvars_transaction_unfold[of T]
     by (blast, blast)
   hence ***: "fv t \<inter> set (transaction_fresh T) = {}"
     using t by auto
 
   show ?A using **(1,2) *** by (cases t) auto
   show ?B using **(3,4,5) unfolding is_Set_def by (cases s) auto
 qed
 
 lemma transaction_noteqs_checks_case:
   assumes T_adm: "admissible_transaction' T"
     and FG: "\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> \<in> set (unlabel (transaction_strand T))"
     and G: "G = []"
   shows "\<exists>t s. F = [(t,s)]" (is ?A)
 proof -
   let ?x = "\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>"
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
   note T_adm_checks = admissible_transaction_is_wellformed_transaction(2)[OF T_adm]
 
   have "?x \<in> set (unlabel (transaction_checks T))"
     using FG wellformed_transaction_unlabel_cases[OF T_wf, of ?x]    
     by (auto simp add: transaction_strand_def unlabel_def)
   hence "length F = 1"
     using T_adm_checks unfolding admissible_transaction_checks_def G by fastforce
   thus ?thesis by fast
 qed
 
 lemma admissible_transaction_fresh_vars_notin:
   assumes T: "admissible_transaction' T"
     and x: "x \<in> set (transaction_fresh T)"
   shows "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)" (is ?A)
     and "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)" (is ?B)
     and "x \<notin> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)" (is ?C)
     and "x \<notin> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)" (is ?D)
     and "x \<notin> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)" (is ?E)
     and "x \<notin> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)" (is ?F)
 proof -
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T]
 
   have 0:
       "set (transaction_fresh T) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       "set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {}"
       "set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = {}"
       "fv_transaction T \<inter> bvars_transaction T = {}"
     using admissible_transactionE[OF T] by argo+
 
   have 1: "set (transaction_fresh T) \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = {}"
     using 0(1,4) fv_transaction_unfold[of T] bvars_transaction_unfold[of T] by blast
 
   have 2:
       "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
       "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {}"
     using bvars_wellformed_transaction_unfold[OF T_wf]
           vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_receive T)"]
     by blast+
   
   show ?A ?B ?C ?E ?F using 0 1 2 x by (fast, fast, fast, fast, fast)
 
   show ?D using 0(3) 1 x vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_checks T)"] by fast
 qed
 
 lemma admissible_transaction_fv_in_receives_or_selects:
   assumes T: "admissible_transaction' T"
     and x: "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
   shows "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<or>
          (x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
           (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> x \<in> fv t \<union> fv s))"
 proof -
   have "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<union>
             fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
     using x(1) fv\<^sub>s\<^sub>s\<^sub>t_append unlabel_append 
     by (metis transaction_strand_def append_assoc)
   thus ?thesis using x(2) admissible_transactionE(9,10)[OF T] by blast
 qed
 
 lemma admissible_transaction_fv_in_receives_or_selects':
   assumes T: "admissible_transaction' T"
     and x: "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
   shows "(\<exists>ts. receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T)) \<and> x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts)) \<or>
          (\<exists>s. select\<langle>Var x, s\<rangle> \<in> set (unlabel (transaction_checks T)))"
 proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)")
   case True thus ?thesis
     using wellformed_transaction_unlabel_cases(1)[
             OF admissible_transaction_is_wellformed_transaction(1)[OF T]]
     by force
 next
   case False
   then obtain t s where t: "select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T))" "x \<in> fv t \<union> fv s"
     using admissible_transaction_fv_in_receives_or_selects[OF T x] by blast
 
   have t': "select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_strand T))"
     using t(1) unfolding transaction_strand_def by simp
 
   show ?thesis
     using t transaction_selects_are_Value_vars[
               OF admissible_transaction_is_wellformed_transaction(1,2)[OF T] t']
     by force
 qed
 
 lemma admissible_transaction_fv_in_receives_or_selects_subst:
   assumes T: "admissible_transaction' T"
     and x: "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
   shows "(\<exists>ts. receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<and> \<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts) \<or>
          (\<exists>s. select\<langle>\<theta> x, s\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
 proof -
   note 0 = admissible_transaction_fv_in_receives_or_selects'[OF T x]
 
   have 1: "\<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set (ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)" when ts: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts)" for ts
     using that subst_mono_fv[of x _ \<theta>] by auto
 
   have 2: "receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle> \<in> set (A \<cdot>\<^sub>s\<^sub>s\<^sub>t \<theta>)" when "receive\<langle>ts\<rangle> \<in> set A" for ts A
     using that by fast
 
   have 3: "select\<langle>t \<cdot> \<theta>,s \<cdot> \<theta>\<rangle> \<in> set (A \<cdot>\<^sub>s\<^sub>s\<^sub>t \<theta>)" when "select\<langle>t,s\<rangle> \<in> set A" for t s A
     using that by fast
 
   show ?thesis
     using 0 1 2[of _ "unlabel (transaction_receive T)"]
           3[of _ _ "unlabel (transaction_checks T)"]
     unfolding unlabel_subst by (metis eval_term.simps(1)) 
 qed
 
 lemma admissible_transaction_fv_in_receives_or_selects_dual_subst:
   defines "f \<equiv> \<lambda>S. unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S)"
   assumes T: "admissible_transaction' T"
     and x: "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
   shows "(\<exists>ts. send\<langle>ts\<rangle> \<in> set (f (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<and> \<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts) \<or>
          (\<exists>s. select\<langle>\<theta> x, s\<rangle> \<in> set (f (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
 using admissible_transaction_fv_in_receives_or_selects_subst[OF T x, of \<theta>]
 by (metis (no_types, lifting) f_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(6)) 
 
 lemma admissible_transaction_decl_subst_empty':
   assumes T: "transaction_decl T () = []"
     and \<xi>: "transaction_decl_subst \<xi> T"
   shows "\<xi> = Var"
 proof -
   have "subst_domain \<xi> = {}"
     using \<xi> T unfolding transaction_decl_subst_def by auto
   thus ?thesis by auto
 qed
 
 lemma admissible_transaction_decl_subst_empty:
   assumes T: "admissible_transaction' T"
     and \<xi>: "transaction_decl_subst \<xi> T"
   shows "\<xi> = Var"
 by (rule admissible_transaction_decl_subst_empty'[OF admissible_transactionE(1)[OF T] \<xi>])
 
 lemma admissible_transaction_no_bvars:
   assumes "admissible_transaction' T"
   shows "fv_transaction T = vars_transaction T"
     and "bvars_transaction T = {}"
 using admissible_transactionE(4)[OF assms]
       bvars_wellformed_transaction_unfold vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t
 by (fast, fast)
 
 lemma admissible_transactions_fv_bvars_disj:
   assumes "\<forall>T \<in> set P. admissible_transaction' T"
   shows "(\<Union>T \<in> set P. fv_transaction T) \<inter> (\<Union>T \<in> set P. bvars_transaction T) = {}"
 using assms admissible_transaction_no_bvars(2) by fast
 
 lemma admissible_transaction_occurs_fv_types:
   assumes "admissible_transaction' T"
     and "x \<in> vars_transaction T"
   shows "\<exists>a. \<Gamma> (Var x) = TAtom a \<and> \<Gamma> (Var x) \<noteq> TAtom OccursSecType"
 proof -
   have "is_Var (fst x)" "the_Var (fst x) = Value"
     using assms unfolding admissible_transaction'_def by blast+
   thus ?thesis using \<Gamma>\<^sub>v_TAtom''(2)[of x] by force
 qed
 
 lemma admissible_transaction_Value_vars_are_fv:
   assumes "admissible_transaction' T"
     and "x \<in> vars_transaction T"
     and "\<Gamma>\<^sub>v x = TAtom Value"
   shows "x \<in> fv_transaction T"
 using assms(2,3) \<Gamma>\<^sub>v_TAtom''(2)[of x] vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
       admissible_transactionE(4)[OF assms(1)]
 by fast
 
 lemma transaction_receive_deduct:
   assumes T_wf: "wellformed_transaction T"
     and \<I>: "constraint_model \<I> (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
     and t: "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
   shows "\<forall>t \<in> set ts. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<I>"
 proof -
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   have t': "send\<langle>ts\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
     using t dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2) unfolding \<theta>_def by blast
   then obtain T1 T2 where T: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) = T1@send\<langle>ts\<rangle>#T2"
     using t' by (meson split_list)
 
   have "constr_sem_stateful \<I> (unlabel A@unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
     using \<I> unlabel_append[of A] unfolding constraint_model_def \<theta>_def by simp
   hence "constr_sem_stateful \<I> (unlabel A@T1@[send\<langle>ts\<rangle>])"
     using strand_sem_append_stateful[of "{}" "{}" "unlabel A@T1@[send\<langle>ts\<rangle>]" _ \<I>]
           transaction_dual_subst_unlabel_unfold[of T \<theta>] T
     by (metis append.assoc append_Cons append_Nil)
   hence "\<forall>t \<in> set ts. ik\<^sub>s\<^sub>s\<^sub>t (unlabel A@T1) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<I>"
     using strand_sem_append_stateful[of "{}" "{}" "unlabel A@T1" "[send\<langle>ts\<rangle>]" \<I>] T
     by force
   moreover have "\<not>is_Receive x"
     when x: "x \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))" for x
   proof -
     have *: "is_Receive a" when "a \<in> set (unlabel (transaction_receive T))" for a
       using T_wf Ball_set[of "unlabel (transaction_receive T)" is_Receive] that
       unfolding wellformed_transaction_def
       by blast
 
     obtain l where l: "(l,x) \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using x unfolding unlabel_def by fastforce
     then obtain ly where ly: "ly \<in> set (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" "(l,x) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p ly"
       unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto
 
     obtain j y where j: "ly = (j,y)" by (metis surj_pair)
     hence "j = l" using ly(2) by (cases y) auto
     hence y: "(l,y) \<in> set (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" "(l,x) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p (l,y)"
       by (metis j ly(1), metis j ly(2))
 
     obtain z where z:
         "z \<in> set (unlabel (transaction_receive T))"
         "(l,z) \<in> set (transaction_receive T)"
         "(l,y) = (l,z) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>"
       using y(1) unfolding subst_apply_labeled_stateful_strand_def unlabel_def by force
 
     have "is_Receive y" using *[OF z(1)] z(3) by (cases z) auto
     thus "\<not>is_Receive x" using l y by (cases y) auto
   qed
   hence "\<not>is_Receive x" when "x \<in> set T1" for x using T that by simp
   hence "ik\<^sub>s\<^sub>s\<^sub>t T1 = {}" unfolding ik\<^sub>s\<^sub>s\<^sub>t_def is_Receive_def by fast
   hence "ik\<^sub>s\<^sub>s\<^sub>t (unlabel A@T1) = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" using ik\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A" T1] by simp
   ultimately show ?thesis by (simp add: \<theta>_def)
 qed
 
 lemma transaction_checks_db:
   assumes T: "admissible_transaction' T"
     and \<I>: "constraint_model \<I> (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
   shows "\<langle>Var (TAtom Value, n) in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
           \<Longrightarrow> (\<alpha> (TAtom Value, n) \<cdot> \<I>, Fun (Set s) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<I>)"
       (is "?A \<Longrightarrow> ?B")
     and "\<langle>Var (TAtom Value, n) not in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
           \<Longrightarrow> (\<alpha> (TAtom Value, n) \<cdot> \<I>, Fun (Set s) []) \<notin> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<I>)"
       (is "?C \<Longrightarrow> ?D")
 proof -
   let ?x = "\<lambda>n. (TAtom Value, n)"
   let ?s = "Fun (Set s) []"
   let ?T = "transaction_receive T@transaction_checks T"
   let ?T' = "?T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   let ?S = "\<lambda>S. transaction_receive T@S"
   let ?S' = "\<lambda>S. ?S S \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T \<xi>]
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T]
 
   have "constr_sem_stateful \<I> (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
     using \<I> unfolding constraint_model_def by simp
   moreover have
       "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
        dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S (T1@[c]) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)@
        dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T2@transaction_updates T@transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)"
     when "transaction_checks T = T1@c#T2" for T1 T2 c \<delta>
     using that dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append subst_lsst_append
     unfolding transaction_strand_def
     by (metis append.assoc append_Cons append_Nil)
   ultimately have T'_model: "constr_sem_stateful \<I> (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' (T1@[(l,c)]))))"
     when "transaction_checks T = T1@(l,c)#T2" for T1 T2 l c
     using strand_sem_append_stateful[of _ _ _ _ \<I>]
     by (simp add: that transaction_strand_def)
 
   show "?A \<Longrightarrow> ?B"
   proof -
     assume a: ?A
     hence *: "\<langle>Var (?x n) in ?s\<rangle> \<in> set (unlabel ?T)"
       unfolding transaction_strand_def unlabel_def by simp
     then obtain l T1 T2 where T1: "transaction_checks T = T1@(l,\<langle>Var (?x n) in ?s\<rangle>)#T2"
       by (metis a split_list unlabel_mem_has_label)
 
     have "?x n \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
       using a by force
     hence "?x n \<notin> set (transaction_fresh T)"
       using a admissible_transaction_fresh_vars_notin[OF T] by fast
     hence "unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' (T1@[(l,\<langle>Var (?x n) in ?s\<rangle>)]))) =
            unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' T1))@[\<langle>\<alpha> (?x n) in ?s\<rangle>]"
       using T a \<sigma> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append subst_lsst_append unlabel_append \<xi>_empty
       by (fastforce simp add: transaction_fresh_subst_def unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def
                               subst_apply_labeled_stateful_strand_def subst_compose)
     moreover have "db\<^sub>s\<^sub>s\<^sub>t (unlabel A) = db\<^sub>s\<^sub>s\<^sub>t (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' T1)))"
       by (simp add: T1 db\<^sub>s\<^sub>s\<^sub>t_transaction_prefix_eq[OF T_wf] del: unlabel_append)
     ultimately have "\<exists>M. strand_sem_stateful M (set (db\<^sub>s\<^sub>s\<^sub>t (unlabel A) \<I>)) [\<langle>\<alpha> (?x n) in ?s\<rangle>] \<I>"
       using T'_model[OF T1] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of _ \<I>] strand_sem_append_stateful[of _ _ _ _ \<I>]
       by (simp add: db\<^sub>s\<^sub>s\<^sub>t_def del: unlabel_append)
     thus ?B by simp
   qed
 
   show "?C \<Longrightarrow> ?D"
   proof -
     assume a: ?C
     hence *: "\<langle>Var (?x n) not in ?s\<rangle> \<in> set (unlabel ?T)"
       unfolding transaction_strand_def unlabel_def by simp
     then obtain l T1 T2 where T1: "transaction_checks T = T1@(l,\<langle>Var (?x n) not in ?s\<rangle>)#T2"
       by (metis a split_list unlabel_mem_has_label)
 
     have "?x n \<in> vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<langle>Var (?x n) not in ?s\<rangle>"
       using vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_cases(9)[of "[]" "Var (?x n)" ?s] by auto
     hence "?x n \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
       using a unfolding vars\<^sub>s\<^sub>s\<^sub>t_def by force
     hence "?x n \<notin> set (transaction_fresh T)"
       using a admissible_transaction_fresh_vars_notin[OF T] by fast
     hence "unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' (T1@[(l,\<langle>Var (?x n) not in ?s\<rangle>)]))) =
            unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' T1))@[\<langle>\<alpha> (?x n) not in ?s\<rangle>]"
       using T a \<sigma> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append subst_lsst_append unlabel_append \<xi>_empty
       by (fastforce simp add: transaction_fresh_subst_def unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def
                               subst_apply_labeled_stateful_strand_def subst_compose)
     moreover have "db\<^sub>s\<^sub>s\<^sub>t (unlabel A) = db\<^sub>s\<^sub>s\<^sub>t (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' T1)))"
       by (simp add: T1 db\<^sub>s\<^sub>s\<^sub>t_transaction_prefix_eq[OF T_wf] del: unlabel_append)
     ultimately have "\<exists>M. strand_sem_stateful M (set (db\<^sub>s\<^sub>s\<^sub>t (unlabel A) \<I>)) [\<langle>\<alpha> (?x n) not in ?s\<rangle>] \<I>"
       using T'_model[OF T1] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of _ \<I>] strand_sem_append_stateful[of _ _ _ _ \<I>]
       by (simp add: db\<^sub>s\<^sub>s\<^sub>t_def del: unlabel_append)
     thus ?D using stateful_strand_sem_NegChecks_no_bvars(1)[of _ _ _ ?s \<I>] by simp
   qed
 qed
 
 lemma transaction_selects_db:
   assumes T: "admissible_transaction' T"
     and \<I>: "constraint_model \<I> (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
   shows "select\<langle>Var (TAtom Value, n), Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
           \<Longrightarrow> (\<alpha> (TAtom Value, n) \<cdot> \<I>, Fun (Set s) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<I>)"
       (is "?A \<Longrightarrow> ?B")
 proof -
   let ?x = "\<lambda>n. (TAtom Value, n)"
   let ?s = "Fun (Set s) []"
   let ?T = "transaction_receive T@transaction_checks T"
   let ?T' = "?T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   let ?S = "\<lambda>S. transaction_receive T@S"
   let ?S' = "\<lambda>S. ?S S \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T \<xi>]
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T]
 
   have "constr_sem_stateful \<I> (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
     using \<I> unfolding constraint_model_def by simp
   moreover have
       "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
        dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S (T1@[c]) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)@
        dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T2@transaction_updates T@transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)"
     when "transaction_checks T = T1@c#T2" for T1 T2 c \<delta>
     using that dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append subst_lsst_append
     unfolding transaction_strand_def by (metis append.assoc append_Cons append_Nil)
   ultimately have T'_model: "constr_sem_stateful \<I> (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' (T1@[(l,c)]))))"
     when "transaction_checks T = T1@(l,c)#T2" for T1 T2 l c
     using strand_sem_append_stateful[of _ _ _ _ \<I>]
     by (simp add: that transaction_strand_def)
 
   show "?A \<Longrightarrow> ?B"
   proof -
     assume a: ?A
     hence *: "select\<langle>Var (?x n), ?s\<rangle> \<in> set (unlabel ?T)"
       unfolding transaction_strand_def unlabel_def by simp
     then obtain l T1 T2 where T1: "transaction_checks T = T1@(l,select\<langle>Var (?x n), ?s\<rangle>)#T2"
       by (metis a split_list unlabel_mem_has_label)
 
     have "?x n \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
       using a by force
     hence "?x n \<notin> set (transaction_fresh T)"
       using a admissible_transaction_fresh_vars_notin[OF T] by fast
     hence "unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' (T1@[(l,select\<langle>Var (?x n), ?s\<rangle>)]))) =
            unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' T1))@[select\<langle>\<alpha> (?x n), ?s\<rangle>]"
       using T a \<sigma> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append subst_lsst_append unlabel_append \<xi>_empty
       by (fastforce simp add: transaction_fresh_subst_def unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def
                               subst_apply_labeled_stateful_strand_def subst_compose)
     moreover have "db\<^sub>s\<^sub>s\<^sub>t (unlabel A) = db\<^sub>s\<^sub>s\<^sub>t (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?S' T1)))"
       by (simp add: T1 db\<^sub>s\<^sub>s\<^sub>t_transaction_prefix_eq[OF T_wf] del: unlabel_append)
     ultimately have "\<exists>M. strand_sem_stateful M (set (db\<^sub>s\<^sub>s\<^sub>t (unlabel A) \<I>)) [\<langle>\<alpha> (?x n) in ?s\<rangle>] \<I>"
       using T'_model[OF T1] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of _ \<I>] strand_sem_append_stateful[of _ _ _ _ \<I>]
       by (simp add: db\<^sub>s\<^sub>s\<^sub>t_def del: unlabel_append)
     thus ?B by simp
   qed
 qed
 
 lemma admissible_transaction_terms_no_Value_consts:
   assumes "admissible_transaction_terms T"
     and "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"
   shows "\<nexists>a T. t = Fun (Val a) T" (is ?A)
     and "\<nexists>a T. t = Fun (Abs a) T" (is ?B)
     and "\<nexists>a T. t = Fun (PubConst Value a) T" (is ?C)
 proof -
   have "\<not>is_Val f" "\<not>is_Abs f" "\<not>is_PubConstValue f"
     when "f \<in> \<Union>(funs_term ` (trms_transaction T))" for f
     using that assms(1)[unfolded admissible_transaction_terms_def]
     unfolding is_PubConstValue_def by (blast,blast,blast)
   moreover have "f \<in> \<Union>(funs_term ` (trms_transaction T))"
     when "f \<in> funs_term t" for f
     using that assms(2) funs_term_subterms_eq(2)[of "trms_transaction T"] by blast+
   ultimately have *: "\<not>is_Val f" "\<not>is_Abs f" "\<not>is_PubConstValue f"
     when "f \<in> funs_term t" for f
     using that by presburger+
 
   show ?A using *(1) by force
   show ?B using *(2) by force
   show ?C using *(3) unfolding is_PubConstValue_def by force
 qed
 
 lemma admissible_transactions_no_Value_consts:
   assumes "admissible_transaction' T"
     and "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"
   shows "\<nexists>a T. t = Fun (Val a) T" (is ?A)
     and "\<nexists>a T. t = Fun (Abs a) T" (is ?B)
     and "\<nexists>a T. t = Fun (PubConst Value a) T" (is ?C)
 using admissible_transaction_terms_no_Value_consts[OF
         admissible_transaction_is_wellformed_transaction(4)[OF assms(1)] assms(2)]
 by auto
 
 lemma admissible_transactions_no_Value_consts':
   assumes "admissible_transaction' T"
     and "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)"
   shows "\<nexists>a T. Fun (Val a) T \<in> subterms t"
     and "\<nexists>a T. Fun (Abs a) T \<in> subterms t"
 using admissible_transactions_no_Value_consts[OF assms(1)] assms(2) by fast+
 
 lemma admissible_transactions_no_Value_consts'':
   assumes "admissible_transaction' T"
   shows "\<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` trms_transaction T)"
     and "\<forall>n. Abs n \<notin> \<Union>(funs_term ` trms_transaction T)"
 using assms
 unfolding admissible_transaction'_def admissible_transaction_terms_def
 by (meson prot_fun.discI(6), meson prot_fun.discI(4))
 
 lemma admissible_transactions_no_PubConsts:
   assumes "admissible_transaction' T"
     and "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"
   shows "\<nexists>a n T. t = Fun (PubConst a n) T"
 proof -
   have "\<not>is_PubConst f"
     when "f \<in> \<Union>(funs_term ` (trms_transaction T))" for f
     using that conjunct1[OF conjunct2[OF admissible_transaction_is_wellformed_transaction(4)[
             OF assms(1), unfolded admissible_transaction_terms_def]]]
     by blast
   moreover have "f \<in> \<Union>(funs_term ` (trms_transaction T))"
     when "f \<in> funs_term t" for f
     using that assms(2) funs_term_subterms_eq(2)[of "trms_transaction T"] by blast+
   ultimately have *: "\<not>is_PubConst f"
     when "f \<in> funs_term t" for f
     using that by presburger+
 
   show ?thesis using * by force
 qed
 
 lemma admissible_transactions_no_PubConsts':
   assumes "admissible_transaction' T"
     and "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)"
   shows "\<nexists>a n T. Fun (PubConst a n) T \<in> subterms t"
 using admissible_transactions_no_PubConsts[OF assms(1)] assms(2) by fast+
 
 lemma admissible_transaction_strand_step_cases:
   assumes T_adm: "admissible_transaction' T"
   shows "r \<in> set (unlabel (transaction_receive T)) \<Longrightarrow> \<exists>t. r = receive\<langle>t\<rangle>"
         (is "?A \<Longrightarrow> ?A'")
     and "r \<in> set (unlabel (transaction_checks T)) \<Longrightarrow>
             (\<exists>x s. (r = \<langle>Var x in Fun (Set s) []\<rangle> \<or> r = select\<langle>Var x, Fun (Set s) []\<rangle> \<or>
                    r = \<langle>Var x not in Fun (Set s) []\<rangle>) \<and>
                    fst x = TAtom Value \<and> x \<in> fv_transaction T - set (transaction_fresh T)) \<or>
             (\<exists>s t. r = \<langle>s == t\<rangle> \<or> r = \<langle>s := t\<rangle> \<or> r = \<langle>s != t\<rangle>)"
         (is "?B \<Longrightarrow> ?B'")
     and "r \<in> set (unlabel (transaction_updates T)) \<Longrightarrow>
             \<exists>x s. (r = insert\<langle>Var x, Fun (Set s) []\<rangle> \<or> r = delete\<langle>Var x, Fun (Set s) []\<rangle>) \<and>
                   fst x = TAtom Value"
         (is "?C \<Longrightarrow> ?C'")
     and "r \<in> set (unlabel (transaction_send T)) \<Longrightarrow> \<exists>t. r = send\<langle>t\<rangle>"
         (is "?D \<Longrightarrow> ?D'")
 proof -
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   show "?A \<Longrightarrow> ?A'"
     using T_wf Ball_set[of "unlabel (transaction_receive T)" is_Receive]
     unfolding wellformed_transaction_def is_Receive_def
     by blast
 
   show "?D \<Longrightarrow> ?D'"
     using T_wf Ball_set[of "unlabel (transaction_send T)" is_Send]
     unfolding wellformed_transaction_def is_Send_def
     by blast
 
   show "?B \<Longrightarrow> ?B'"
   proof -
     assume r: ?B
     note adm_checks = admissible_transaction_is_wellformed_transaction(1,2)[OF T_adm]
 
     have fv_r1: "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p r \<subseteq> fv_transaction T"
       using r fv_transaction_unfold[of T] by auto
   
     have fv_r2: "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p r \<inter> set (transaction_fresh T) = {}"
       using r T_wf unfolding wellformed_transaction_def by fastforce
 
     have "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
       using adm_checks(1) unfolding wellformed_transaction_def by blast
     hence "is_InSet r \<or> is_Equality r \<or> is_NegChecks r"
       using r unfolding list_all_iff by blast
     thus ?B'
     proof (elim disjE conjE)
       assume *: "is_InSet r"
       hence **: "is_Var (the_elem_term r)" "is_Fun (the_set_term r)"
                 "is_Set (the_Fun (the_set_term r))" "args (the_set_term r) = []"
                 "fst (the_Var (the_elem_term r)) = TAtom Value"
         using r adm_checks unfolding admissible_transaction_checks_def is_Fun_Set_def
         by fast+
       
       obtain ac rt rs where r': "r = \<langle>ac: rt \<in> rs\<rangle>" using * by (cases r) auto
       obtain x where x: "rt = Var x" "fst x = TAtom Value" using **(1,5) r' by auto
       obtain f S where fS: "rs = Fun f S" using **(2) r' by auto
       obtain s where s: "f = Set s" using **(3) fS r' by (cases f) auto
       hence S: "S = []" using **(4) fS r' by auto
   
       show ?B' using r' x fS s S fv_r1 fv_r2 by (cases ac) simp_all
     next
       assume *: "is_NegChecks r"
       hence **: "bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p r = []"
                 "(the_eqs r = [] \<and> length (the_ins r) = 1) \<or>
                  (the_ins r = [] \<and> length (the_eqs r) = 1)"
         using r adm_checks unfolding admissible_transaction_checks_def by fast+
       show ?B' using **(2)
       proof (elim disjE conjE)
         assume ***: "the_eqs r = []" "length (the_ins r) = 1"
         then obtain t s where ts: "the_ins r = [(t,s)]" by (cases "the_ins r") auto
         hence "hd (the_ins r) = (t,s)" by simp
         hence ****: "is_Var (fst (t,s))" "is_Fun (snd (t,s))"
                     "is_Set (the_Fun (snd (t,s)))" "args (snd (t,s)) = []"
                     "fst (the_Var (fst (t,s))) = TAtom Value"
           using * ***(1) Set.bspec[OF adm_checks(2)[unfolded admissible_transaction_checks_def] r]
           unfolding is_Fun_Set_def by simp_all
         obtain x where x: "t = Var x" "fst x = TAtom Value" using ts ****(1,5) by (cases t) simp_all
         obtain f S where fS: "s = Fun f S" using ts ****(2) by (cases s) simp_all
         obtain ss where ss: "f = Set ss" using fS ****(3) by (cases f) simp_all
         have S: "S = []" using ts fS ss ****(4) by simp
         
         show ?B' using ts x fS ss S *** **(1) * fv_r1 fv_r2 by (cases r) auto
       next
         assume ***: "the_ins r = []" "length (the_eqs r) = 1"
         then obtain t s where "the_eqs r = [(t,s)]" by (cases "the_eqs r") auto
         thus ?B' using *** **(1) * by (cases r) auto
       qed
     qed (auto simp add: is_Equality_def the_check_def intro: poscheckvariant.exhaust)
   qed
 
   show "?C \<Longrightarrow> ?C'"
   proof -
     assume r: ?C
     note adm_upds = admissible_transaction_is_wellformed_transaction(3)[OF T_adm]
 
     have *: "is_Update r" "is_Var (the_elem_term r)" "is_Fun (the_set_term r)"
             "is_Set (the_Fun (the_set_term r))" "args (the_set_term r) = []"
             "fst (the_Var (the_elem_term r)) = TAtom Value"
       using r adm_upds unfolding admissible_transaction_updates_def is_Fun_Set_def by fast+
 
     obtain t s where ts: "r = insert\<langle>t,s\<rangle> \<or> r = delete\<langle>t,s\<rangle>" using *(1) by (cases r) auto
     obtain x where x: "t = Var x" "fst x = TAtom Value" using ts *(2,6) by (cases t) auto
     obtain f T where fT: "s = Fun f T" using ts *(3) by (cases s) auto
     obtain ss where ss: "f = Set ss" using ts fT *(4) by (cases f) fastforce+
     have T: "T = []" using ts fT *(5) ss by (cases T) auto
 
     show ?C'
       using ts x fT ss T by blast
   qed
 qed
 
 lemma protocol_transaction_vars_TAtom_typed:
   assumes T_adm: "admissible_transaction' T"
   shows "\<forall>x \<in> vars_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     and "\<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     and "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
 proof -
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   show "\<forall>x \<in> vars_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     using admissible_transactionE(3)[OF T_adm] by fast
   thus "\<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     using vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t by fast
 
   show "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     using admissible_transactionE(2)[OF T_adm] by argo
 qed
 
 lemma protocol_transactions_no_pubconsts:
   assumes "admissible_transaction' T"
   shows "Fun (Val n) S \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)"
     and "Fun (PubConst Value n) S \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)"
 using assms admissible_transactions_no_Value_consts(1,3) by (blast, blast)
 
 lemma protocol_transactions_no_abss:
   assumes "admissible_transaction' T"
   shows "Fun (Abs n) S \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)"
 using assms admissible_transactions_no_Value_consts(2)
 by fast
 
 lemma admissible_transaction_strand_sem_fv_ineq:
   assumes T_adm: "admissible_transaction' T"
     and \<I>: "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<I>"
     and x: "x \<in> fv_transaction T - set (transaction_fresh T)"
     and y: "y \<in> fv_transaction T - set (transaction_fresh T)"
     and x_not_y: "x \<noteq> y"
   shows "\<theta> x \<cdot> \<I> \<noteq> \<theta> y \<cdot> \<I>"
 proof -
   have "\<langle>Var x != Var y\<rangle> \<in> set (unlabel (transaction_checks T)) \<or>
         \<langle>Var y != Var x\<rangle> \<in> set (unlabel (transaction_checks T))"
     using x y x_not_y admissible_transactionE(8)[OF T_adm] by auto
   hence "\<langle>Var x != Var y\<rangle> \<in> set (unlabel (transaction_strand T)) \<or>
          \<langle>Var y != Var x\<rangle> \<in> set (unlabel (transaction_strand T))"
     unfolding transaction_strand_def unlabel_def by auto
   hence "\<langle>\<theta> x != \<theta> y\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<or>
          \<langle>\<theta> y != \<theta> x\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
     using stateful_strand_step_subst_inI(8)[of _ _ "unlabel (transaction_strand T)" \<theta>]
           subst_lsst_unlabel[of "transaction_strand T" \<theta>]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(7)[of "[]" _ "[]"]
     by force
   then obtain B where B:
       "prefix (B@[\<langle>\<theta> x != \<theta> y\<rangle>]) (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) \<or>
        prefix (B@[\<langle>\<theta> y != \<theta> x\<rangle>]) (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
     unfolding prefix_def
     by (metis (no_types, opaque_lifting) append.assoc append_Cons append_Nil split_list)
   thus ?thesis
     using \<I> strand_sem_append_stateful[of IK DB _ _ \<I>]
           stateful_strand_sem_NegChecks_no_bvars(2)
     unfolding prefix_def
     by metis 
 qed
 
 lemma admissible_transaction_sem_iff:
   fixes \<theta> and T::"('fun,'atom,'sets,'lbl) prot_transaction"
   defines "A \<equiv> unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   assumes T: "admissible_transaction' T"
     and I: " interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
   shows "strand_sem_stateful M D A I \<longleftrightarrow> (
     (\<forall>l ts. (l,receive\<langle>ts\<rangle>) \<in> set (transaction_receive T) \<longrightarrow> (\<forall>t \<in> set ts. M \<turnstile> t \<cdot> \<theta> \<cdot> I)) \<and>
     (\<forall>l ac t s. (l,\<langle>ac: t \<doteq> s\<rangle>) \<in> set (transaction_checks T) \<longrightarrow> t \<cdot> \<theta> \<cdot> I = s \<cdot> \<theta> \<cdot> I) \<and>
     (\<forall>l ac t s. (l,\<langle>ac: t \<in> s\<rangle>) \<in> set (transaction_checks T) \<longrightarrow> (t \<cdot> \<theta> \<cdot> I, s \<cdot> \<theta> \<cdot> I) \<in> D) \<and>
     (\<forall>l t s. (l,\<langle>t != s\<rangle>) \<in> set (transaction_checks T) \<longrightarrow> t \<cdot> \<theta> \<cdot> I \<noteq> s \<cdot> \<theta> \<cdot> I) \<and>
     (\<forall>l t s. (l,\<langle>t not in s\<rangle>) \<in> set (transaction_checks T) \<longrightarrow> (t \<cdot> \<theta> \<cdot> I, s \<cdot> \<theta> \<cdot> I) \<notin> D))"
     (is "?A \<longleftrightarrow> ?B")
 proof -
   define P where "P \<equiv>
     \<lambda>X. \<lambda>\<delta>::('fun,'atom,'sets,'lbl) prot_subst. subst_domain \<delta> = set X \<and> ground (subst_range \<delta>)"
   define rm where "rm \<equiv> \<lambda>X. \<lambda>\<delta>::('fun,'atom,'sets,'lbl) prot_subst. rm_vars (set X) \<delta>"
   define chks where "chks \<equiv> transaction_checks T"
   define q1 where "q1 \<equiv> \<lambda>t X \<delta>. t \<cdot> rm X \<theta> \<cdot> \<delta> \<cdot> I"
   define q2 where "q2 \<equiv> \<lambda>t. t \<cdot> \<theta> \<cdot> I"
 
   note 0 = admissible_transaction_is_wellformed_transaction[OF T]
   note 1 = wellformed_transaction_sem_iff[OF 0(1) I, of M D \<theta>, unfolded A_def[symmetric]]
   note 2 = admissible_transactionE[OF T]
 
   have 3: "rm X \<theta> = \<theta>" when "X = []" for X using that unfolding rm_def by auto
 
   have 4: "P X \<delta> \<longleftrightarrow> \<delta> = Var" when "X = []" for X and \<delta>
     using that unfolding P_def by auto
 
   have 5: "\<exists>t s. \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> = \<langle>t != s\<rangle> \<or> \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> = \<langle>t not in s\<rangle>"
     when X: "(l, \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>) \<in> set chks" for l X F G
   proof -
     have *: "\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle> \<in> set (unlabel (transaction_strand T))"
       using X transaction_strand_subsets(2)[of T] unlabel_in unfolding chks_def by fast
     hence **: "X = []" using 2(4) by auto
 
     note *** = transaction_notinset_checks_are_Value_vars(3,4)[OF T *]
                transaction_noteqs_checks_case[OF T *]
 
     show ?thesis
     proof (cases "G = []")
       case True thus ?thesis using ** ***(3) by blast
     next
       case False
       then obtain t s where g: "(t,s) \<in> set G" by (cases G) auto
       show ?thesis using ** ***(1,2)[OF g] by blast
     qed
   qed
 
   have 6: "q1 t X \<delta> = q2 t" when "P X \<delta>" "X = []" for X \<delta> t
     using that 3 4 unfolding q1_def q2_def by simp
 
   let ?negcheck_sem = "\<lambda>X F G. \<forall>\<delta>. P X \<delta> \<longrightarrow>
                                 (\<exists>(t,s) \<in> set F. q1 t X \<delta> \<noteq> q1 s X \<delta>) \<or>
                                 (\<exists>(t,s) \<in> set G. (q1 t X \<delta>, q1 s X \<delta>) \<notin> D)"
 
   have "(\<forall>l X F G. (l,\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>) \<in> set chks \<longrightarrow> ?negcheck_sem X F G) \<longleftrightarrow>
         ((\<forall>l t s. (l,\<langle>t != s\<rangle>) \<in> set chks \<longrightarrow> q2 t \<noteq> q2 s) \<and>
          (\<forall>l t s. (l,\<langle>t not in s\<rangle>) \<in> set chks \<longrightarrow> (q2 t, q2 s) \<notin> D))"
     (is "?A \<longleftrightarrow> ?B")
   proof
     have "q2 t \<noteq> q2 s" when t: "(l,\<langle>t != s\<rangle>) \<in> set chks" ?A for l t s
     proof -
       have "?negcheck_sem [] [(t,s)] []" using t by blast
       thus ?thesis using 4[of "[]"] 6[of "[]"] by force
     qed
     moreover have "(q2 t, q2 s) \<notin> D" when t: "(l,\<langle>t not in s\<rangle>) \<in> set chks" ?A for l t s
     proof -
       have "?negcheck_sem [] [] [(t,s)]" using t by blast
       thus ?thesis using 4[of "[]"] 6[of "[]"] by force
     qed 
     ultimately show "?A \<Longrightarrow> ?B" by blast
 
     have "?negcheck_sem X F G"
       when t: "(l,\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>) \<in> set chks" ?B for l X F G
     proof -
       obtain t s where ts: "(X = [] \<and> F = [(t,s)] \<and> G = []) \<or> (X = [] \<and> F = [] \<and> G = [(t,s)])"
         using 5[OF t(1)] by blast
       hence "(X = [] \<and> F = [(t,s)] \<and> G = [] \<and> q2 t \<noteq> q2 s) \<or>
              (X = [] \<and> F = [] \<and> G = [(t,s)] \<and> (q2 t, q2 s) \<notin> D)" using t by blast
       thus ?thesis using 4[of "[]"] 6[of "[]"] by fastforce
     qed
     thus "?B \<Longrightarrow> ?A" by simp
   qed
   thus ?thesis using 1 unfolding rm_def chks_def P_def q1_def q2_def by simp
 qed
 
 lemma admissible_transaction_terms_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s:
   assumes "admissible_transaction_terms T"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms_transaction T)"
 by (rule conjunct1[OF assms[unfolded admissible_transaction_terms_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric]]])
 
 lemma admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s:
   assumes "admissible_transaction' T"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms_transaction T)" 
 proof -
   have "admissible_transaction_terms T" using assms[unfolded admissible_transaction'_def] by fast
   thus ?thesis by (metis admissible_transaction_terms_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s)
 qed
 
 lemma admissible_transaction_no_Ana_Attack:
   assumes "admissible_transaction_terms T"
     and "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)"
   shows "attack\<langle>n\<rangle> \<notin> set (snd (Ana t))"
 proof -
   obtain r where r: "r \<in> set (unlabel (transaction_strand T))" "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r)"
     using assms(2) by force
 
   obtain K M where t: "Ana t = (K, M)"
     by (metis surj_pair)
 
   show ?thesis
   proof
     assume n: "attack\<langle>n\<rangle> \<in> set (snd (Ana t))"
     hence "attack\<langle>n\<rangle> \<in> set M" using t by simp
     hence n': "attack\<langle>n\<rangle> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r)"
       using Ana_subterm[OF t] r(2) subterms_subset by fast
     hence "\<exists>f \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r). is_Attack f"
       using funs_term_Fun_subterm' unfolding is_Attack_def by fast
     hence "is_Send r" "length (the_msgs r) = 1" "is_Fun (hd (the_msgs r))"
           "is_Attack (the_Fun (hd (the_msgs r)))" "args (hd (the_msgs r)) = []"
       using assms(1) r(1) unfolding admissible_transaction_terms_def is_Fun_Attack_def by metis+
     hence "t = attack\<langle>n\<rangle>"
       using n' r(2) unfolding is_Send_def is_Attack_def by (cases "the_msgs r") auto
     thus False using n by fastforce
   qed
 qed
 
 lemma admissible_transaction_Value_vars:
   assumes T: "admissible_transaction' T"
     and x: "x \<in> fv_transaction T"
   shows "\<Gamma>\<^sub>v x = TAtom Value"
 proof -
   have "x \<in> vars_transaction T"
     using x vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
     by blast
   thus "\<Gamma>\<^sub>v x = TAtom Value"
     using admissible_transactionE(3)[OF T] by simp
 qed
 
 lemma admissible_transaction_occurs_checksE1:
   assumes T: "admissible_transaction_occurs_checks T"
     and x: "x \<in> fv_transaction T - set (transaction_fresh T)" "\<Gamma>\<^sub>v x = TAtom Value"
   obtains l ts S where
     "transaction_receive T = (l,receive\<langle>ts\<rangle>)#S" "occurs (Var x) \<in> set ts"
 proof -
   let ?rcvs = "transaction_receive T"
   let ?frsh = "transaction_fresh T"
   let ?fvs = "fv_transaction T"
 
   have *: "?rcvs \<noteq> []" "is_Receive (hd (unlabel ?rcvs))"
           "\<forall>x \<in> ?fvs - set ?frsh. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
             occurs (Var x) \<in> set (the_msgs (hd (unlabel ?rcvs)))"
     using T x unfolding admissible_transaction_occurs_checks_def \<Gamma>\<^sub>v_TAtom''(2) by meson+
 
   obtain r S where S: "?rcvs = r#S"
     using *(1) by (cases ?rcvs) auto
 
   obtain l ts where r: "r = (l,receive\<langle>ts\<rangle>)"
     by (metis *(1,2) S list.map_sel(1) list.sel(1) prod.collapse is_Receive_def unlabel_def) 
 
   have 0: "occurs (Var x) \<in> set ts" using *(3) x S r by fastforce
 
   show ?thesis using that[unfolded S r, of l ts S] 0 by blast
 qed
 
 lemma admissible_transaction_occurs_checksE2:
   assumes T: "admissible_transaction_occurs_checks T"
     and x: "x \<in> set (transaction_fresh T)"
   obtains l ts S where
     "transaction_send T = (l,send\<langle>ts\<rangle>)#S" "occurs (Var x) \<in> set ts"
 proof -
   let ?snds = "transaction_send T"
   let ?frsh = "transaction_fresh T"
   let ?fvs = "fv_transaction T"
   define ts where "ts \<equiv> the_msgs (hd (unlabel ?snds))"
 
   let ?P = "\<forall>x \<in> set ?frsh. occurs (Var x) \<in> set ts"
 
   have "?frsh \<noteq> []" using x by auto
   hence *: "?snds \<noteq> []" "is_Send (hd (unlabel ?snds))" "?P"
     using T x unfolding admissible_transaction_occurs_checks_def ts_def by meson+
 
   obtain r S where S: "?snds = r#S"
     using *(1) by (cases ?snds) auto
 
   obtain l where r: "r = (l,send\<langle>ts\<rangle>)"
     by (metis *(1,2) S list.map_sel(1) list.sel(1) prod.collapse unlabel_def ts_def
               stateful_strand_step.collapse(1)) 
 
   have ts: "occurs (Var x) \<in> set ts"
     using x *(3) unfolding S by auto
 
   show ?thesis using that[unfolded S r, of l ts S] ts by blast
 qed
 
 lemma admissible_transaction_occurs_checksE3:
   assumes T: "admissible_transaction_occurs_checks T"
     and t: "OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t" "t \<in> set ts"
     and ts: "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
   obtains x where "t = occurs (Var x)" "x \<in> set (transaction_fresh T)"
 proof -
   let ?P = "\<lambda>t. \<exists>x \<in> set (transaction_fresh T). t = occurs (Var x)"
 
   have "?P t"
     when "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t"
     for t
     using assms that
     unfolding admissible_transaction_occurs_checks_def
               admissible_transaction_send_occurs_form_def
     by metis
   moreover have "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
     using t(2) ts unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by fastforce
   ultimately have "?P t" using t(1) by blast
   thus thesis using that by blast
 qed
 
 lemma admissible_transaction_occurs_checksE4:
   assumes T: "admissible_transaction_occurs_checks T"
     and ts: "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
     and t: "occurs t \<in> set ts"
   obtains x where "t = Var x" "x \<in> set (transaction_fresh T)"
 using admissible_transaction_occurs_checksE3[OF T _ t ts] by auto
 
 lemma admissible_transaction_occurs_checksE5:
   assumes T: "admissible_transaction_occurs_checks T"
   shows "Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
 proof -
   have "\<exists>x \<in> set (transaction_fresh T). t = occurs (Var x)"
     when "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t"
     for t
     using assms that
     unfolding admissible_transaction_occurs_checks_def
               admissible_transaction_send_occurs_form_def
     by metis
   thus ?thesis by fastforce
 qed
 
 lemma admissible_transaction_occurs_checksE6:
   assumes T: "admissible_transaction_occurs_checks T"
     and t: "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
   shows "Fun OccursSec [] \<notin> set (snd (Ana t))" (is ?A)
     and "occurs k \<notin> set (snd (Ana t))" (is ?B)
 proof -
   obtain t' where t': "t' \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "t \<sqsubseteq> t'" using t by blast
   have "?A \<and> ?B"
   proof (rule ccontr)
     assume *: "\<not>(?A \<and> ?B)"
     hence "OccursSec \<in> funs_term t' \<or> OccursFact \<in> funs_term t'"
       by (meson t'(2) Ana_subterm' funs_term_Fun_subterm' term.order.trans) 
     then obtain x where x: "x \<in> set (transaction_fresh T)" "t' = occurs (Var x)"
       using t'(1) T
       unfolding admissible_transaction_occurs_checks_def
                 admissible_transaction_send_occurs_form_def
       by metis
     have "t = occurs (Var x) \<or> t = Var x \<or> t = Fun OccursSec []" using x(2) t'(2) by auto
     thus False using * by fastforce
   qed
   thus ?A ?B by simp_all
 qed
 
 lemma has_initial_value_producing_transactionE:
   fixes P::"('fun,'atom,'sets,'lbl) prot"
   assumes P: "has_initial_value_producing_transaction P"
     and P_adm: "\<forall>T \<in> set P. admissible_transaction' T"
   obtains T x s ts upds l l' where
     "\<Gamma>\<^sub>v x = TAtom Value" "Var x \<in> set ts" "fv\<^sub>s\<^sub>e\<^sub>t (set ts) = {x}"
     "\<forall>n. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts)" "T \<in> set P"
     "T = Transaction (\<lambda>(). []) [x] [] [] upds [(l, send\<langle>ts\<rangle>)]"
     "upds = [] \<or> (upds = [(l', insert\<langle>Var x, \<langle>s\<rangle>\<^sub>s\<rangle>)] \<and>
       (\<forall>T \<in> set P. \<forall>(l,a) \<in> set (transaction_strand T). \<forall>t.
         a \<noteq> select\<langle>t, \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t in \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t not in \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> delete\<langle>t, \<langle>s\<rangle>\<^sub>s\<rangle>)) \<or>
      T = Transaction (\<lambda>(). []) [x] [] [] [] [(l, send\<langle>ts\<rangle>)]"
 proof -
   define f where "f \<equiv> \<lambda>s.
       list_all (\<lambda>T. list_all (\<lambda>a. ((is_Delete a \<or> is_InSet a) \<longrightarrow> the_set_term a \<noteq> \<langle>s\<rangle>\<^sub>s) \<and>
                                   (is_NegChecks a \<longrightarrow> list_all (\<lambda>(_,t). t \<noteq> \<langle>s\<rangle>\<^sub>s) (the_ins a)))
                              (unlabel (transaction_checks T@transaction_updates T)))
                P"
 
   obtain T where T0:
       "T \<in> set P"
       "length (transaction_fresh T) = 1" "transaction_receive T = []"
       "transaction_checks T = []" "length (transaction_send T) = 1"
       "let x = hd (transaction_fresh T); a = hd (transaction_send T); u = transaction_updates T
        in is_Send (snd a) \<and> Var x \<in> set (the_msgs (snd a)) \<and>
           fv\<^sub>s\<^sub>e\<^sub>t (set (the_msgs (snd a))) = {x} \<and>
           (u \<noteq> [] \<longrightarrow> (
             let b = hd u; c = snd b
             in tl u = [] \<and> is_Insert c \<and> the_elem_term c = Var x \<and>
                is_Fun_Set (the_set_term c) \<and> f (the_Set (the_Fun (the_set_term c)))))"
     using P unfolding has_initial_value_producing_transaction_def Let_def list_ex_iff f_def by blast
 
   obtain x upds ts h s l l' where T1:
       "T = Transaction h [x] [] [] upds [(l, send\<langle>ts\<rangle>)]"
       "Var x \<in> set ts" "fv\<^sub>s\<^sub>e\<^sub>t (set ts) = {x}"
       "upds = [] \<or> (upds = [(l', insert\<langle>Var x, \<langle>s\<rangle>\<^sub>s\<rangle>)] \<and> f s)"
   proof (cases T)
     case T: (Transaction A B C D E F)
 
     obtain x where B: "B = [x]" using T0(2) unfolding T by (cases B) auto
     have C: "C = []" using T0(3) unfolding T by simp
     have D: "D = []" using T0(4) unfolding T by simp
     obtain l a where F: "F = [(l,a)]" using T0(5) unfolding T by fastforce
     obtain ts where ts: "a = send\<langle>ts\<rangle>" using T0(6) unfolding T F by (cases a) auto
     obtain k u where E: "E = [] \<or> E = [(k,u)]" using T0(6) unfolding T by (cases E) fastforce+
     have x: "Var x \<in> set ts" "fv\<^sub>s\<^sub>e\<^sub>t (set ts) = {x}" using T0(6) unfolding T B F ts by auto
 
     from E show ?thesis
     proof
       assume E': "E = [(k,u)]"
       obtain t t' where u: "u = insert\<langle>t,t'\<rangle>" using T0(6) unfolding T E' by (cases u) auto
       have t: "t = Var x" using T0(6) unfolding T B E' u Let_def by simp
       obtain s where t': "t' = \<langle>s\<rangle>\<^sub>s" and s: "f s" using T0(6) unfolding T B E' u Let_def by auto
       show ?thesis using that[OF T[unfolded B C D F ts E' u t t'] x] s by blast
     qed (use that[OF T[unfolded B C D F ts] x] in blast)
   qed
 
   note T_adm = bspec[OF P_adm T0(1)]
 
   have "x \<in> set (transaction_fresh T)" using T1(1) by fastforce
   hence x: "\<Gamma>\<^sub>v x = TAtom Value" using admissible_transactionE(2)[OF T_adm] by fast
 
   have "set ts \<subseteq> trms_transaction T" unfolding T1(1) trms_transaction_unfold by simp
   hence ts: "\<forall>n. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts)"
     using admissible_transactions_no_Value_consts[OF T_adm] by blast
 
   have "a \<noteq> select\<langle>t, \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t in \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t not in \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> delete\<langle>t, \<langle>s\<rangle>\<^sub>s\<rangle>"
     when upds: "upds = [(k, insert\<langle>Var x,\<langle>s\<rangle>\<^sub>s\<rangle>)]"
       and T': "T' \<in> set P" and la: "(l,a) \<in> set (transaction_strand T')"
     for T' l k a t
   proof -
     note T'_wf = admissible_transaction_is_wellformed_transaction(1)[OF bspec[OF P_adm T']]
 
     have "a \<in> set (unlabel (transaction_checks T'@transaction_updates T'))"
       when a': "is_Check_or_Assignment a \<or> is_Update a"
       using that wellformed_transaction_strand_unlabel_memberD[OF T'_wf unlabel_in[OF la]]
       by (cases a) auto
     note 0 = this T1(4) T'
 
     note 1 = upds f_def list_all_iff
 
     show ?thesis
     proof (cases a)
       case (Delete t' s') thus ?thesis using 0 unfolding 1 by fastforce
     next
       case (InSet ac t' s') thus ?thesis using 0 unfolding 1 by fastforce
     next
       case (NegChecks X F G) thus ?thesis using 0 unfolding 1 by fastforce
     qed auto
   qed
   hence s: "\<forall>T \<in> set P. \<forall>(l,a) \<in> set (transaction_strand T). \<forall>t.
         a \<noteq> select\<langle>t, \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t in \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t not in \<langle>s\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> delete\<langle>t, \<langle>s\<rangle>\<^sub>s\<rangle>"
     when upds: "upds = [(k, insert\<langle>Var x,\<langle>s\<rangle>\<^sub>s\<rangle>)]" for k
     using upds by force
 
   have h: "h = (\<lambda>(). [])"
   proof -
     have "transaction_decl T = h" using T1(1) by fastforce
     hence "h a = []" for a using admissible_transactionE(1)[OF T_adm] by simp
     thus ?thesis using ext[of h "\<lambda>(). []"] by (metis case_unit_Unity)
   qed
 
   show ?thesis using that[OF x T1(2,3) ts T0(1)] T1(1,4) s unfolding h by auto
 qed
 
 lemma has_initial_value_producing_transaction_update_send_ex_filter:
   fixes P::"('a,'b,'c,'d) prot"
   defines "f \<equiv> \<lambda>T. transaction_fresh T = [] \<longrightarrow>
                       list_ex (\<lambda>a. is_Update (snd a) \<or> is_Send (snd a)) (transaction_strand T)"
   assumes P: "has_initial_value_producing_transaction P"
   shows "has_initial_value_producing_transaction (filter f P)"
 proof -
   define g where "g \<equiv> \<lambda>P::('a,'b,'c,'d) prot. \<lambda>s.
       list_all (\<lambda>T. list_all (\<lambda>a. ((is_Delete a \<or> is_InSet a) \<longrightarrow> the_set_term a \<noteq> \<langle>s\<rangle>\<^sub>s) \<and>
                                   (is_NegChecks a \<longrightarrow> list_all (\<lambda>(_,t). t \<noteq> \<langle>s\<rangle>\<^sub>s) (the_ins a)))
                              (unlabel (transaction_checks T@transaction_updates T)))
                P"
 
   let ?Q = "\<lambda>P T.
      let x = hd (transaction_fresh T); a = hd (transaction_send T); u = transaction_updates T
      in is_Send (snd a) \<and> Var x \<in> set (the_msgs (snd a)) \<and>
         fv\<^sub>s\<^sub>e\<^sub>t (set (the_msgs (snd a))) = {x} \<and>
         (u \<noteq> [] \<longrightarrow> (
           let b = hd u; c = snd b
           in tl u = [] \<and> is_Insert c \<and> the_elem_term c = Var x \<and>
              is_Fun_Set (the_set_term c) \<and> g P (the_Set (the_Fun (the_set_term c)))))"
 
   have "set (filter f P) \<subseteq> set P" by simp
   hence "list_all h P \<Longrightarrow> list_all h (filter f P)" for h unfolding list_all_iff by blast
   hence g_f_subset: "g P s \<Longrightarrow> g (filter f P) s" for s unfolding g_def by blast
 
   obtain T where T:
     "T \<in> set P" "length (transaction_fresh T) = 1" "transaction_receive T = []"
     "transaction_checks T = []" "length (transaction_send T) = 1" "?Q P T"
     using P unfolding has_initial_value_producing_transaction_def Let_def list_ex_iff g_def by blast
 
   obtain x where x: "transaction_fresh T = [x]" using T(2) by blast
   obtain a where a: "transaction_send T = [a]" using T(5) by blast
   obtain l b where b: "a = (l,b)" by (cases a) auto
   obtain ts where ts: "b = send\<langle>ts\<rangle>" using T(6) unfolding Let_def a b by (cases b) auto
 
   have "T \<in> set (filter f P)" using T(1) x a unfolding b ts f_def by auto
   moreover have "?Q (filter f P) T" using T(6) g_f_subset by meson
   ultimately show ?thesis
     using T(2-5)
     unfolding has_initial_value_producing_transaction_def Let_def list_ex_iff g_def
     by blast
 qed
 
 
 subsection \<open>Lemmata: Renaming, Declaration, and Fresh Substitutions\<close>
 lemma transaction_decl_subst_empty_inv:
   assumes "transaction_decl_subst Var T"
   shows "transaction_decl T () = []"
 using assms unfolding transaction_decl_subst_def subst_domain_Var by blast
 
 lemma transaction_decl_subst_domain:
   fixes \<xi>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> T"
   shows "subst_domain \<xi> = fst ` set (transaction_decl T ())"
 using assms unfolding transaction_decl_subst_def by argo
 
 lemma transaction_decl_subst_grounds_domain:
   fixes \<xi>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> T"
     and "x \<in> fst ` set (transaction_decl T ())"
   shows "fv (\<xi> x) = {}"
 proof -
   obtain c where "\<xi> x = Fun c []"
-    using assms unfolding transaction_decl_subst_def by moura
+    using assms unfolding transaction_decl_subst_def by force
   thus ?thesis by simp
 qed
 
 lemma transaction_decl_subst_range_vars_empty:
   fixes \<xi>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> T"
   shows "range_vars \<xi> = {}"
 using assms unfolding transaction_decl_subst_def range_vars_def by auto
 
 lemma transaction_decl_subst_wt:
   fixes \<xi>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> T"
   shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<xi>"
 using assms unfolding transaction_decl_subst_def by blast
 
 lemma transaction_decl_subst_is_wf_trm:
   fixes \<xi>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> P"
   shows "wf\<^sub>t\<^sub>r\<^sub>m (\<xi> v)"
 proof (cases "v \<in> subst_domain \<xi>")
   case True thus ?thesis using assms unfolding transaction_decl_subst_def by fastforce
 qed auto
 
 lemma transaction_decl_subst_range_wf_trms:
   fixes \<xi>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> P"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<xi>)"
 by (metis transaction_decl_subst_is_wf_trm[OF assms] wf_trm_subst_range_iff)
 
 lemma transaction_renaming_subst_is_renaming:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<alpha>: "transaction_renaming_subst \<alpha> P A"
   shows "\<exists>m. \<forall>\<tau> n. \<alpha> (\<tau>,n) = Var (\<tau>,n+Suc m)" (is ?A)
     and "\<exists>y. \<alpha> x = Var y" (is ?B)
     and "\<alpha> x \<noteq> Var x" (is ?C)
     and "subst_domain \<alpha> = UNIV" (is ?D)
     and "subst_range \<alpha> \<subseteq> range Var" (is ?E)
     and "fv (t \<cdot> \<alpha>) \<subseteq> range_vars \<alpha>" (is ?F)
 proof -
   show 0: ?A using \<alpha> unfolding transaction_renaming_subst_def var_rename_def by force
   show ?B using \<alpha> unfolding transaction_renaming_subst_def var_rename_def by blast
   show ?C using 0 by (cases x) auto
   show 1: ?D using 0 by fastforce
   show ?E using 0 by auto
   show ?F by (induct t) (auto simp add: 1 subst_dom_vars_in_subst subst_fv_imgI)
 qed
 
 lemma transaction_renaming_subst_is_injective:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P A"
   shows "inj \<alpha>"
 proof (intro injI)
   fix x y::"('fun,'atom,'sets,'lbl) prot_var"
   obtain \<tau>x nx where x: "x = (\<tau>x,nx)" by (metis surj_pair)
   obtain \<tau>y ny where y: "y = (\<tau>y,ny)" by (metis surj_pair)
 
   obtain m where m: "\<forall>\<tau>. \<forall>n. \<alpha> (\<tau>, n) = Var (\<tau>, n + Suc m)"
     using transaction_renaming_subst_is_renaming(1)[OF assms] by blast
 
   assume "\<alpha> x = \<alpha> y"
   hence "\<tau>x = \<tau>y" "nx = ny" using x y m by simp_all
   thus "x = y" using x y by argo
 qed
 
 lemma transaction_renaming_subst_vars_disj:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   shows "fv\<^sub>s\<^sub>e\<^sub>t (\<alpha> ` (\<Union>(vars_transaction ` set P))) \<inter> (\<Union>(vars_transaction ` set P)) = {}" (is ?A)
     and "fv\<^sub>s\<^sub>e\<^sub>t (\<alpha> ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<inter> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = {}" (is ?B)
     and "T \<in> set P \<Longrightarrow> vars_transaction T \<inter> range_vars \<alpha> = {}" (is "T \<in> set P \<Longrightarrow> ?C1")
     and "T \<in> set P \<Longrightarrow> bvars_transaction T \<inter> range_vars \<alpha> = {}" (is "T \<in> set P \<Longrightarrow> ?C2")
     and "T \<in> set P \<Longrightarrow> fv_transaction T \<inter> range_vars \<alpha> = {}" (is "T \<in> set P \<Longrightarrow> ?C3")
     and "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<inter> range_vars \<alpha> = {}" (is ?D1)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<inter> range_vars \<alpha> = {}" (is ?D2)
     and "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<inter> range_vars \<alpha> = {}" (is ?D3)
 proof -
   define X where "X \<equiv> \<Union>(vars_transaction ` set P) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 
   have 1: "finite X" by (simp add: X_def)
 
   obtain n where n: "n \<ge> max_var_set X" "\<alpha> = var_rename n"
-    using assms unfolding transaction_renaming_subst_def X_def by moura
+    using assms unfolding transaction_renaming_subst_def X_def by force
   hence 2: "\<forall>x \<in> X. snd x < Suc n"
     using less_Suc_max_var_set[OF _ 1] unfolding var_rename_def by fastforce
   
   have 3: "x \<notin> fv\<^sub>s\<^sub>e\<^sub>t (\<alpha> ` X)" "fv (\<alpha> x) \<inter> X = {}" "x \<notin> range_vars \<alpha>" when x: "x \<in> X" for x
     using 2 x n unfolding var_rename_def by force+
 
   show ?A ?B using 3(1,2) unfolding X_def by auto
 
   show ?C1 when T: "T \<in> set P" using T 3(3) unfolding X_def by blast
   thus ?C2 ?C3 when T: "T \<in> set P"
     using T by (simp_all add: disjoint_iff_not_equal vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t)
 
   show ?D1 using 3(3) unfolding X_def by auto
   thus ?D2 ?D3 by (simp_all add: disjoint_iff_not_equal vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t)
 qed
 
 lemma transaction_renaming_subst_wt:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P X"
   shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<alpha>"
 proof -
   { fix x::"('fun,'atom,'sets,'lbl) prot_var"
-    obtain \<tau> n where x: "x = (\<tau>,n)" by moura
+    obtain \<tau> n where x: "x = (\<tau>,n)" by force
     then obtain m where m: "\<alpha> x = Var (\<tau>,m)"
-      using assms transaction_renaming_subst_is_renaming(1) by moura
+      using assms transaction_renaming_subst_is_renaming(1) by force
     hence "\<Gamma> (\<alpha> x) = \<Gamma>\<^sub>v x" using x by (simp add: \<Gamma>\<^sub>v_def)
   } thus ?thesis by (simp add: wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def)
 qed
 
 lemma transaction_renaming_subst_is_wf_trm:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P X"
   shows "wf\<^sub>t\<^sub>r\<^sub>m (\<alpha> v)"
 proof -
-  obtain \<tau> n where "v = (\<tau>, n)" by moura
+  obtain \<tau> n where "v = (\<tau>, n)" by force
   then obtain m where "\<alpha> v = Var (\<tau>, n + Suc m)"
     using transaction_renaming_subst_is_renaming(1)[OF assms]
-    by moura
+    by force
   thus ?thesis by (metis wf_trm_Var)
 qed
 
 lemma transaction_renaming_subst_range_wf_trms:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P X"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<alpha>)"
 by (metis transaction_renaming_subst_is_wf_trm[OF assms] wf_trm_subst_range_iff)
 
 lemma transaction_renaming_subst_range_notin_vars:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   shows "\<exists>y. \<alpha> x = Var y \<and> y \<notin> \<Union>(vars_transaction ` set P) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 proof -
   obtain \<tau> n where x: "x = (\<tau>,n)" by (metis surj_pair)
 
   define y where "y \<equiv> \<lambda>m. (\<tau>,n+Suc m)"
 
   have "\<exists>m \<ge> max_var_set (\<Union>(vars_transaction ` set P) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A). \<alpha> x = Var (y m)"
     using assms x by (auto simp add: y_def transaction_renaming_subst_def var_rename_def)
   moreover have "finite (\<Union>(vars_transaction ` set P) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" by auto
   ultimately show ?thesis using x unfolding y_def by force
 qed
 
 lemma transaction_renaming_subst_var_obtain:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<alpha>: "transaction_renaming_subst \<alpha> P X"
   shows "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (S \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>) \<Longrightarrow> \<exists>y. \<alpha> y = Var x" (is "?A1 \<Longrightarrow> ?B1")
     and "x \<in> fv (t \<cdot> \<alpha>) \<Longrightarrow> \<exists>y \<in> fv t. \<alpha> y = Var x" (is "?A2 \<Longrightarrow> ?B2")
 proof -
   assume x: ?A1
-  obtain y where y: "y \<in> fv\<^sub>s\<^sub>s\<^sub>t S" "x \<in> fv (\<alpha> y)" using fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var[OF x] by moura
+  obtain y where y: "y \<in> fv\<^sub>s\<^sub>s\<^sub>t S" "x \<in> fv (\<alpha> y)" using fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var[OF x] by force
   thus ?B1 using transaction_renaming_subst_is_renaming(2)[OF \<alpha>, of y] by fastforce
 next
   assume x: ?A2
-  obtain y where y: "y \<in> fv t" "x \<in> fv (\<alpha> y)" using fv_subst_obtain_var[OF x] by moura
+  obtain y where y: "y \<in> fv t" "x \<in> fv (\<alpha> y)" using fv_subst_obtain_var[OF x] by force
   thus ?B2 using transaction_renaming_subst_is_renaming(2)[OF \<alpha>, of y] by fastforce
 qed
 
 lemma transaction_renaming_subst_set_eq:
   assumes "set P1 = set P2"
   shows "transaction_renaming_subst \<alpha> P1 X = transaction_renaming_subst \<alpha> P2 X" (is "?A = ?B")
 using assms unfolding transaction_renaming_subst_def by presburger
 
 lemma transaction_renaming_subst_vars_transaction_neq:
   assumes T: "T \<in> set P"
     and \<alpha>: "transaction_renaming_subst \<alpha> P vars"
     and vars:"finite vars"
     and x: "x \<in> vars_transaction T"
   shows "\<alpha> y \<noteq> Var x"
 proof -
   have "\<exists>n. \<alpha> = var_rename n \<and> n \<ge> max_var_set (\<Union>(vars_transaction ` set P))"
     using T \<alpha> vars x unfolding transaction_renaming_subst_def by auto
   then obtain n where n_p: "\<alpha> = var_rename n" "n \<ge> max_var_set (\<Union>(vars_transaction ` set P))"
     by blast
   moreover
   have "\<Union>(vars_transaction ` set P) \<supseteq> vars_transaction T"
     using T by blast
   ultimately
   have n_gt: "n \<ge> max_var_set (vars_transaction T)"
     by auto
   obtain a b where ab: "x = (a,b)"
     by (cases x) auto
   obtain c d where cd: "y = (c,d)"
     by (cases y) auto
 
   have nb: "n \<ge> b"
     using n_gt x ab
     by auto
 
   have "\<alpha> y = \<alpha> (c, d)"
     using cd by auto
   moreover
   have "... = Var (c, Suc (d + n))"
     unfolding n_p(1) unfolding var_rename_def by simp 
   moreover
   have "... \<noteq> Var x"
     using nb ab by auto
   ultimately
   show ?thesis
     by auto
 qed
 
 lemma transaction_renaming_subst_fv_disj:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   shows "fv\<^sub>s\<^sub>e\<^sub>t (\<alpha> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t  A = {}"
 proof -
   have "fv\<^sub>s\<^sub>e\<^sub>t (\<alpha> ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<inter> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t  A = {}"
     using assms transaction_renaming_subst_vars_disj(2) by blast
   moreover
   have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<subseteq> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
     by (simp add: vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t)
   ultimately
   show ?thesis
     by auto
 qed
 
 lemma transaction_fresh_subst_is_wf_trm:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
   shows "wf\<^sub>t\<^sub>r\<^sub>m (\<sigma> v)"
 proof (cases "v \<in> subst_domain \<sigma>")
   case True
   then obtain c where "\<sigma> v = Fun c []" "arity c = 0"
     using assms unfolding transaction_fresh_subst_def
-    by moura
+    by force
   thus ?thesis by auto
 qed auto
 
 lemma transaction_fresh_subst_wt:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
   shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<sigma>"
 using assms unfolding transaction_fresh_subst_def by blast
 
 lemma transaction_fresh_subst_domain:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
   shows "subst_domain \<sigma> = set (transaction_fresh T)"
 using assms unfolding transaction_fresh_subst_def by fast
 
 lemma transaction_fresh_subst_range_wf_trms:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<sigma>)"
 by (metis transaction_fresh_subst_is_wf_trm[OF assms] wf_trm_subst_range_iff)
 
 lemma transaction_fresh_subst_range_fresh:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T M"
   shows "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t M"
     and "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"
 using assms unfolding transaction_fresh_subst_def by meson+
 
 lemma transaction_fresh_subst_sends_to_val:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<sigma>: "transaction_fresh_subst \<sigma> T X"
     and y: "y \<in> set (transaction_fresh T)" "\<Gamma>\<^sub>v y = TAtom Value"
   obtains n where "\<sigma> y = Fun (Val n) []" "Fun (Val n) [] \<in> subst_range \<sigma>"
 proof -
   have "\<sigma> y \<in> subst_range \<sigma>" using assms unfolding transaction_fresh_subst_def by simp
 
   obtain c where c: "\<sigma> y = Fun c []" "\<not>public c" "arity c = 0"
     using \<sigma> y(1) unfolding transaction_fresh_subst_def by fastforce
 
   have "\<Gamma> (\<sigma> y) = TAtom Value"
     using \<sigma> y(2) \<Gamma>\<^sub>v_TAtom''(2)[of y] wt_subst_trm''[of \<sigma> "Var y"]
     unfolding transaction_fresh_subst_def by simp
   then obtain n where "c = Val n"
     using c by (cases c) (auto split: option.splits)
   thus ?thesis
     using c that unfolding transaction_fresh_subst_def
     by fastforce
 qed
 
 lemma transaction_fresh_subst_sends_to_val':
   fixes \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
     and "y \<in> set (transaction_fresh T)" "\<Gamma>\<^sub>v y = TAtom Value"
   obtains n where "(\<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> = Fun (Val n) []" "Fun (Val n) [] \<in> subst_range \<sigma>" 
 proof -
   obtain n where "\<sigma> y = Fun (Val n) []" "Fun (Val n) [] \<in> subst_range \<sigma>"
-    using transaction_fresh_subst_sends_to_val[OF assms] by moura
+    using transaction_fresh_subst_sends_to_val[OF assms] by force
   thus ?thesis using that by (fastforce simp add: subst_compose_def)
 qed
 
 lemma transaction_fresh_subst_grounds_domain:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
     and "y \<in> set (transaction_fresh T)"
   shows "fv (\<sigma> y) = {}"
 proof -
   obtain c where "\<sigma> y = Fun c []"
-    using assms unfolding transaction_fresh_subst_def by moura
+    using assms unfolding transaction_fresh_subst_def by force
   thus ?thesis by simp
 qed
 
 lemma transaction_fresh_subst_range_vars_empty:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T X"
   shows "range_vars \<sigma> = {}"
 proof -
   have "fv t = {}" when "t \<in> subst_range \<sigma>" for t
     using assms that unfolding transaction_fresh_subst_def by fastforce
   thus ?thesis unfolding range_vars_def by blast
 qed
 
 lemma transaction_decl_fresh_renaming_substs_range:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
   shows "x \<in> fst ` set (transaction_decl T ()) \<Longrightarrow>
           \<exists>c. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun c [] \<and> arity c = 0"
     and "x \<notin> fst ` set (transaction_decl T ()) \<Longrightarrow>
           x \<in> set (transaction_fresh T) \<Longrightarrow>
             \<exists>c. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun c [] \<and> \<not>public c \<and> arity c = 0"
     and "x \<notin> fst ` set (transaction_decl T ()) \<Longrightarrow>
           x \<in> set (transaction_fresh T) \<Longrightarrow>
           fst x = TAtom Value \<Longrightarrow>
             \<exists>n. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun (Val n) []"
     and "x \<notin> fst ` set (transaction_decl T ()) \<Longrightarrow>
           x \<notin> set (transaction_fresh T) \<Longrightarrow>
             \<exists>y. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Var y"
 proof -
   assume "x \<in> fst ` set (transaction_decl T ())"
   then obtain c where c: "\<xi> x = Fun c []" "arity c = 0"
     using \<xi> unfolding transaction_decl_subst_def by fastforce
   thus "\<exists>c. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun c [] \<and> arity c = 0"
     using subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha> x] subst_compose[of \<xi> \<sigma> x] by simp
 next
   assume x: "x \<notin> fst ` set (transaction_decl T ())"
             "x \<in> set (transaction_fresh T)"
 
   have *: "(\<xi> \<circ>\<^sub>s \<sigma>) x = \<sigma> x"
     using x(1) \<xi> unfolding transaction_decl_subst_def
     by (metis (no_types, opaque_lifting) subst_comp_notin_dom_eq)
   then obtain c where c: "(\<xi> \<circ>\<^sub>s \<sigma>) x = Fun c []" "\<not>public c" "arity c = 0"
     using \<sigma> x(2) unfolding transaction_fresh_subst_def by fastforce
   thus "\<exists>c. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun c [] \<and> \<not>public c \<and> arity c = 0"
     using subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha> x] subst_compose[of \<xi> \<sigma> x] by simp
 
   assume "fst x = TAtom Value"
   hence "\<Gamma> ((\<xi> \<circ>\<^sub>s \<sigma>) x) = TAtom Value"
     using * \<sigma> \<Gamma>\<^sub>v_TAtom''(2)[of x] wt_subst_trm''[of \<sigma> "Var x"]
     unfolding transaction_fresh_subst_def by simp
   then obtain n where "c = Val n"
     using c by (cases c) (auto split: option.splits)
   thus "\<exists>n. (\<xi> \<circ>\<^sub>s\<sigma> \<circ>\<^sub>s \<alpha>) x = Fun (Val n) []"
     using c subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha> x] subst_compose[of \<xi> \<sigma> x] by simp
 next
   assume "x \<notin> fst ` set (transaction_decl T ())"
          "x \<notin> set (transaction_fresh T)"
   hence "(\<xi> \<circ>\<^sub>s \<sigma>) x = Var x"
     using \<xi> \<sigma>
     unfolding transaction_decl_subst_def transaction_fresh_subst_def
     by (metis (no_types, opaque_lifting) subst_comp_notin_dom_eq subst_domI)
   thus "\<exists>y. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Var y"
     using transaction_renaming_subst_is_renaming(1)[OF \<alpha>]
           subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha> x] subst_compose[of \<xi> \<sigma> x]
     by (cases x) force
 qed
 
 lemma transaction_decl_fresh_renaming_substs_range':
   fixes \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
     and t: "t \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   shows "(\<exists>c. t = Fun c [] \<and> arity c = 0) \<or> (\<exists>x. t = Var x)"
     and "\<xi> = Var \<Longrightarrow> (\<exists>c. t = Fun c [] \<and> \<not>public c \<and> arity c = 0) \<or> (\<exists>x. t = Var x)"
     and "\<xi> = Var \<Longrightarrow> \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<Longrightarrow>
                       (\<exists>n. t = Fun (Val n) []) \<or> (\<exists>x. t = Var x)"
     and "\<xi> = Var \<Longrightarrow> is_Fun t \<Longrightarrow> t \<in> subst_range \<sigma>"
 proof -
   obtain x where x: "x \<in> subst_domain (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = t"
     using t by auto
 
   note 0 = x transaction_decl_fresh_renaming_substs_range[OF \<xi> \<sigma> \<alpha>, of x]
 
   show "(\<exists>c. t = Fun c [] \<and> arity c = 0) \<or> (\<exists>x. t = Var x)"
     using 0 unfolding \<Gamma>\<^sub>v_TAtom'' by auto
 
   assume 1: "\<xi> = Var"
 
   note 2 = transaction_decl_subst_empty_inv[OF \<xi>[unfolded 1]]
 
   show 3: "(\<exists>c. t = Fun c [] \<and> \<not>public c \<and> arity c = 0) \<or> (\<exists>x. t = Var x)"
     using 0 2 unfolding \<Gamma>\<^sub>v_TAtom'' by auto
 
   show "(\<exists>n. t = Fun (Val n) []) \<or> (\<exists>x. t = Var x)"
     when "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     using 0 2 that unfolding \<Gamma>\<^sub>v_TAtom'' by auto
 
   show "t \<in> subst_range \<sigma>" when t': "is_Fun t"
   proof -
     obtain x where x: "(\<sigma> \<circ>\<^sub>s \<alpha>) x = t" using t 1 by auto
     
     show ?thesis
     proof (cases "x \<in> subst_domain \<sigma>")
       case True thus ?thesis
         by (metis subst_dom_vars_in_subst subst_ground_ident_compose(1) subst_imgI x
                   transaction_fresh_subst_grounds_domain[OF \<sigma>]
                   transaction_fresh_subst_domain[OF \<sigma>]) 
     next
       case False thus ?thesis
         by (metis (no_types, lifting) subst_compose_def subst_domI term.disc(1) that
                   transaction_renaming_subst_is_renaming(5)[OF \<alpha>] var_renaming_is_Fun_iff x)
     qed
   qed
 qed
 
 lemma transaction_decl_fresh_renaming_substs_range'':
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and y: "y \<in> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x)"
   shows "\<xi> x = Var x"
     and "\<sigma> x = Var x"
     and "\<alpha> x = Var y"
     and "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Var y"
 proof -
   have "\<exists>z. z \<in> fv (\<xi> x)" by (metis y subst_compose_fv')
   hence "x \<notin> subst_domain \<xi>"
     using y transaction_decl_subst_domain[OF \<xi>]
           transaction_decl_subst_grounds_domain[OF \<xi>, of x]
     by blast
   thus 0: "\<xi> x = Var x" by blast
   hence "y \<in> fv ((\<sigma> \<circ>\<^sub>s \<alpha>) x)" using y by (simp add: subst_compose)
   hence "\<exists>z. z \<in> fv (\<sigma> x)" by (metis subst_compose_fv')
   hence "x \<notin> subst_domain \<sigma>"
     using y transaction_fresh_subst_domain[OF \<sigma>]
           transaction_fresh_subst_grounds_domain[OF \<sigma>, of x]
     by blast
   thus 1: "\<sigma> x = Var x" by blast
   
   show "\<alpha> x = Var y" "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Var y"
     using 0 1 y transaction_renaming_subst_is_renaming(2)[OF \<alpha>, of x]
     unfolding subst_compose_def by (fastforce,fastforce)
 qed
 
 lemma transaction_decl_fresh_renaming_substs_vars_subset:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "\<Union>(fv_transaction ` set P) \<subseteq> subst_domain (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" (is ?A)
     and "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> subst_domain (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" (is ?B)
     and "T' \<in> set P \<Longrightarrow> fv_transaction T' \<subseteq> subst_domain (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" (is "T' \<in> set P \<Longrightarrow> ?C")
     and "T' \<in> set P \<Longrightarrow> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<subseteq> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       (is "T' \<in> set P \<Longrightarrow> ?D")
 proof -
   have *: "x \<in> subst_domain (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" for x
   proof (cases "x \<in> subst_domain \<xi>")
     case True thus ?thesis
       using transaction_decl_subst_domain[OF \<xi>] transaction_decl_subst_grounds_domain[OF \<xi>]
       by (simp add: subst_domI subst_dom_vars_in_subst subst_ground_ident_compose(1))
   next
     case False
     hence \<xi>_x_eq: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = (\<sigma> \<circ>\<^sub>s \<alpha>) x" by (auto simp add: subst_compose)
 
     show ?thesis
     proof (cases "x \<in> subst_domain \<sigma>")
       case True
       hence "x \<notin> {x. \<exists>y. \<sigma> x = Var y \<and> \<alpha> y = Var x}"
         using transaction_fresh_subst_domain[OF \<sigma>]
               transaction_fresh_subst_grounds_domain[OF \<sigma>, of x]
         by auto
       hence "x \<in> subst_domain (\<sigma> \<circ>\<^sub>s \<alpha>)" using subst_domain_subst_compose[of \<sigma> \<alpha>] by blast
       thus ?thesis using \<xi>_x_eq subst_dom_vars_in_subst by fastforce 
     next
       case False
       hence "(\<sigma> \<circ>\<^sub>s \<alpha>) x = \<alpha> x" unfolding subst_compose_def by fastforce
       moreover have "\<alpha> x \<noteq> Var x"
         using transaction_renaming_subst_is_renaming(1)[OF \<alpha>] by (cases x) auto
       ultimately show ?thesis using \<xi>_x_eq by fastforce
     qed
   qed
   
   show ?A ?B using * by blast+
 
   show ?C when T: "T' \<in> set P" using T * by blast
   hence "fv\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T') \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<subseteq> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     when T: "T' \<in> set P"
     using T fv\<^sub>s\<^sub>s\<^sub>t_subst_subset_range_vars_if_subset_domain by blast
   thus ?D when T: "T' \<in> set P" by (metis T unlabel_subst)
 qed
 
 lemma transaction_decl_fresh_renaming_substs_vars_disj:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` (\<Union>(vars_transaction ` set P))) \<inter> (\<Union>(vars_transaction ` set P)) = {}"
       (is ?A)
     and "x \<in> \<Union>(vars_transaction ` set P) \<Longrightarrow> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x) \<inter> (\<Union>(vars_transaction ` set P)) = {}"
       (is "?B' \<Longrightarrow> ?B")
     and "T' \<in> set P \<Longrightarrow> vars_transaction T' \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}" (is "T' \<in> set P \<Longrightarrow> ?C1")
     and "T' \<in> set P \<Longrightarrow> bvars_transaction T' \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}" (is "T' \<in> set P \<Longrightarrow> ?C2")
     and "T' \<in> set P \<Longrightarrow> fv_transaction T' \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}" (is "T' \<in> set P \<Longrightarrow> ?C3")
     and "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}" (is ?D1)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}" (is ?D2)
     and "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}" (is ?D3)
     and "range_vars \<xi> = {}" (is ?E1)
     and "range_vars \<sigma> = {}" (is ?E2)
     and "range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<subseteq> range_vars \<alpha>" (is ?E3)
 proof -
   note 0 = transaction_renaming_subst_vars_disj[OF \<alpha>]
 
   show ?A
   proof (cases "fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` (\<Union>(vars_transaction ` set P))) = {}")
     case False
     hence "\<forall>x \<in> (\<Union>(vars_transaction ` set P)). (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = \<alpha> x \<or> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x) = {}"
       using transaction_decl_fresh_renaming_substs_range''[OF \<xi> \<sigma> \<alpha>] by auto
     thus ?thesis using 0(1) by force
   qed blast
   thus "?B' \<Longrightarrow> ?B" by auto
 
   show ?E1 ?E2
     using transaction_fresh_subst_grounds_domain[OF \<sigma>]
           transaction_decl_subst_grounds_domain[OF \<xi>]
     unfolding transaction_fresh_subst_domain[OF \<sigma>, symmetric]
               transaction_decl_subst_domain[OF \<xi>, symmetric]
     by (fastforce, fastforce)
   thus 1: ?E3
     using range_vars_subst_compose_subset[of \<xi> \<sigma>]
           range_vars_subst_compose_subset[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha>]
     by blast
   
   show ?C1 ?C2 ?C3 when T: "T' \<in> set P" using T 1 0(3,4,5)[of T'] by blast+
 
   show ?D1 ?D2 ?D3 using 1 0(6,7,8) by blast+
 qed
 
 lemma transaction_decl_fresh_renaming_substs_trms:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<inter> subst_domain \<xi> = {}"
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<inter> subst_domain \<sigma> = {}"
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<inter> subst_domain \<alpha> = {}"
   shows "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))) = subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \<cdot>\<^sub>s\<^sub>e\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 proof -
   have 1: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S). (\<exists>f. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun f []) \<or> (\<exists>y. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Var y)"
     using transaction_decl_fresh_renaming_substs_range'[OF \<xi> \<sigma> \<alpha>] by blast
 
   have 2: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<inter> subst_domain (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}"
     using assms(4-6) subst_domain_compose[of \<xi> \<sigma>] subst_domain_compose[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha>] by blast
 
   show ?thesis using subterms_subst_lsst[OF 1 2] by simp
 qed
 
 lemma transaction_decl_fresh_renaming_substs_wt:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T M"
           "transaction_renaming_subst \<alpha> P X"
   shows "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 using transaction_renaming_subst_wt[OF assms(3)]
       transaction_fresh_subst_wt[OF assms(2)]
       transaction_decl_subst_wt[OF assms(1)]
 by (metis wt_subst_compose)
 
 lemma transaction_decl_fresh_renaming_substs_range_wf_trms:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T M"
           "transaction_renaming_subst \<alpha> P X"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
 using transaction_renaming_subst_range_wf_trms[OF assms(3)]
       transaction_fresh_subst_range_wf_trms[OF assms(2)]
       transaction_decl_subst_range_wf_trms[OF assms(1)]
       wf_trms_subst_compose[of \<xi> \<sigma>]
       wf_trms_subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma>" \<alpha>]
 by metis
 
 lemma transaction_decl_fresh_renaming_substs_fv:
   fixes \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
     and x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
   shows "\<exists>y \<in> fv_transaction T - set (transaction_fresh T). (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y = Var x"
 proof -
   have "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using x fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     by argo
   then obtain y where "y \<in> fv_transaction T" "x \<in> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y)"
     by (metis fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var)
   thus ?thesis
     using transaction_decl_fresh_renaming_substs_range[OF \<xi> \<sigma> \<alpha>, of y]
     by (cases "y \<in> set (transaction_fresh T)") force+
 qed
 
 lemma transaction_decl_fresh_renaming_substs_range_no_attack_const:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
     and T: "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     and t: "t \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   shows "\<nexists>n. t = attack\<langle>n\<rangle>"
 proof -
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF \<xi> \<sigma> \<alpha>]
 
   obtain x where x: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = t" using t by auto
 
   have x_type: "\<Gamma> (Var x) = \<Gamma> (Var x \<cdot> \<xi>)" "\<Gamma> (Var x) = \<Gamma> (Var x \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using \<xi> wt_subst_trm''[of \<xi> "Var x"] wt_subst_trm''[OF \<xi>\<sigma>\<alpha>_wt, of "Var x"]
     unfolding transaction_decl_subst_def by (blast, blast)
 
   show ?thesis
   proof (cases t)
     case (Fun f S)
     hence "x \<in> set (transaction_fresh T) \<or> x \<in> fst ` set (transaction_decl T ())"
       using transaction_decl_fresh_renaming_substs_range[OF \<xi> \<sigma> \<alpha>, of x] x by force
     thus ?thesis
     proof
       assume "x \<in> set (transaction_fresh T)"
       hence "\<Gamma> t = TAtom Value \<or> (\<exists>a. \<Gamma> t = TAtom (Atom a))"
         using T x_type(2) x by (metis \<Gamma>.simps(1) eval_term.simps(1))
       thus ?thesis by auto
     next
       assume "x \<in> fst ` set (transaction_decl T ())"
       then obtain c where c: "\<xi> x = Fun (Fu c) []" "arity\<^sub>f c = 0"
         using \<xi> unfolding transaction_decl_subst_def by auto
 
       have "\<Gamma> t = TAtom Bottom \<or> (\<exists>a. \<Gamma> t = TAtom (Atom a))"
         using c(1) \<Gamma>_consts_simps(1)[OF c(2)] x x_type
               eval_term.simps(1)[of _ x \<xi>] eval_term.simps(1)[of _ x "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
         by (cases "\<Gamma>\<^sub>f c") simp_all
       thus ?thesis by auto
     qed
   qed simp
 qed
 
 lemma transaction_decl_fresh_renaming_substs_occurs_fact_send_receive:
   fixes t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T M"
     and \<alpha>: "transaction_renaming_subst \<alpha> P X"
     and T: "admissible_transaction' T"
     and t: "occurs t \<in> set ts"
   shows "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))
           \<Longrightarrow> \<exists>ts' s. send\<langle>ts'\<rangle> \<in> set (unlabel (transaction_send T)) \<and>
                       occurs s \<in> set ts' \<and> t = s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       (is "?A \<Longrightarrow> ?A'")
     and "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))
           \<Longrightarrow> \<exists>ts' s. receive\<langle>ts'\<rangle> \<in> set (unlabel (transaction_receive T)) \<and>
                       occurs s \<in> set ts' \<and> t = s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       (is "?B \<Longrightarrow> ?B'")
 proof -
   assume ?A
   then obtain s ts' where s:
       "s \<in> set ts'" "send\<langle>ts'\<rangle> \<in> set (unlabel (transaction_strand T))" "occurs t = s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     using t stateful_strand_step_mem_substD(1)[
             of ts "unlabel (transaction_strand T)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     by auto
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T \<xi>]
 
   have T_decl_notin: "x \<notin> fst ` set (transaction_decl T ())" for x
     using transaction_decl_subst_empty_inv[OF \<xi>[unfolded \<xi>_empty]] by simp
 
   note 0 = s(3) transaction_decl_fresh_renaming_substs_range[OF \<xi> \<sigma> \<alpha>]
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T]
   note T_fresh = admissible_transactionE(14)[OF T]
 
   have "\<exists>u. s = occurs u"
   proof (cases s)
     case (Var x) 
     hence "(\<exists>c. s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Fun c []) \<or> (\<exists>y. s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Var y)"
       using 0(2-5)[of x] \<xi>_empty by (auto simp del: subst_subst_compose)
     thus ?thesis
       using 0(1) by simp
   next
     case (Fun f T)
     hence 1: "f = OccursFact" "length T = 2" "T ! 0 \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Fun OccursSec []"
              "T ! 1 \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = t"
       using 0(1) by auto
     have "T ! 0 = Fun OccursSec []"
     proof (cases "T ! 0")
       case (Var x) thus ?thesis
         using 0(2-5)[of x] 1(3) T_fresh T_decl_notin
         unfolding list_all_iff by (auto simp del: subst_subst_compose)
     qed (use 1(3) in simp)
     thus ?thesis using Fun 1 0(1) by (auto simp del: subst_subst_compose)
   qed
-  then obtain u where u: "s = occurs u" by moura
+  then obtain u where u: "s = occurs u" by force
   hence "t = u \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" using s(3) by fastforce
   thus ?A' using s u wellformed_transaction_strand_unlabel_memberD(8)[OF T_wf] by metis
 next
   assume ?B
   then obtain s ts' where s:
       "s \<in> set ts'" "receive\<langle>ts'\<rangle> \<in> set (unlabel (transaction_strand T))" "occurs t = s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     using t stateful_strand_step_mem_substD(2)[
             of ts "unlabel (transaction_strand T)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     by auto
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T \<xi>]
 
   have T_decl_notin: "x \<notin> fst ` set (transaction_decl T ())" for x
     using transaction_decl_subst_empty_inv[OF \<xi>[unfolded \<xi>_empty]] by simp
 
   note 0 = s(3) transaction_decl_fresh_renaming_substs_range[OF \<xi> \<sigma> \<alpha>]
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T]
   note T_fresh = admissible_transactionE(14)[OF T]
 
   have "\<exists>u. s = occurs u"
   proof (cases s)
     case (Var x) 
     hence "(\<exists>c. s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Fun c []) \<or> (\<exists>y. s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Var y)"
       using 0(2-5)[of x] \<xi>_empty by (auto simp del: subst_subst_compose)
     thus ?thesis
       using 0(1) by simp
   next
     case (Fun f T)
     hence 1: "f = OccursFact" "length T = 2" "T ! 0 \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Fun OccursSec []"
               "T ! 1 \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = t"
       using 0(1) by auto
     have "T ! 0 = Fun OccursSec []"
     proof (cases "T ! 0")
       case (Var x) thus ?thesis
         using 0(2-5)[of x] 1(3) T_fresh T_decl_notin
         unfolding list_all_iff by (auto simp del: subst_subst_compose)
     qed (use 1(3) in simp)
     thus ?thesis using Fun 1 0(1) by (auto simp del: subst_subst_compose)
   qed
-  then obtain u where u: "s = occurs u" by moura
+  then obtain u where u: "s = occurs u" by force
   hence "t = u \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" using s(3) by fastforce
   thus ?B' using s u wellformed_transaction_strand_unlabel_memberD(1)[OF T_wf] by metis
 qed
 
 lemma transaction_decl_subst_proj:
   assumes "transaction_decl_subst \<xi> T"
   shows "transaction_decl_subst \<xi> (transaction_proj n T)"
 using assms transaction_proj_decl_eq[of n T]
 unfolding transaction_decl_subst_def by presburger
 
 lemma transaction_fresh_subst_proj:
   assumes "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   shows "transaction_fresh_subst \<sigma> (transaction_proj n T) (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A))"
 using assms transaction_proj_fresh_eq[of n T]
       contra_subsetD[OF subterms\<^sub>s\<^sub>e\<^sub>t_mono[OF transaction_proj_trms_subset[of n T]]]
       contra_subsetD[OF subterms\<^sub>s\<^sub>e\<^sub>t_mono[OF trms\<^sub>s\<^sub>s\<^sub>t_proj_subset(1)[of n A]]]
 unfolding transaction_fresh_subst_def by metis
   
 lemma transaction_renaming_subst_proj:
   assumes "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   shows "transaction_renaming_subst \<alpha> (map (transaction_proj n) P) (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n A))"
 proof -
   let ?X = "\<lambda>P A. \<Union>(vars_transaction ` set P) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   define Y where "Y \<equiv> ?X (map (transaction_proj n) P) (proj n A)"
   define Z where "Z \<equiv> ?X P A"
 
   have "Y \<subseteq> Z"
     using sst_vars_proj_subset(3)[of n A] transaction_proj_vars_subset[of n]
     unfolding Y_def Z_def by fastforce
   hence "insert 0 (snd ` Y) \<subseteq> insert 0 (snd ` Z)" by blast
   moreover have "finite (insert 0 (snd ` Z))" "finite (insert 0 (snd ` Y))"
     unfolding Y_def Z_def by auto
   ultimately have 0: "max_var_set Y \<le> max_var_set Z" using Max_mono by blast
 
   have "\<exists>n\<ge>max_var_set Z. \<alpha> = var_rename n"
     using assms unfolding transaction_renaming_subst_def Z_def by blast
   hence "\<exists>n\<ge>max_var_set Y. \<alpha> = var_rename n" using 0 le_trans by fast
   thus ?thesis unfolding transaction_renaming_subst_def Y_def by blast
 qed
 
 lemma transaction_decl_fresh_renaming_substs_wf_sst:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes T: "wf'\<^sub>s\<^sub>s\<^sub>t (fst ` set (transaction_decl T ()) \<union> set (transaction_fresh T))
                     (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "wf'\<^sub>s\<^sub>s\<^sub>t {} (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
 proof -
   have 0: "range_vars \<xi> \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) = {}"
           "range_vars \<sigma> \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi>) = {}"
           "ground (\<xi> ` (fst ` set (transaction_decl T ())))"
           "ground (\<sigma> ` set (transaction_fresh T))"
           "ground (\<alpha> ` {})"
     using transaction_decl_subst_domain[OF \<xi>]
           transaction_decl_subst_grounds_domain[OF \<xi>]
           transaction_decl_subst_range_vars_empty[OF \<xi>]
           transaction_fresh_subst_range_vars_empty[OF \<sigma>]
           transaction_fresh_subst_domain[OF \<sigma>]
           transaction_fresh_subst_grounds_domain[OF \<sigma>]
     by (simp, simp, simp, simp, simp)
 
   have 1: "fv\<^sub>s\<^sub>e\<^sub>t (\<xi> ` set (transaction_fresh T)) \<subseteq> set (transaction_fresh T)" (is "?A \<subseteq> ?B")
   proof
     fix x assume x: "x \<in> ?A"
     then obtain y where y: "y \<in> set (transaction_fresh T)" "x \<in> fv (\<xi> y)" by auto
     hence "y \<notin> subst_domain \<xi>"
       using transaction_decl_subst_domain[OF \<xi>]
             transaction_decl_subst_grounds_domain[OF \<xi>]
       by fast
     thus "x \<in> ?B" using x y by auto
   qed
 
   let ?X = "fst ` set (transaction_decl T ()) \<union> set (transaction_fresh T)"
 
   have "fv\<^sub>s\<^sub>e\<^sub>t (\<alpha> ` fv\<^sub>s\<^sub>e\<^sub>t (\<sigma> ` fv\<^sub>s\<^sub>e\<^sub>t (\<xi> ` ?X))) = {}" using 0(3-5) 1 by auto
   hence "wf'\<^sub>s\<^sub>s\<^sub>t {} (((unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi>) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<sigma>) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>)"
     by (metis wf\<^sub>s\<^sub>s\<^sub>t_subst_apply[OF wf\<^sub>s\<^sub>s\<^sub>t_subst_apply[OF wf\<^sub>s\<^sub>s\<^sub>t_subst_apply[OF T]]])
   thus ?thesis
     using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst
           labeled_stateful_strand_subst_comp[OF 0(1), of "\<sigma> \<circ>\<^sub>s \<alpha>"]
           labeled_stateful_strand_subst_comp[OF 0(2), of \<alpha>]
           subst_compose_assoc[of \<xi> \<sigma> \<alpha>]
     by metis
 qed
 
 lemma admissible_transaction_decl_fresh_renaming_subst_not_occurs:
   fixes \<xi> \<sigma> \<alpha>
   defines "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   assumes T_adm: "admissible_transaction' T"
     and \<xi>\<sigma>\<alpha>:
       "transaction_decl_subst \<xi> T"
       "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "\<nexists>t. \<theta> x = occurs t"
     and "\<theta> x \<noteq> Fun OccursSec []"
 proof -
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm \<xi>\<sigma>\<alpha>(1)]
   note T_fresh_val = admissible_transactionE(2)[OF T_adm]
 
   show "\<nexists>t. \<theta> x = occurs t" for x
     using transaction_decl_fresh_renaming_substs_range'(1)[OF \<xi>\<sigma>\<alpha>]
     unfolding \<theta>_def[symmetric] by (cases "x \<in> subst_domain \<theta>") (force,force)
 
   show "\<theta> x \<noteq> Fun OccursSec []" for x
     using transaction_decl_fresh_renaming_substs_range'(3)[
             OF \<xi>\<sigma>\<alpha> _ \<xi>_empty T_fresh_val, of "\<theta> x"]
     unfolding \<theta>_def[symmetric] by (cases "x \<in> subst_domain \<theta>") auto
 qed
 
 
 subsection \<open>Lemmata: Reachable Constraints\<close>
 lemma reachable_constraints_as_transaction_lists:
   fixes f
   defines "f \<equiv> \<lambda>(T,\<xi>,\<sigma>,\<alpha>). dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     and "g \<equiv> concat \<circ> map f"
   assumes A: "A \<in> reachable_constraints P"
   obtains Ts where "A = g Ts"
     and "\<forall>B. prefix B Ts \<longrightarrow> g B \<in> reachable_constraints P"
     and "\<forall>B T \<xi> \<sigma> \<alpha>. prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts \<longrightarrow>
                       T \<in> set P \<and> transaction_decl_subst \<xi> T \<and>
                       transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B)) \<and>
                       transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
 proof -
   let ?P1 = "\<lambda>A Ts. A = g Ts"
   let ?P2 = "\<lambda>Ts. \<forall>B. prefix B Ts \<longrightarrow> g B \<in> reachable_constraints P"
   let ?P3 = "\<lambda>Ts. \<forall>B T \<xi> \<sigma> \<alpha>. prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts \<longrightarrow>
                       T \<in> set P \<and> transaction_decl_subst \<xi> T \<and>
                       transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B)) \<and>
                       transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
 
   have "\<exists>Ts. ?P1 A Ts \<and> ?P2 Ts \<and> ?P3 Ts" using A
   proof (induction A rule: reachable_constraints.induct)
     case init
     have "?P1 [] []" "?P2 []" "?P3 []" unfolding g_def f_def by simp_all
     thus ?case by blast
   next
     case (step A T \<xi> \<sigma> \<alpha>)
     let ?A' = "A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     obtain Ts where Ts: "?P1 A Ts" "?P2 Ts" "?P3 Ts" using step.IH by blast
 
     have 1: "?P1 ?A' (Ts@[(T,\<xi>,\<sigma>,\<alpha>)])"
       using Ts(1) unfolding g_def f_def by simp
     
     have 2: "?P2 (Ts@[(T,\<xi>,\<sigma>,\<alpha>)])"
     proof (intro allI impI)
       fix B assume "prefix B (Ts@[(T,\<xi>,\<sigma>,\<alpha>)])"
       hence "prefix B Ts \<or> B = Ts@[(T,\<xi>,\<sigma>,\<alpha>)]" by fastforce
       thus "g B \<in> reachable_constraints P "
         using Ts(1,2) reachable_constraints.step[OF step.hyps]
         unfolding g_def f_def by auto
     qed
 
     have 3: "?P3 (Ts@[(T,\<xi>,\<sigma>,\<alpha>)])"
       using Ts(1,3) step.hyps(2-5) unfolding g_def f_def by auto 
 
     show ?case using 1 2 3 by blast
   qed
   thus thesis using that by blast
 qed
 
 lemma reachable_constraints_transaction_action_obtain:
   assumes A: "A \<in> reachable_constraints P"
     and a: "a \<in> set A"
   obtains T b B \<alpha> \<sigma> \<xi>
   where "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
     and "T \<in> set P" "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
         "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
     and "b \<in> set (transaction_strand T)" "a = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "fst a = fst b"
 proof -
   define f where "f \<equiv> \<lambda>(T,\<xi>,\<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>).
                           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define g where "g \<equiv> concat \<circ> map f"
 
   obtain Ts where Ts:
       "A = g Ts" "\<forall>B. prefix B Ts \<longrightarrow> g B \<in> reachable_constraints P"
       "\<forall>B T \<xi> \<sigma> \<alpha>. prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts \<longrightarrow>
             T \<in> set P \<and> transaction_decl_subst \<xi> T \<and>
             transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B)) \<and>
             transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
     using reachable_constraints_as_transaction_lists[OF A] unfolding g_def f_def by blast
 
   obtain T \<alpha> \<xi> \<sigma> where T: "(T,\<xi>,\<sigma>,\<alpha>) \<in> set Ts" "a \<in> set (f (T,\<xi>,\<sigma>,\<alpha>))"
     using Ts(1) a unfolding g_def by auto
   
   obtain B where B: "prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts"
     using T(1) by (meson prefix_snoc_in_iff) 
 
   obtain b where b:
       "b \<in> set (transaction_strand T)" "a = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "fst a = fst b"
     using T(2) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_memberD'[of a "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" thesis]
     unfolding f_def by simp
 
   have 0: "prefix (g B@f (T, \<xi>, \<sigma>, \<alpha>)) A"
     using concat_map_mono_prefix[OF B, of f] unfolding g_def Ts(1) by simp
 
   have 1: "T \<in> set P" "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
           "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
     using B Ts(3) by (blast,blast,blast,blast)
 
   show thesis using 0[unfolded f_def] that[OF _ 1 b] by fast
 qed
 
 lemma reachable_constraints_unlabel_eq:
   defines "transaction_unlabel_eq \<equiv> \<lambda>T1 T2.
              transaction_decl T1     =          transaction_decl T2 \<and>
              transaction_fresh T1    =          transaction_fresh T2 \<and>
     unlabel (transaction_receive T1) = unlabel (transaction_receive T2) \<and>
     unlabel (transaction_checks T1)  = unlabel (transaction_checks T2) \<and>
     unlabel (transaction_updates T1) = unlabel (transaction_updates T2) \<and>
     unlabel (transaction_send T1)    = unlabel (transaction_send T2)"
   assumes Peq: "list_all2 transaction_unlabel_eq P1 P2"
   shows "unlabel ` reachable_constraints P1 = unlabel ` reachable_constraints P2" (is "?A = ?B")
 proof (intro antisym subsetI)
   have "transaction_unlabel_eq T2 T1 = transaction_unlabel_eq T1 T2" for T1 T2
     unfolding transaction_unlabel_eq_def by argo
   hence Peq': "list_all2 transaction_unlabel_eq P2 P1"
     using Peq list_all2_sym by metis
 
   have 0: "unlabel (transaction_strand T1) = unlabel (transaction_strand T2)"
     when "transaction_unlabel_eq T1 T2" for T1 T2
     using that unfolding transaction_unlabel_eq_def transaction_strand_def by force
 
   have "vars_transaction T1 = vars_transaction T2" when "transaction_unlabel_eq T1 T2" for T1 T2
     using 0[OF that] by simp
   hence "vars_transaction (P1 ! i) = vars_transaction (P2 ! i)" when "i < length P1" for i
     using that Peq list_all2_conv_all_nth by blast
   moreover have "length P1 = length P2" using Peq unfolding list_all2_iff by argo
   ultimately have 1: "\<Union>(vars_transaction ` set P1) = \<Union>(vars_transaction ` set P2)"
     using in_set_conv_nth[of _ P1] in_set_conv_nth[of _ P2] by fastforce
 
   have 2:
       "transaction_decl_subst \<xi> T1 \<Longrightarrow> transaction_decl_subst \<xi> T2" (is "?A1 \<Longrightarrow> ?A2")
       "transaction_fresh_subst \<sigma> T1 (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<Longrightarrow> transaction_fresh_subst \<sigma> T2 (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
         (is "?B1 \<Longrightarrow> ?B2")
       "transaction_renaming_subst \<alpha> P1 (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<Longrightarrow> transaction_renaming_subst \<alpha> P2 (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
         (is "?C1 \<Longrightarrow> ?C2")
       "transaction_renaming_subst \<alpha> P2 (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<Longrightarrow> transaction_renaming_subst \<alpha> P1 (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
         (is "?D1 \<Longrightarrow> ?D2")
     when "transaction_unlabel_eq T1 T2" "unlabel \<A> = unlabel \<B>"
     for T1 T2::"('fun,'atom,'sets,'lbl) prot_transaction"
       and \<A> \<B>::"('fun,'atom,'sets,'lbl) prot_strand"
       and \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   proof -
     have *: "transaction_decl T1 = transaction_decl T2"
             "transaction_fresh T1 = transaction_fresh T2"
             "trms_transaction T1 = trms_transaction T2"
       using that unfolding transaction_unlabel_eq_def transaction_strand_def by force+
 
     show "?A1 \<Longrightarrow> ?A2" using *(1) unfolding transaction_decl_subst_def by argo
     show "?B1 \<Longrightarrow> ?B2" using that(2) *(2,3) unfolding transaction_fresh_subst_def by force
     show "?C1 \<Longrightarrow> ?C2" using that(2) 1 unfolding transaction_renaming_subst_def by metis
     show "?D1 \<Longrightarrow> ?D2" using that(2) 1 unfolding transaction_renaming_subst_def by metis
   qed
 
   have 3: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T1 \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) =
            unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T2 \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     when "transaction_unlabel_eq T1 T2" for T1 T2 \<theta>
     using 0[OF that] unlabel_subst[of _ \<theta>] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_cong by metis
 
   have "\<exists>\<B> \<in> reachable_constraints P2. unlabel \<A> = unlabel \<B>"
     when "\<A> \<in> reachable_constraints P1" for \<A> using that
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     obtain \<B> where IH: "\<B> \<in> reachable_constraints P2" "unlabel \<A> = unlabel \<B>"
       by (meson step.IH)
     
     obtain T' where T': "T' \<in> set P2" "transaction_unlabel_eq T T'"
       using list_all2_in_set_ex[OF Peq step.hyps(2)] by auto
 
     show ?case
       using 3[OF T'(2), of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] IH(2) reachable_constraints.step[OF IH(1) T'(1)]
             2[OF T'(2) IH(2)] step.hyps(3-5)
       by (metis unlabel_append[of \<A>] unlabel_append[of \<B>])
   qed (simp add: unlabel_def)
   thus "\<A> \<in> ?A \<Longrightarrow> \<A> \<in> ?B" for \<A> by fast
 
   have "\<exists>\<B> \<in> reachable_constraints P1. unlabel \<A> = unlabel \<B>"
     when "\<A> \<in> reachable_constraints P2" for \<A> using that
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     obtain \<B> where IH: "\<B> \<in> reachable_constraints P1" "unlabel \<A> = unlabel \<B>"
       by (meson step.IH)
     
     obtain T' where T': "T' \<in> set P1" "transaction_unlabel_eq T T'"
       using list_all2_in_set_ex[OF Peq' step.hyps(2)] by auto
 
     show ?case
       using 3[OF T'(2), of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] IH(2) reachable_constraints.step[OF IH(1) T'(1)]
             2[OF T'(2) IH(2)] step.hyps(3-5)
       by (metis unlabel_append[of \<A>] unlabel_append[of \<B>])
   qed (simp add: unlabel_def)
   thus "\<A> \<in> ?B \<Longrightarrow> \<A> \<in> ?A" for \<A> by fast
 qed
 
 lemma reachable_constraints_set_eq:
   assumes "set P1 = set P2"
   shows "reachable_constraints P1 = reachable_constraints P2" (is "?A = ?B")
 proof (intro antisym subsetI)
   note 0 = assms transaction_renaming_subst_set_eq[OF assms]
   note 1 = reachable_constraints.intros
 
   show "\<A> \<in> ?A \<Longrightarrow> \<A> \<in> ?B" for \<A>
     by (induct \<A> rule: reachable_constraints.induct) (auto simp add: 0 intro: 1)
 
   show "\<A> \<in> ?B \<Longrightarrow> \<A> \<in> ?A" for \<A>
     by (induct \<A> rule: reachable_constraints.induct) (auto simp add: 0 intro: 1)
 qed
 
 lemma reachable_constraints_set_subst:
   assumes "set P1 = set P2"
     and "Q (reachable_constraints P1)"
   shows "Q (reachable_constraints P2)"
 by (rule subst[of _ _ Q, OF reachable_constraints_set_eq[OF assms(1)] assms(2)])
 
 lemma reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s:
   assumes "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms_transaction T)"
     and "\<A> \<in> reachable_constraints P"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
 using assms(2)
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms_transaction T)"
     using assms(1) step.hyps(2) by blast
   hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
     by (metis wf_trms_subst)
   hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     using wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_trms\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] by metis
   hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
     using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq by blast
   thus ?case using step.IH unlabel_append[of \<A>] trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] by auto
 qed simp
 
 lemma reachable_constraints_var_types_in_transactions:
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T).
               \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
   shows "\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` fv_transaction T)" (is "?A \<A>")
     and "\<Gamma>\<^sub>v ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` bvars_transaction T)" (is "?B \<A>")
     and "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` vars_transaction T)" (is "?C \<A>")
 using \<A>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   note 2 = transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
 
   have 3: "\<forall>t \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>). fv t = {} \<or> (\<exists>x. t = Var x)"
     using transaction_decl_fresh_renaming_substs_range'(1)[OF step.hyps(3-5)]
     by fastforce
 
   have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
        "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
        "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     unfolding T'_def
     by (metis fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq,
         metis bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq,
         metis vars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq)
   hence "\<Gamma> ` Var ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> \<Gamma> ` Var ` fv_transaction T"
         "\<Gamma> ` Var ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = \<Gamma> ` Var ` bvars_transaction T"
         "\<Gamma> ` Var ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> \<Gamma> ` Var ` vars_transaction T"
     using wt_subst_lsst_vars_type_subset[OF 2 3, of "transaction_strand T"]
     by argo+
   hence "\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> \<Gamma>\<^sub>v ` fv_transaction T"
         "\<Gamma>\<^sub>v ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = \<Gamma>\<^sub>v ` bvars_transaction T"
         "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> \<Gamma>\<^sub>v ` vars_transaction T"
     by (metis \<Gamma>\<^sub>v_Var_image)+
   hence 4: "\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` fv_transaction T)"
            "\<Gamma>\<^sub>v ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` bvars_transaction T)"
            "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` vars_transaction T)"
     using step.hyps(2) by fast+
 
   have 5: "\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> @ T') = (\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<union> (\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
           "\<Gamma>\<^sub>v ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> @ T') = (\<Gamma>\<^sub>v ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<union> (\<Gamma>\<^sub>v ` bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
           "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> @ T') = (\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<union> (\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
     using unlabel_append[of \<A> T']
           fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel T'"]
           bvars\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel T'"]
           vars\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel T'"]
     by auto
 
   { case 1 thus ?case
       using step.IH(1) 4(1) 5(1)
       unfolding T'_def by (simp del: subst_subst_compose fv\<^sub>s\<^sub>s\<^sub>t_def)
   }
 
   { case 2 thus ?case
       using step.IH(2) 4(2) 5(2)
       unfolding T'_def by (simp del: subst_subst_compose bvars\<^sub>s\<^sub>s\<^sub>t_def)
   }
 
   { case 3 thus ?case
       using step.IH(3) 4(3) 5(3)
       unfolding T'_def by (simp del: subst_subst_compose)
   }
 qed simp_all
 
 lemma reachable_constraints_no_bvars:
   assumes \<A>: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) = {}"
   shows "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
 using assms proof (induction)
   case init
   then show ?case 
     unfolding unlabel_def by auto
 next
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   then have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
     by metis
   moreover
   have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) = {}"
     using step by (metis bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq)
   ultimately 
   show ?case
     using bvars\<^sub>s\<^sub>s\<^sub>t_append unlabel_append by (metis sup_bot.left_neutral)
 qed
 
 lemma reachable_constraints_fv_bvars_disj:
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>S \<in> set P. admissible_transaction' S"
   shows "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
 proof -
   let ?X = "\<Union>T \<in> set P. bvars_transaction T"
 
   note 0 = admissible_transactions_fv_bvars_disj[OF P]
 
   have 1: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> ?X" using \<A>_reach
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) = bvars_transaction T"
       using bvars\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel (transaction_strand T)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
       by argo
     hence "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<subseteq> ?X"
       using step.hyps(2)
       by blast
     thus ?case
       using step.IH bvars\<^sub>s\<^sub>s\<^sub>t_append
       by auto
   qed (simp add: unlabel_def)
 
   have 2: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> ?X = {}" using \<A>_reach
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     have "x \<noteq> y" when x: "x \<in> ?X" and y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" for x y
     proof -
       obtain y' where y': "y' \<in> fv_transaction T" "y \<in> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y')"
         using y unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
         by (metis fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var)
 
       have "y \<notin> \<Union>(vars_transaction ` set P)"
         using transaction_decl_fresh_renaming_substs_range''[OF step.hyps(3-5) y'(2)]
               transaction_renaming_subst_range_notin_vars[OF step.hyps(5), of y']
         by auto
       thus ?thesis using x vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t by fast
     qed
     hence "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<inter> ?X = {}"
       by blast
     thus ?case
       using step.IH
             fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"]
             unlabel_append[of \<A> "transaction_strand T"]
       by force
   qed (simp add: unlabel_def)
 
   show ?thesis using 0 1 2 by blast
 qed
 
 lemma reachable_constraints_vars_TAtom_typed:
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and x: "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
   shows "\<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
 proof -
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P \<A>_reach)
 
   have T_adm: "admissible_transaction' T" when "T \<in> set P" for T
     by (meson that Ball_set P)
 
   have "\<forall>T\<in>set P. \<forall>x\<in>set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     using protocol_transaction_vars_TAtom_typed(3) P by blast
   hence *: "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> (\<Union>T\<in>set P. \<Gamma>\<^sub>v ` vars_transaction T)"
     using reachable_constraints_var_types_in_transactions[of \<A> P, OF \<A>_reach] by auto
 
   have "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> TAtom ` insert Value (range Atom)"
   proof -
     have "\<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
       when "T \<in> set P" "x \<in> vars_transaction T" for T x
       using that protocol_transaction_vars_TAtom_typed(1)[of T] P
             admissible_transactionE(5)
       by blast
     hence "(\<Union>T\<in>set P. \<Gamma>\<^sub>v ` vars_transaction T) \<subseteq> TAtom ` insert Value (range Atom)"
       using P by blast
     thus "\<Gamma>\<^sub>v ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> TAtom ` insert Value (range Atom)"
       using * by auto
   qed
   thus ?thesis using x by auto
 qed
 
 lemma reachable_constraints_vars_not_attack_typed:
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T).
               \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
            "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x"
     and x: "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
   shows "\<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x"
 using reachable_constraints_var_types_in_transactions(3)[OF \<A>_reach P(1)] P(2) x by fastforce
 
 lemma reachable_constraints_Value_vars_are_fv:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and x: "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
     and "\<Gamma>\<^sub>v x = TAtom Value"
   shows "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
 proof -
   have "\<forall>T\<in>set P. bvars_transaction T = {}"
     using P admissible_transactionE(4) by metis
   hence \<A>_no_bvars: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
     using reachable_constraints_no_bvars[OF \<A>_reach] by metis
   thus ?thesis using x vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"] by blast
 qed
 
 lemma reachable_constraints_subterms_subst:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
   shows "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>)) = (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
 proof -
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P \<A>_reach)
 
   from \<I> have \<I>': "welltyped_constraint_model \<I> \<A>"
     using welltyped_constraint_model_prefix by auto
 
   have 1: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>). (\<exists>f. \<I> x = Fun f []) \<or> (\<exists>y. \<I> x = Var y)"
   proof
     fix x
     assume xa: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     have "\<exists>f T. \<I> x = Fun f T"
       using \<I> interpretation_grounds[of \<I> "Var x"]
       unfolding welltyped_constraint_model_def constraint_model_def
       by (cases "\<I> x") auto
     then obtain f T where fT_p: "\<I> x = Fun f T"
       by auto
     hence "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)"
       using \<I>
       unfolding welltyped_constraint_model_def constraint_model_def
       using wf_trm_subst_rangeD
       by metis
     moreover
     have "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
       using xa var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t[of x "unlabel \<A>"] vars_iff_subtermeq[of x]
       by auto
     hence "\<exists>a. \<Gamma>\<^sub>v x = TAtom a"
       using reachable_constraints_vars_TAtom_typed[OF \<A>_reach P] by blast
     hence "\<exists>a. \<Gamma> (Var x) = TAtom a"
       by simp
     hence "\<exists>a. \<Gamma> (Fun f T) = TAtom a"
       by (metis (no_types, opaque_lifting) \<I>' welltyped_constraint_model_def fT_p wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def)
     ultimately show "(\<exists>f. \<I> x = Fun f []) \<or> (\<exists>y. \<I> x = Var y)"
       using TAtom_term_cases fT_p by metis
   qed
 
   have "\<forall>T\<in>set P. bvars_transaction T = {}"
     using assms admissible_transactionE(4) by metis
   then have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
     using reachable_constraints_no_bvars assms by metis
   then have 2: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> subst_domain \<I> = {}"
     by auto
 
   show ?thesis
     using subterms_subst_lsst[OF _ 2] 1
     by simp
 qed
 
 lemma reachable_constraints_val_funs_private':
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction_terms T"
            "\<forall>T \<in> set P. transaction_decl T () = []"
            "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     and f: "f \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "\<not>is_PubConstValue f"
     and "\<not>is_Abs f"
 proof -
   have "\<not>is_PubConstValue f \<and> \<not>is_Abs f" using \<A>_reach f
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     let ?T' = "unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     let ?T'' = "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
     note \<xi>_empty =
       admissible_transaction_decl_subst_empty'[OF bspec[OF P(2) step.hyps(2)] step.hyps(3)]
 
     have T: "admissible_transaction_terms T"
       using P(1) step.hyps(2) by metis
 
     have T_fresh: "\<forall>x \<in> set (transaction_fresh T). fst x = TAtom Value" when "T \<in> set P" for T
       using P that admissible_transactionE(14) unfolding list_all_iff \<Gamma>\<^sub>v_TAtom'' by fast
 
     show ?thesis using step
     proof (cases "f \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)")
       case False
       then obtain t where t: "t \<in> trms\<^sub>s\<^sub>s\<^sub>t ?T'" "f \<in> funs_term t"
         using step.prems trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of ?T'']
               trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?T'')"]
               unlabel_append[of \<A> "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?T''"] unlabel_subst[of "transaction_strand T"]
         by fastforce
       show ?thesis using trms\<^sub>s\<^sub>s\<^sub>t_funs_term_cases[OF t]
       proof
         assume "\<exists>u \<in> trms_transaction T. f \<in> funs_term u"
         thus ?thesis
           using conjunct1[OF conjunct2[OF T[unfolded admissible_transaction_terms_def]]]
           unfolding is_PubConstValue_def by blast
       next
         assume "\<exists>x \<in> fv_transaction T. f \<in> funs_term ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x)"
-        then obtain x where "x \<in> fv_transaction T" "f \<in> funs_term ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x)" by moura
+        then obtain x where "x \<in> fv_transaction T" "f \<in> funs_term ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x)" by force
         thus ?thesis
           using transaction_decl_fresh_renaming_substs_range'(3)[
                   OF step.hyps(3-5) _ \<xi>_empty T_fresh[OF step.hyps(2), unfolded \<Gamma>\<^sub>v_TAtom''(2)]]
           unfolding is_PubConstValue_def
           by (metis (no_types, lifting) funs_term_Fun_subterm prot_fun.disc(30,48) subst_imgI
                 subtermeq_Var_const(2) term.distinct(1) term.inject(2) term.set_cases(1))
       qed
     qed simp
   qed simp
   thus "\<not>is_PubConstValue f" "\<not>is_Abs f" by simp_all
 qed
 
 lemma reachable_constraints_val_funs_private:
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and f: "f \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "\<not>is_PubConstValue f"
     and "\<not>is_Abs f"
 using P reachable_constraints_val_funs_private'[OF \<A>_reach _ _ _ f]
       admissible_transaction_is_wellformed_transaction(4)
       admissible_transactionE(1,14)
 unfolding list_all_iff \<Gamma>\<^sub>v_TAtom''
 by (blast,fast)
 
 lemma reachable_constraints_occurs_fact_ik_case:
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and occ: "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   shows "\<exists>n. t = Fun (Val n) []"
 using \<A>_reach occ
 proof (induction A rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   have T_adm: "admissible_transaction' T" using P step.hyps(2) by blast
   hence T: "wellformed_transaction T" "admissible_transaction_occurs_checks T"
     using admissible_transaction_is_wellformed_transaction(1) P_occ step.hyps(2) by (blast,blast)
 
   have T_fresh: "\<forall>x \<in> set (transaction_fresh T). fst x = TAtom Value"
     using admissible_transactionE(14)[OF T_adm] unfolding list_all_iff by fast
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm step.hyps(3)]
 
   have \<xi>_dom_empty: "z \<notin> fst ` set (transaction_decl T ())" for z
     using transaction_decl_subst_empty_inv[OF step.hyps(3)[unfolded \<xi>_empty]] by simp
 
   show ?case
   proof (cases "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A")
     case False
     hence "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using step.prems unfolding \<theta>_def by simp
     hence "\<exists>ts. occurs t \<in> set ts \<and>
                 receive\<langle>ts\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
       unfolding ik\<^sub>s\<^sub>s\<^sub>t_def by force
     hence "\<exists>ts. occurs t \<in> set ts \<and>
                 send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(1) by blast
     then obtain ts s where s:
         "s \<in> set ts" "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))" "s \<cdot> \<theta> = occurs t"
       using stateful_strand_step_mem_substD(1)[of _ "unlabel (transaction_strand T)" \<theta>]
             unlabel_subst[of "transaction_strand T" \<theta>]
       by force
 
     note 0 = transaction_decl_fresh_renaming_substs_range[OF step.hyps(3-5)]
 
     have 1: "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
       using s(2) wellformed_transaction_strand_unlabel_memberD(8)[OF T(1)] by blast
 
     have 2: "is_Send (send\<langle>ts\<rangle>)"
       unfolding is_Send_def by simp
 
     have 3: "\<exists>u. s = occurs u"
     proof -
       { fix z
         have "(\<exists>n. \<theta> z = Fun (Val n) []) \<or> (\<exists>y. \<theta> z = Var y)"
           using 0(3,4) T_fresh \<xi>_dom_empty unfolding \<theta>_def by blast
         hence "\<nexists>u. \<theta> z = occurs u" "\<theta> z \<noteq> Fun OccursSec []" by auto
       } note * = this
 
       obtain u u' where T: "s = Fun OccursFact [u,u']"
         using *(1) s(3) by (cases s) auto
       thus ?thesis using *(2) s(3) by (cases u) auto
     qed
 
     obtain x where x: "x \<in> set (transaction_fresh T)" "s = occurs (Var x)"
       using 3 s(1) admissible_transaction_occurs_checksE4[OF T(2) 1] by metis
     
     have "t = \<theta> x"
       using s(3) x(2) by auto
     thus ?thesis
       using 0(3)[OF \<xi>_dom_empty x(1)] x(1) T_fresh unfolding \<theta>_def by fast
   qed (simp add: step.IH)
 qed simp
 
 lemma reachable_constraints_occurs_fact_send_ex:
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and x: "\<Gamma>\<^sub>v x = TAtom Value" "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   shows "\<exists>ts. occurs (Var x) \<in> set ts \<and> send\<langle>ts\<rangle> \<in> set (unlabel A)"
 using \<A>_reach x(2)
 proof (induction A rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF bspec[OF P step.hyps(2)] step.hyps(3)]
   note T = bspec[OF P_occ step.hyps(2)]
   
   show ?case
   proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A")
     case True
     show ?thesis
       using step.IH[OF True] unlabel_append[of A]
       by auto
   next
     case False
     then obtain y where y:
         "y \<in> fv_transaction T - set (transaction_fresh T)" "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y = Var x"
       using transaction_decl_fresh_renaming_substs_fv[OF step.hyps(3-5), of x]
             step.prems(1) fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A"] unlabel_append[of A]
       by auto
     
     have "\<sigma> y = Var y" using y(1) step.hyps(4) unfolding transaction_fresh_subst_def by auto
     hence "\<alpha> y = Var x" using y(2) unfolding subst_compose_def \<xi>_empty by simp
     hence y_val: "fst y = TAtom Value" "\<Gamma>\<^sub>v y = TAtom Value"
       using x(1) \<Gamma>\<^sub>v_TAtom''[of x] \<Gamma>\<^sub>v_TAtom''[of y]
             wt_subst_trm''[OF transaction_renaming_subst_wt[OF step.hyps(5)], of "Var y"]
       by force+
 
     obtain ts where ts:
         "occurs (Var y) \<in> set ts" "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))"
       using admissible_transaction_occurs_checksE1[OF T y(1) y_val(2)]
       by (metis list.set_intros(1) unlabel_Cons(1)) 
     hence "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))" 
       using transaction_strand_subsets(5) by blast
     hence *: "receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>\<rangle> \<in> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       using unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             stateful_strand_step_subst_inI(2)[of _ _ "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] 
       by force
 
     have "occurs (Var y) \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = occurs (Var x)"
       using y(2) by (auto simp del: subst_subst_compose)
     hence **: "occurs (Var x) \<in> set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" using ts(1) by force
 
     have "send\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
       using * dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2) by blast
     thus ?thesis using ** unlabel_append[of A] by force
   qed
 qed simp
 
 lemma reachable_constraints_db\<^sub>l\<^sub>s\<^sub>s\<^sub>t_set_args_empty:
   assumes \<A>: "\<A> \<in> reachable_constraints P"
     and PP: "list_all wellformed_transaction P"
     and admissible_transaction_updates:
       "let f = (\<lambda>T. \<forall>x \<in> set (unlabel (transaction_updates T)).
                       is_Update x \<and> is_Var (the_elem_term x) \<and> is_Fun_Set (the_set_term x) \<and>
                       fst (the_Var (the_elem_term x)) = TAtom Value)
       in list_all f P"
     and d: "(t, s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
   shows "\<exists>ss. s = Fun (Set ss) []"
   using \<A> d
 proof (induction)
   case (step \<A> TT \<xi> \<sigma> \<alpha>)
   let ?TT = "transaction_strand TT \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   let ?TTu = "unlabel ?TT"
   let ?TTd = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?TT"
   let ?TTdu = "unlabel ?TTd"
 
   from step(6) have "(t, s) \<in> set (db'\<^sub>s\<^sub>s\<^sub>t ?TTdu \<I> (db'\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> []))"
     by (metis db\<^sub>s\<^sub>s\<^sub>t_append db\<^sub>s\<^sub>s\<^sub>t_def step.prems unlabel_append)
   hence "(t, s) \<in> set (db'\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> []) \<or>
     (\<exists>t' s'. insert\<langle>t',s'\<rangle> \<in> set ?TTdu \<and> t = t' \<cdot> \<I> \<and> s = s' \<cdot> \<I>)"
     using db\<^sub>s\<^sub>s\<^sub>t_in_cases[of t "s" ?TTdu \<I>] by metis 
   thus ?case
   proof
     assume "\<exists>t' s'. insert\<langle>t',s'\<rangle> \<in> set ?TTdu \<and> t = t' \<cdot> \<I> \<and> s = s' \<cdot> \<I>"
     then obtain t' s' where t's'_p: "insert\<langle>t',s'\<rangle> \<in> set ?TTdu" "t = t' \<cdot> \<I>" "s = s' \<cdot> \<I>" by metis
     then obtain lll where "(lll, insert\<langle>t',s'\<rangle>) \<in> set ?TTd" by (meson unlabel_mem_has_label)
     hence "(lll, insert\<langle>t',s'\<rangle>) \<in> set (transaction_strand TT \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(4) by blast
     hence "insert\<langle>t',s'\<rangle> \<in> set ?TTu" by (meson unlabel_in)
     hence "insert\<langle>t',s'\<rangle> \<in> set ((unlabel (transaction_strand TT)) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       by (simp add: subst_lsst_unlabel)
     hence "insert\<langle>t',s'\<rangle> \<in> (\<lambda>x. x \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` set (unlabel (transaction_strand TT))"
       unfolding subst_apply_stateful_strand_def by auto
     then obtain u where
         "u \<in> set (unlabel (transaction_strand TT)) \<and> u \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = insert\<langle>t',s'\<rangle>"
       by auto
     hence "\<exists>t'' s''. insert\<langle>t'',s''\<rangle> \<in> set (unlabel (transaction_strand TT)) \<and>
                    t' = t'' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<and> s' = s'' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       by  (cases u) auto
     then obtain t'' s'' where t''s''_p:
         "insert\<langle>t'',s''\<rangle> \<in> set (unlabel (transaction_strand TT)) \<and>
           t' = t'' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<and> s' = s'' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       by auto
     hence "insert\<langle>t'',s''\<rangle> \<in> set (unlabel (transaction_updates TT))"
       using is_Update_in_transaction_updates[of "insert\<langle>t'',s''\<rangle>" TT]
       using PP step(2) unfolding list_all_iff by auto
     moreover have "\<forall>x\<in>set (unlabel (transaction_updates TT)). is_Fun_Set (the_set_term x)"
       using step(2) admissible_transaction_updates unfolding is_Fun_Set_def list_all_iff by auto
     ultimately have "is_Fun_Set (the_set_term (insert\<langle>t'',s''\<rangle>))" by auto
     moreover have "s' = s'' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" using t''s''_p by blast
     ultimately have "is_Fun_Set (the_set_term (insert\<langle>t',s'\<rangle>))" by (auto simp add: is_Fun_Set_subst)
     hence "is_Fun_Set s" by (simp add: t's'_p(3) is_Fun_Set_subst)
     thus ?case using is_Fun_Set_exi by auto
   qed (auto simp add: step db\<^sub>s\<^sub>s\<^sub>t_def)
 qed auto
 
 lemma reachable_constraints_occurs_fact_ik_ground:
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and t: "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   shows "fv (occurs t) = {}"
 proof -
   have 0: "admissible_transaction' T"
     when "T \<in> set P" for T
     using P that unfolding list_all_iff by simp
 
   note 1 = admissible_transaction_is_wellformed_transaction(1)[OF 0] bspec[OF P_occ]
 
   have 2: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) =
            (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<union> (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>)"
     when "T \<in> set P" for T \<theta> and A::"('fun,'atom,'sets,'lbl) prot_constr"
     using dual_transaction_ik_is_transaction_send'[OF 1(1)[OF that]] by fastforce
 
   show ?thesis using \<A>_reach t
   proof (induction A rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     note \<xi>_empty = admissible_transaction_decl_subst_empty[OF 0[OF step.hyps(2)] step.hyps(3)]
 
     from step show ?case
     proof (cases "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A")
       case False
       hence "occurs t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
         using 2[OF step.hyps(2)] step.prems \<xi>_empty by blast
       then obtain ts where ts:
           "occurs t \<in> set ts" "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
         using wellformed_transaction_send_receive_subst_trm_cases(2)[OF 1(1)[OF step.hyps(2)]]
         by blast
       then obtain ts' s where s:
           "occurs s \<in> set ts'" "send\<langle>ts'\<rangle> \<in> set (unlabel (transaction_send T))" "t = s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
         using transaction_decl_fresh_renaming_substs_occurs_fact_send_receive(1)[
                 OF step.hyps(3-5) 0[OF step.hyps(2)] ts(1)]
               transaction_strand_subst_subsets(8)[of T "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
         by blast
 
       obtain x where x: "x \<in> set (transaction_fresh T)" "s = Var x"
         using admissible_transaction_occurs_checksE4[OF 1(2)[OF step.hyps(2)] s(2,1)] by metis
 
       have "fv t = {}"
         using transaction_decl_fresh_renaming_substs_range(2)[OF step.hyps(3-5) _ x(1)]
               s(3) x(2) transaction_decl_subst_empty_inv[OF step.hyps(3)[unfolded \<xi>_empty]]
         by (auto simp del: subst_subst_compose)
       thus ?thesis by simp
     qed simp
   qed simp
 qed
 
 lemma reachable_constraints_occurs_fact_ik_funs_terms:
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
   shows "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I). OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana s)))" (is "?A A")
     and "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I). OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana s)))" (is "?B A")
     and "Fun OccursSec [] \<notin> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I" (is "?C A")
     and "\<forall>x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. I x \<noteq> Fun OccursSec []" (is "?D A")
 proof -
   have T_adm: "admissible_transaction' T" when "T \<in> set P" for T
     using P that unfolding list_all_iff by simp
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   note T_occ = bspec[OF P_occ]
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm]
 
   have \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" by (metis \<I> welltyped_constraint_model_def)
 
   have \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
     by (metis \<I> welltyped_constraint_model_def constraint_model_def)
 
   have \<I>_grounds: "fv (I x) = {}" "\<exists>f T. I x = Fun f T" for x
     using \<I> interpretation_grounds[of I, of "Var x"] empty_fv_exists_fun[of "I x"]
     unfolding welltyped_constraint_model_def constraint_model_def by auto
 
   have 00: "fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<subseteq> vars_transaction T"
            "fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))) = fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))"
     for T::"('fun,'atom,'sets,'lbl) prot_transaction"
     using fv_trms\<^sub>s\<^sub>s\<^sub>t_subset(1)[of "unlabel (transaction_send T)"] vars_transaction_unfold
           fv_subterms_set[of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"]
     by blast+
 
   have 0: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<exists>a. \<Gamma> (Var x) = TAtom a"
           "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<Gamma> (Var x) \<noteq> TAtom OccursSecType"
           "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))). \<exists>a. \<Gamma> (Var x) = TAtom a"
           "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))). \<Gamma> (Var x) \<noteq> TAtom OccursSecType"
           "\<forall>x \<in> vars_transaction T. \<exists>a. \<Gamma> (Var x) = TAtom a"
           "\<forall>x \<in> vars_transaction T. \<Gamma> (Var x) \<noteq> TAtom OccursSecType"
     when "T \<in> set P" for T
     using admissible_transaction_occurs_fv_types[OF T_adm[OF that]] 00
     by blast+
 
   note T_fresh_type = admissible_transactionE(2)[OF T_adm]
 
   have 1: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<cdot>\<^sub>s\<^sub>e\<^sub>t I =
            (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<union> (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta> \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
     when "T \<in> set P" for T \<theta> and A::"('fun,'atom,'sets,'lbl) prot_constr"
     using dual_transaction_ik_is_transaction_send'[OF T_wf[OF that]]
     by fastforce
 
   have 2: "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta> \<cdot>\<^sub>s\<^sub>e\<^sub>t I) =
            subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta> \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
     when "T \<in> set P" and \<theta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<theta>)" for T \<theta>
     using wt_subst_TAtom_subterms_set_subst[OF wt_subst_compose[OF \<theta>(1) \<I>_wt] 0(1)[OF that(1)]]
           wf_trm_subst_rangeD[OF wf_trms_subst_compose[OF \<theta>(2) \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s]]
     by auto
 
   have 3: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     when "T \<in> set P" "transaction_decl_subst \<xi> T"
          "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     for \<xi> \<sigma> \<alpha> and T::"('fun,'atom,'sets,'lbl) prot_transaction"
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
     using protocol_transaction_vars_TAtom_typed(3)[of T] P that(1)
           transaction_decl_fresh_renaming_substs_wt[OF that(2-4)]
           transaction_decl_fresh_renaming_substs_range_wf_trms[OF that(2-4)]
           wf_trms_subst_compose
     by simp_all
 
   have 4: "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)).
               OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana s))) \<and>
               OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
     when T: "T \<in> set P" for T
   proof
     fix t assume t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))"
     then obtain ts s where s:
         "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))" "s \<in> set ts" "t \<in> subterms s"
       using wellformed_transaction_unlabel_cases(4)[OF T_wf[OF T]]
       by fastforce
 
     have s_occ: "\<exists>x. s = occurs (Var x)" when "OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t"
       using that s(1) subtermeq_imp_funs_term_subset[OF s(3)]
             admissible_transaction_occurs_checksE3[OF T_occ[OF T] _ s(2)]
       by blast
 
-    obtain K T' where K: "Ana t = (K,T')" by moura
+    obtain K T' where K: "Ana t = (K,T')" by force
 
     show "OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana t))) \<and>
           OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana t)))"
     proof (rule ccontr)
       assume "\<not>(OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana t))) \<and>
                 OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana t))))"
       hence a: "OccursFact \<in> \<Union>(funs_term ` set (snd (Ana t))) \<or>
                 OccursSec \<in> \<Union>(funs_term ` set (snd (Ana t)))"
         by simp
       hence "OccursFact \<in> \<Union>(funs_term ` set T') \<or> OccursSec \<in> \<Union>(funs_term ` set T')"
         using K by simp
       hence "OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t"
         using Ana_subterm[OF K] funs_term_subterms_eq(1)[of t] by blast
       then obtain x where x: "t \<in> subterms (occurs (Var x))"
         using s(3) s_occ by blast
       thus False using a by fastforce
     qed
   qed
 
   have 5: "OccursFact \<notin> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
           "OccursSec \<notin> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       when \<xi>\<sigma>\<alpha>: "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
                 "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       and T: "T \<in> set P"
     for \<xi> \<sigma> \<alpha> and T::"('fun,'atom,'sets,'lbl) prot_transaction"
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
   proof -
     have "OccursFact \<notin> funs_term t" "OccursSec \<notin> funs_term t"
       when "t \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" for t 
       using transaction_decl_fresh_renaming_substs_range'(3)[
               OF \<xi>\<sigma>\<alpha> that \<xi>_empty[OF T \<xi>\<sigma>\<alpha>(1)] T_fresh_type[OF T]]
       by auto
     thus "OccursFact \<notin> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
          "OccursSec \<notin> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       by blast+
   qed
 
   have 6: "I x \<noteq> Fun OccursSec []" "\<nexists>t. I x = occurs t" "\<exists>a. \<Gamma> (I x) = TAtom a \<and> a \<noteq> OccursSecType"
     when T: "T \<in> set P"
       and \<xi>\<sigma>\<alpha>: "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
                "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       and x: "Var x \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     for x \<xi> \<sigma> \<alpha> and T::"('fun,'atom,'sets,'lbl) prot_transaction"
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
   proof -
     obtain t where t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "t \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = Var x"
-      using x by moura
+      using x by force
     then obtain y where y: "t = Var y" by (cases t) auto
 
     have "\<exists>a. \<Gamma> t = TAtom a \<and> a \<noteq> OccursSecType"
       using 0(1,2)[OF T] t(1) y
       by force
     thus "\<exists>a. \<Gamma> (I x) = TAtom a \<and> a \<noteq> OccursSecType"
       using wt_subst_trm''[OF 3(1)[OF T \<xi>\<sigma>\<alpha>]] wt_subst_trm''[OF \<I>_wt] t(2) 
       by (metis eval_term.simps(1))
     thus "I x \<noteq> Fun OccursSec []" "\<nexists>t. I x = occurs t"
       by auto
   qed
 
   have 7: "I x \<noteq> Fun OccursSec []" "\<nexists>t. I x = occurs t" "\<exists>a. \<Gamma> (I x) = TAtom a \<and> a \<noteq> OccursSecType"
     when T: "T \<in> set P"
       and \<xi>\<sigma>\<alpha>: "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
                "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       and x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars_transaction T)"
     for x \<xi> \<sigma> \<alpha> and T::"('fun,'atom,'sets,'lbl) prot_transaction"
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
   proof -
     obtain y where y: "y \<in> vars_transaction T" "x \<in> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y)"
       using x by auto
     hence y': "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y = Var x"
       using transaction_decl_fresh_renaming_substs_range'(3)[
               OF \<xi>\<sigma>\<alpha> _ \<xi>_empty[OF T \<xi>\<sigma>\<alpha>(1)] T_fresh_type[OF T]]
       by (cases "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)") force+
 
     have "\<exists>a. \<Gamma> (Var y) = TAtom a \<and> a \<noteq> OccursSecType"
       using 0(5,6)[OF T] y
       by force
     thus "\<exists>a. \<Gamma> (I x) = TAtom a \<and> a \<noteq> OccursSecType"
       using wt_subst_trm''[OF 3(1)[OF T \<xi>\<sigma>\<alpha>]] wt_subst_trm''[OF \<I>_wt] y'
       by (metis eval_term.simps(1))
     thus "I x \<noteq> Fun OccursSec []" "\<nexists>t. I x = occurs t"
       by auto
   qed
 
   have 8: "I x \<noteq> Fun OccursSec []" "\<nexists>t. I x = occurs t" "\<exists>a. \<Gamma> (I x) = TAtom a \<and> a \<noteq> OccursSecType"
     when T: "T \<in> set P"
       and \<xi>\<sigma>\<alpha>: "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
                "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       and x: "Var x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     for x \<xi> \<sigma> \<alpha> and T::"('fun,'atom,'sets,'lbl) prot_transaction"
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
   proof -
     obtain t where t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))" "t \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = Var x"
-      using x by moura
+      using x by force
     then obtain y where y: "t = Var y" by (cases t) auto
 
     have "\<exists>a. \<Gamma> t = TAtom a \<and> a \<noteq> OccursSecType"
       using 0(3,4)[OF T] t(1) y
       by force
     thus "\<exists>a. \<Gamma> (I x) = TAtom a \<and> a \<noteq> OccursSecType"
       using wt_subst_trm''[OF 3(1)[OF T \<xi>\<sigma>\<alpha>]] wt_subst_trm''[OF \<I>_wt] t(2) 
       by (metis eval_term.simps(1))
     thus "I x \<noteq> Fun OccursSec []" "\<nexists>t. I x = occurs t"
       by auto
   qed
 
   have s_fv: "fv s \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars_transaction T)"
     when s: "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       and T: "T \<in> set P"
     for s and \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
       and T::"('fun,'atom,'sets,'lbl) prot_transaction"
   proof
     fix x assume "x \<in> fv s"
     hence "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using s by auto
     hence *: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using fv_subterms_set_subst' by fast
     have **: "list_all is_Send (unlabel (transaction_send T))"
       using T_wf[OF T] unfolding wellformed_transaction_def by blast
     have "x \<in> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))"
     proof -
       obtain t where t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "x \<in> fv (t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
         using * by fastforce
       hence "fv t \<subseteq> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
         using fv_trms\<^sub>s\<^sub>s\<^sub>t_subset(1)[of "unlabel (transaction_send T)"]
         by auto
       thus ?thesis using t(2) subst_apply_fv_subset by fast
     qed
     thus "x \<in> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars_transaction T)"
       using vars_transaction_unfold[of T] by fastforce
   qed
 
   show "?A A" using \<A>_reach
   proof (induction A rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     have *: "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)).
               OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
       using 4[OF step.hyps(2)] by blast
 
     have "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot>\<^sub>s\<^sub>e\<^sub>t I.
             OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
     proof
       fix t assume t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       then obtain s u where su:
           "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "s \<cdot> I = t"
           "u \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))" "u \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = s"
         by force
 
-      obtain Ku Tu where KTu: "Ana u = (Ku,Tu)" by moura
+      obtain Ku Tu where KTu: "Ana u = (Ku,Tu)" by force
       
       have *: "OccursFact \<notin> \<Union>(funs_term ` set Tu)"
               "OccursFact \<notin> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
               "OccursFact \<notin> \<Union>(funs_term ` \<Union>(((set \<circ> snd \<circ> Ana) ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))))"
         using transaction_decl_fresh_renaming_substs_range'(3)[
                 OF step.hyps(3-5) _ \<xi>_empty[OF step.hyps(2,3)] T_fresh_type[OF step.hyps(2)]]
               4[OF step.hyps(2)] su(3) KTu
         by (fastforce,fastforce,fastforce)
 
       have "OccursFact \<notin> \<Union>(funs_term ` set (Tu \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       proof -
         { fix f assume f: "f \<in> \<Union>(funs_term ` set (Tu \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
-          then obtain tf where tf: "tf \<in> set Tu" "f \<in> funs_term (tf \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" by moura
+          then obtain tf where tf: "tf \<in> set Tu" "f \<in> funs_term (tf \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" by force
           hence "f \<in> funs_term tf \<or> f \<in> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
             using funs_term_subst[of tf "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] by force
           hence "f \<noteq> OccursFact" using *(1,2) tf(1) by blast
         } thus ?thesis by metis
       qed
       hence **: "OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
       proof (cases u)
         case (Var xu)
         hence "s = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) xu" using su(4) by (metis eval_term.simps(1))
         thus ?thesis using *(3) by fastforce
       qed (use su(4) KTu Ana_subst'[of _ _ Ku Tu "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] in simp)
       
       show "OccursFact \<notin> \<Union>(funs_term ` set (snd (Ana t)))"
       proof (cases s)
         case (Var sx)
         then obtain a where a: "\<Gamma> (I sx) = Var a"
           using su(1) 8(3)[OF step.hyps(2-5), of sx] by fast
         hence "Ana (I sx) = ([],[])" by (metis \<I>_grounds(2) const_type_inv[THEN Ana_const])
         thus ?thesis using Var su(2) by simp
       next
         case (Fun f S)
         hence snd_Ana_t: "snd (Ana t) = snd (Ana s) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t I"
           using su(2) Ana_subst'[of f S _ "snd (Ana s)" I] by (cases "Ana s") simp_all
 
         { fix g assume "g \<in> \<Union>(funs_term ` set (snd (Ana t)))"
           hence "g \<in> \<Union>(funs_term ` set (snd (Ana s))) \<or>
                  (\<exists>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s))). g \<in> funs_term (I x))"
             using snd_Ana_t funs_term_subst[of _ I] by auto
           hence "g \<noteq> OccursFact"
           proof
             assume "\<exists>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s))). g \<in> funs_term (I x)"
-            then obtain x where x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s)))" "g \<in> funs_term (I x)" by moura
+            then obtain x where x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s)))" "g \<in> funs_term (I x)" by force
             have "x \<in> fv s" using x(1) Ana_vars(2)[of s] by (cases "Ana s") auto
             hence "x \<in> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars_transaction T)"
               using s_fv[OF su(1) step.hyps(2)] by blast
             then obtain a h U where h:
                 "I x = Fun h U" "\<Gamma> (I x) = Var a" "a \<noteq> OccursSecType" "arity h = 0"
               using \<I>_grounds(2) 7(3)[OF step.hyps(2-5)] const_type_inv
               by metis
             hence "h \<noteq> OccursFact" by auto
             moreover have "U = []" using h(1,2,4) const_type_inv_wf[of h U a] \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s by fastforce
             ultimately show ?thesis using h(1) x(2) by auto
           qed (use ** in blast)
         } thus ?thesis by blast
       qed
     qed
     thus ?case
       using step.IH step.prems 1[OF step.hyps(2), of A "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             2[OF step.hyps(2) 3[OF step.hyps(2-5)]]
       by auto
   qed simp
 
   show "?B A" using \<A>_reach
   proof (induction A rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     have "\<forall>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot>\<^sub>s\<^sub>e\<^sub>t I.
             OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
     proof
       fix t assume t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       then obtain s u where su:
           "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "s \<cdot> I = t"
           "u \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))" "u \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = s"
         by force
 
-      obtain Ku Tu where KTu: "Ana u = (Ku,Tu)" by moura
+      obtain Ku Tu where KTu: "Ana u = (Ku,Tu)" by force
       
       have *: "OccursSec \<notin> \<Union>(funs_term ` set Tu)"
               "OccursSec \<notin> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
               "OccursSec \<notin> \<Union>(funs_term ` \<Union>(((set \<circ> snd \<circ> Ana) ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))))"
         using transaction_decl_fresh_renaming_substs_range'(3)[
                 OF step.hyps(3-5) _ \<xi>_empty[OF step.hyps(2,3)] T_fresh_type[OF step.hyps(2)]] 
               4[OF step.hyps(2)] su(3) KTu
         by (fastforce,fastforce,fastforce)
 
       have "OccursSec \<notin> \<Union>(funs_term ` set (Tu \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       proof -
         { fix f assume f: "f \<in> \<Union>(funs_term ` set (Tu \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
-          then obtain tf where tf: "tf \<in> set Tu" "f \<in> funs_term (tf \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" by moura
+          then obtain tf where tf: "tf \<in> set Tu" "f \<in> funs_term (tf \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" by force
           hence "f \<in> funs_term tf \<or> f \<in> \<Union>(funs_term ` subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
             using funs_term_subst[of tf "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] by force
           hence "f \<noteq> OccursSec" using *(1,2) tf(1) by blast
         } thus ?thesis by metis
       qed
       hence **: "OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana s)))"
       proof (cases u)
         case (Var xu)
         hence "s = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) xu" using su(4) by (metis eval_term.simps(1))
         thus ?thesis using *(3) by fastforce
       qed (use su(4) KTu Ana_subst'[of _ _ Ku Tu "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] in simp)
       
       show "OccursSec \<notin> \<Union>(funs_term ` set (snd (Ana t)))"
       proof (cases s)
         case (Var sx)
         then obtain a where a: "\<Gamma> (I sx) = Var a"
           using su(1) 8(3)[OF step.hyps(2-5), of sx] by fast
         hence "Ana (I sx) = ([],[])" by (metis \<I>_grounds(2) const_type_inv[THEN Ana_const])
         thus ?thesis using Var su(2) by simp
       next
         case (Fun f S)
         hence snd_Ana_t: "snd (Ana t) = snd (Ana s) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t I"
           using su(2) Ana_subst'[of f S _ "snd (Ana s)" I] by (cases "Ana s") simp_all
 
         { fix g assume "g \<in> \<Union>(funs_term ` set (snd (Ana t)))"
           hence "g \<in> \<Union>(funs_term ` set (snd (Ana s))) \<or>
                  (\<exists>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s))). g \<in> funs_term (I x))"
             using snd_Ana_t funs_term_subst[of _ I] by auto
           hence "g \<noteq> OccursSec"
           proof
             assume "\<exists>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s))). g \<in> funs_term (I x)"
-            then obtain x where x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s)))" "g \<in> funs_term (I x)" by moura
+            then obtain x where x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (snd (Ana s)))" "g \<in> funs_term (I x)" by force
             have "x \<in> fv s" using x(1) Ana_vars(2)[of s] by (cases "Ana s") auto
             hence "x \<in> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars_transaction T)"
               using s_fv[OF su(1) step.hyps(2)] by blast
             then obtain a h U where h:
                 "I x = Fun h U" "\<Gamma> (I x) = Var a" "a \<noteq> OccursSecType" "arity h = 0"
               using \<I>_grounds(2) 7(3)[OF step.hyps(2-5)] const_type_inv
               by metis
             hence "h \<noteq> OccursSec" by auto
             moreover have "U = []" using h(1,2,4) const_type_inv_wf[of h U a] \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s by fastforce
             ultimately show ?thesis using h(1) x(2) by auto
           qed (use ** in blast)
         } thus ?thesis by blast
       qed
     qed
     thus ?case
       using step.IH step.prems 1[OF step.hyps(2), of A "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             2[OF step.hyps(2) 3[OF step.hyps(2-5)]]
       by auto
   qed simp
 
   show "?C A" using \<A>_reach
   proof (induction A rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     have *: "Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       using admissible_transaction_occurs_checksE5[OF T_occ[OF step.hyps(2)]] by blast
 
     have **: "Fun OccursSec [] \<notin> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using transaction_decl_fresh_renaming_substs_range'(3)[
               OF step.hyps(3-5) _ \<xi>_empty[OF step.hyps(2,3)] T_fresh_type[OF step.hyps(2)]]
       by auto
 
     have "Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
     proof
       assume "Fun OccursSec [] \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       then obtain s where "s \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "s \<cdot> I = Fun OccursSec []"
-        by moura
+        by force
       moreover have "Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       proof
         assume "Fun OccursSec [] \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
         then obtain u where "u \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "u \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = Fun OccursSec []"
-          by moura
+          by force
         thus False using * ** by (cases u) (force simp del: subst_subst_compose)+
       qed
       ultimately show False using 6[OF step.hyps(2-5)] by (cases s) auto
     qed
     thus ?case using step.IH step.prems 1[OF step.hyps(2), of A "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] by fast
   qed simp
 
   show "?D A" using \<A>_reach
   proof (induction A rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     { fix x assume x: "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       hence x': "x \<in> vars\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
         by (metis vars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unlabel_subst)
       hence "x \<in> vars_transaction T \<or> x \<in> fv\<^sub>s\<^sub>e\<^sub>t ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` vars_transaction T)"
         using vars\<^sub>s\<^sub>s\<^sub>t_subst_cases[OF x'] by metis
       moreover have "I x \<noteq> Fun OccursSec []" when "x \<in> vars_transaction T"
         using that 0(5,6)[OF step.hyps(2)] wt_subst_trm''[OF \<I>_wt, of "Var x"]
         by fastforce
       ultimately have "I x \<noteq> Fun OccursSec []"
         using 7(1)[OF step.hyps(2-5), of x]
         by blast
     } thus ?case using step.IH by auto
   qed simp
 qed
 
 lemma reachable_constraints_occurs_fact_ik_subst_aux:
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and t: "t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "t \<cdot> I = occurs s"
   shows "\<exists>u. t = occurs u"
 proof -
   have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
     using \<I> unfolding welltyped_constraint_model_def constraint_model_def by metis
   hence 0: "\<Gamma> t = \<Gamma> (occurs s)"
     using t(2) wt_subst_trm'' by metis
 
   have 1: "\<Gamma>\<^sub>v ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<subseteq> (\<Union>T \<in> set P. \<Gamma>\<^sub>v ` fv_transaction T)"
           "\<forall>T \<in> set P. \<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     using reachable_constraints_var_types_in_transactions(1)[OF \<A>_reach]
           protocol_transaction_vars_TAtom_typed(2,3) P
     by fast+
 
   show ?thesis
   proof (cases t)
     case (Var x)
     thus ?thesis
       using 0 1 t(1) var_subterm_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of x "unlabel A"]
       by fastforce
   next
     case (Fun f T)
     hence 2: "f = OccursFact" "length T = Suc (Suc 0)" "T ! 0 \<cdot> I = Fun OccursSec []"
       using t(2) by auto
 
     have "T ! 0 = Fun OccursSec []"
     proof (cases "T ! 0")
       case (Var y)
       hence "I y = Fun OccursSec []" using Fun 2(3) by simp
       moreover have "Var y \<in> set T" using Var 2(2) length_Suc_conv[of T 1] by auto
       hence "y \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" using Fun t(1) by force
       hence "y \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
         using fv_ik_subset_fv_sst'[of "unlabel A"] vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel A"]
         by blast
       ultimately have False
         using reachable_constraints_occurs_fact_ik_funs_terms(4)[OF \<A>_reach \<I> P P_occ]
         by blast
       thus ?thesis by simp
     qed (use 2(3) in simp)
     moreover have "\<exists>u u'. T = [u,u']"
       using iffD1[OF length_Suc_conv 2(2)] iffD1[OF length_Suc_conv[of _ 0]] length_0_conv by fast
     ultimately show ?thesis using Fun 2(1,2) by force
   qed
 qed
 
 lemma reachable_constraints_occurs_fact_ik_subst:
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and t: "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
   shows "occurs t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 proof -
   have \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
     using \<I> unfolding welltyped_constraint_model_def constraint_model_def by metis
 
   obtain s where s: "s \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "s \<cdot> I = occurs t"
     using t by auto
   hence u: "\<exists>u. s = occurs u"
     using \<I>_wt reachable_constraints_occurs_fact_ik_subst_aux[OF \<A>_reach \<I> P P_occ]
     by blast
   hence "fv s = {}"
     using reachable_constraints_occurs_fact_ik_ground[OF \<A>_reach P P_occ] s
     by fast
   thus ?thesis
     using s u subst_ground_ident[of s I] 
     by argo
 qed
 
 lemma reachable_constraints_occurs_fact_send_in_ik:
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and x: "occurs (Var x) \<in> set ts" "send\<langle>ts\<rangle> \<in> set (unlabel A)"
   shows "occurs (I x) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 using \<A>_reach \<I> x
 proof (induction A rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
   have T_adm: "admissible_transaction' T"
     using P step.hyps(2) unfolding list_all_iff by blast
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
   note T_adm_occ = bspec[OF P_occ]
 
   have \<I>_is_T_model: "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) (set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I)) (unlabel T') I"
     using step.prems unlabel_append[of A T'] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel A" I "[]"]
           strand_sem_append_stateful[of "{}" "{}" "unlabel A" "unlabel T'" I]
     by (simp add: T'_def \<theta>_def welltyped_constraint_model_def constraint_model_def db\<^sub>s\<^sub>s\<^sub>t_def)
 
   show ?case
   proof (cases "send\<langle>ts\<rangle> \<in> set (unlabel A)")
     case False
     hence "send\<langle>ts\<rangle> \<in> set (unlabel T')"
       using step.prems(3) unfolding T'_def \<theta>_def by simp
     hence "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2) unfolding T'_def by blast
     then obtain y ts' where y:
         "receive\<langle>ts'\<rangle> \<in> set (unlabel (transaction_receive T))"
         "\<theta> y = Var x" "occurs (Var y) \<in> set ts'"
       using transaction_decl_fresh_renaming_substs_occurs_fact_send_receive(2)[
               OF step.hyps(3-5) T_adm]
             subst_to_var_is_var[of _ \<theta> x] step.prems(2)
       unfolding \<theta>_def by (metis eval_term.simps(1))
     hence "occurs (Var y) \<cdot> \<theta> \<in> set ts' \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>"
           "receive\<langle>ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using subst_lsst_unlabel_member[of "receive\<langle>ts'\<rangle>" "transaction_receive T" \<theta>]
       by fastforce+
     hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> occurs (Var y) \<cdot> \<theta> \<cdot> I"
       using wellformed_transaction_sem_receives[
               OF T_wf, of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I" "set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I)" \<theta> I "ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"]
             \<I>_is_T_model
       unfolding T'_def list_all_iff by fastforce
     hence *: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> occurs (\<theta> y \<cdot> I)"
       by auto
 
     have "occurs (\<theta> y \<cdot> I) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       using deduct_occurs_in_ik[OF *]
             reachable_constraints_occurs_fact_ik_subst[
               OF step.hyps(1) welltyped_constraint_model_prefix[OF step.prems(1)] P P_occ,
               of "\<theta> y \<cdot> I"]
             reachable_constraints_occurs_fact_ik_funs_terms[
               OF step.hyps(1) welltyped_constraint_model_prefix[OF step.prems(1)] P P_occ]
       by blast
     thus ?thesis using y(2) by simp
   qed (simp add: step.IH[OF welltyped_constraint_model_prefix[OF step.prems(1)]] step.prems(2))
 qed simp
 
 lemma reachable_constraints_occurs_fact_deduct_in_ik:
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and k: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> occurs k"
   shows "occurs k \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
     and "occurs k \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 using reachable_constraints_occurs_fact_ik_funs_terms(1-3)[OF \<A>_reach \<I> P P_occ]
       reachable_constraints_occurs_fact_ik_subst[OF \<A>_reach \<I> P P_occ]
       deduct_occurs_in_ik[OF k]
 by (presburger, presburger)
 
 lemma reachable_constraints_fv_bvars_subset:
   assumes A: "A \<in> reachable_constraints P"
   shows "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<subseteq> (\<Union>T \<in> set P. bvars_transaction T)"
 using assms
 proof (induction A rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   let ?T' = "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   show ?case
     using step.IH step.hyps(2)
           bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of ?T']
           bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           bvars\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?T')"]
           unlabel_append[of \<A> "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?T'"]
     by (metis (no_types, lifting) SUP_upper Un_subset_iff)
 qed simp
 
 lemma reachable_constraints_fv_disj:
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes A: "A \<in> reachable_constraints P"
   shows "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<inter> (\<Union>T \<in> set P. bvars_transaction T) = {}"
 using A
 proof (induction A rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   define T' where "T' \<equiv> transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" 
   define X where "X \<equiv> \<Union>T \<in> set P. bvars_transaction T"
   have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<inter> X = {}"
     using transaction_decl_fresh_renaming_substs_vars_disj(4)[OF step.hyps(3-5)]
           transaction_decl_fresh_renaming_substs_vars_subset(4)[OF step.hyps(3-5,2)]
     unfolding T'_def X_def by blast
   hence "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<inter> X = {}"
     using step.IH[unfolded X_def[symmetric]] fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of T'] by auto
   thus ?case unfolding T'_def X_def by blast
 qed simp
 
 (* TODO: this lemma subsumes reachable_constraints_fv_bvars_disj *)
 lemma reachable_constraints_fv_bvars_disj':
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes P: "\<forall>T \<in> set P. wellformed_transaction T"
     and A: "A \<in> reachable_constraints P"
   shows "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = {}"
 using A
 proof (induction A rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   note 0 = transaction_decl_fresh_renaming_substs_vars_disj[OF step.hyps(3-5)]
   note 1 = transaction_decl_fresh_renaming_substs_vars_subset[OF step.hyps(3-5)]
 
   have 2: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = {}" 
     using 0(7) 1(4)[OF step.hyps(2)] fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq
     unfolding T'_def by (metis (no_types) disjoint_iff_not_equal subset_iff)
 
   have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> \<Union>(bvars_transaction ` set P)"
        "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> \<Union>(bvars_transaction ` set P) = {}"
     using reachable_constraints_fv_bvars_subset[OF reachable_constraints.step[OF step.hyps]]
           reachable_constraints_fv_disj[OF reachable_constraints.step[OF step.hyps]]
     unfolding T'_def by auto
   hence 3: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = {}" by blast
   
   have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<inter> bvars_transaction T = {}"
     using 0(4)[OF step.hyps(2)] 1(4)[OF step.hyps(2)] by blast
   hence 4: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = {}"
     by (metis (no_types) T'_def fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq
               unlabel_subst bvars\<^sub>s\<^sub>s\<^sub>t_subst)
 
   have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') = {}"
     using 2 3 4 step.IH
     unfolding unlabel_append[of \<A> T']
               fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel T'"]
               bvars\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel T'"]
     by fast
   thus ?case unfolding T'_def by blast
 qed simp
 
 lemma reachable_constraints_wf:
   assumes P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
     and A: "A \<in> reachable_constraints P"
   shows "wf\<^sub>s\<^sub>s\<^sub>t (unlabel A)"
     and "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
 proof -
   let ?X = "\<lambda>T. fst ` set (transaction_decl T ()) \<union> set (transaction_fresh T)"
 
   have "wellformed_transaction T"
     when "T \<in> set P" for T
     using P(1) that by fast+
   hence 0: "wf'\<^sub>s\<^sub>s\<^sub>t (?X T) (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
            "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) = {}"
            "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms_transaction T)"
     when T: "T \<in> set P" for T
     unfolding admissible_transaction_terms_def
     by (metis T wellformed_transaction_wf\<^sub>s\<^sub>s\<^sub>t(1),
         metis T wellformed_transaction_wf\<^sub>s\<^sub>s\<^sub>t(2) fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq,
         metis T wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code P(2))
 
   from A have "wf\<^sub>s\<^sub>s\<^sub>t (unlabel A) \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   proof (induction A rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     let ?T' = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
     have IH: "wf'\<^sub>s\<^sub>s\<^sub>t {} (unlabel A)" "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = {}" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       using step.IH by metis+
 
     have 1: "wf'\<^sub>s\<^sub>s\<^sub>t {} (unlabel (A@?T'))"
       using transaction_decl_fresh_renaming_substs_wf_sst[OF 0(1)[OF step.hyps(2)] step.hyps(3-5)]
             wf\<^sub>s\<^sub>s\<^sub>t_vars_mono[of "{}"] wf\<^sub>s\<^sub>s\<^sub>t_append[OF IH(1)]
       by simp
 
     have 2: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@?T') \<inter> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@?T') = {}"
       using reachable_constraints_fv_bvars_disj'[OF P(1)]
             reachable_constraints.step[OF step.hyps]
       by blast
 
     have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?T')"
       using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unlabel_subst
             wf_trms_subst[
               OF transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)],
               THEN wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_trms\<^sub>s\<^sub>s\<^sub>t_subst,
               OF 0(3)[OF step.hyps(2)]]
       by metis
     hence 3: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@?T'))"
       using IH(3) by auto
 
     show ?case using 1 2 3 by force
   qed simp
   thus "wf\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" by metis+
 qed
 
 lemma reachable_constraints_no_Ana_attack:
   assumes \<A>: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. wellformed_transaction T"
            "\<forall>T \<in> set P. admissible_transaction_terms T"
            "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T).
               \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     and t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "attack\<langle>n\<rangle> \<notin> set (snd (Ana t))"
 proof -
   have T_adm_term: "admissible_transaction_terms T" when "T \<in> set P" for T
     using P that by blast
 
   have T_wf: "wellformed_transaction T" when "T \<in> set P" for T
     using P that by blast
 
   have T_fresh: "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     when "T \<in> set P" for T
     using P(3) that by fast
 
   show ?thesis
   using \<A> t
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>) thus ?case
     proof (cases "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)")
       case False
       hence "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
         using step.prems by simp
       hence "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
         using dual_transaction_ik_is_transaction_send'[OF T_wf[OF step.hyps(2)]]
         by metis
       hence "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
         using transaction_decl_fresh_renaming_substs_trms[
                 OF step.hyps(3-5), of "transaction_send T"]
               wellformed_transaction_unlabel_cases(4)[OF T_wf[OF step.hyps(2)]]
         by fastforce
       then obtain s where s: "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))" "t = s \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
-        by moura
+        by force
       hence s': "attack\<langle>n\<rangle> \<notin> set (snd (Ana s))"
         using admissible_transaction_no_Ana_Attack[OF T_adm_term[OF step.hyps(2)]]
               trms_transaction_unfold[of T]
         by blast
 
       note * = transaction_decl_fresh_renaming_substs_range'(1-3)[OF step.hyps(3-5)]
                transaction_decl_fresh_renaming_substs_range_no_attack_const[
                  OF step.hyps(3-5) T_fresh[OF step.hyps(2)]]
 
       show ?thesis
       proof
         assume n: "attack\<langle>n\<rangle> \<in> set (snd (Ana t))"
         thus False
         proof (cases s)
           case (Var x)
           hence "(\<exists>c. t = Fun c []) \<or> (\<exists>y. t = Var y)"
             using *(1)[of t] n s(2) by (force simp del: subst_subst_compose)
           thus ?thesis using n Ana_subterm' by fastforce
         next
           case (Fun f S)
           hence "attack\<langle>n\<rangle> \<in> set (snd (Ana s)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
             using Ana_subst'[of f S _ "snd (Ana s)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] s(2) s' n
             by (cases "Ana s") auto
           hence "attack\<langle>n\<rangle> \<in> set (snd (Ana s)) \<or> attack\<langle>n\<rangle> \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
             using const_mem_subst_cases' by fast
           thus ?thesis using *(4) s' by fast
         qed
       qed
     qed simp
   qed simp
 qed
 
 lemma reachable_constraints_receive_attack_if_attack:
   assumes \<A>: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. wellformed_transaction T"
            "\<forall>T \<in> set P. admissible_transaction_terms T"
            "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T).
               \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
            "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and l: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> attack\<langle>l\<rangle>"
   shows "attack\<langle>l\<rangle> \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     and "receive\<langle>[attack\<langle>l\<rangle>]\<rangle> \<in> set (unlabel \<A>)"
     and "\<forall>T \<in> set P. \<forall>s \<in> set (transaction_strand T).
               is_Send (snd s) \<and> length (the_msgs (snd s)) = 1 \<and>
               is_Fun_Attack (hd (the_msgs (snd s)))
               \<longrightarrow> the_Attack_label (the_Fun (hd (the_msgs (snd s)))) = fst s
          \<Longrightarrow> (l,receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set \<A>" (is "?Q \<Longrightarrow> (l,receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set \<A>")
 proof -
   have \<I>': "constr_sem_stateful \<I> (unlabel \<A>)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
            "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     using \<I> unfolding welltyped_constraint_model_def constraint_model_def by metis+
 
   have 0: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>)"
     when \<A>: "\<A> \<in> reachable_constraints P" for \<A>
     using reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s[OF _ \<A>] admissible_transaction_terms_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(2)
           ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset[of "unlabel \<A>"] wf_trms_subst[OF \<I>'(3)]
     by fast
 
   have 1: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>). \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x"
     when \<A>: "\<A> \<in> reachable_constraints P" for \<A>
     using reachable_constraints_vars_not_attack_typed[OF \<A> P(3,4)]
           fv_ik_subset_vars_sst'[of "unlabel \<A>"]
     by fast
 
   have 2: "attack\<langle>l\<rangle> \<notin> set (snd (Ana t)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" when t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" for t
   proof
     assume "attack\<langle>l\<rangle> \<in> set (snd (Ana t)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
-    then obtain s where s: "s \<in> set (snd (Ana t))" "s \<cdot> \<I> = attack\<langle>l\<rangle>" by moura
+    then obtain s where s: "s \<in> set (snd (Ana t))" "s \<cdot> \<I> = attack\<langle>l\<rangle>" by force
 
     obtain x where x: "s = Var x"
       by (cases s) (use s reachable_constraints_no_Ana_attack[OF \<A> P(1-3) t] in auto)
 
     have "x \<in> fv t" using x Ana_subterm'[OF s(1)] vars_iff_subtermeq by force
     hence "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" using t fv_subterms by fastforce
     hence "\<Gamma>\<^sub>v x \<noteq> TAtom AttackType" using 1[OF \<A>] by fastforce
     thus False using s(2) x wt_subst_trm''[OF \<I>'(4), of "Var x"] by fastforce
   qed
 
   have 3: "attack\<langle>l\<rangle> \<notin> set (snd (Ana t))" when t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>)" for t
   proof
     assume "attack\<langle>l\<rangle> \<in> set (snd (Ana t))"
     then obtain s where s:
         "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (\<I> ` fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))" "attack\<langle>l\<rangle> \<in> set (snd (Ana s))"
       using Ana_subst_subterms_cases[OF t] 2 by fast
-    then obtain x where x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" "s \<sqsubseteq> \<I> x" by moura
+    then obtain x where x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" "s \<sqsubseteq> \<I> x" by force
     hence "\<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>)"
       using var_is_subterm[of x] subterms_subst_subset'[of \<I> "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"]
       by force
     hence *: "wf\<^sub>t\<^sub>r\<^sub>m (\<I> x)" "wf\<^sub>t\<^sub>r\<^sub>m s"
       using wf_trms_subterms[OF 0[OF \<A>]] wf_trm_subtermeq[OF _ x(2)]
       by auto
 
     show False
       using term.order_trans[
               OF subtermeq_imp_subtermtypeeq[OF *(2) Ana_subterm'[OF s(2)]]
                  subtermeq_imp_subtermtypeeq[OF *(1) x(2)]]
             1[OF \<A>] x(1) wt_subst_trm''[OF \<I>'(4), of "Var x"]
       by force
   qed
 
   have 4: "t = attack\<langle>n\<rangle>"
     when t: "t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = attack\<langle>n\<rangle>"
       and hyps: "transaction_decl_subst \<xi> T"
                 "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
                 "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       and T: "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     for t n
       and T::"('fun, 'atom, 'sets, 'lbl) prot_transaction"
       and \<xi> \<sigma> \<alpha>::"('fun, 'atom, 'sets, 'lbl) prot_subst"
       and \<A>::"('fun, 'atom, 'sets, 'lbl) prot_strand"
   proof (cases t)
     case (Var x)
     hence "attack\<langle>n\<rangle> \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       by (metis (no_types, lifting) t eval_term.simps(1) subst_imgI term.distinct(1))  
     thus ?thesis
       using transaction_decl_fresh_renaming_substs_range_no_attack_const[OF hyps T]
       by blast
   qed (use t in simp)
 
   have 5: "\<exists>ts'. ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta> \<and> (l,send\<langle>ts'\<rangle>) \<in> set (transaction_strand T)"
     when ts: "(l,receive\<langle>ts\<rangle>) \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     for l ts \<theta> and T::"('fun, 'atom, 'sets, 'lbl) prot_transaction"
     using subst_lsst_memD(2)[OF ts[unfolded dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(1)[symmetric]]]
     by auto
 
   have 6: "l' = l" when "(l',receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set \<A>" and Q: "?Q" for l'
     using \<A> that(1)
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>) show ?case
     proof (cases "(l',receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set \<A>")
       case False
       hence *: "(l',receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
         using step.prems by simp
       have "(l',send\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set (transaction_strand T)"
         using 4[OF _ step.hyps(3-5)] P(3) step.hyps(2) 5[OF *] by force
       thus ?thesis using Q step.hyps(2) unfolding is_Fun_Attack_def by fastforce
     qed (use step.IH in simp)
   qed simp
 
   have 7: "\<exists>t. ts = [t] \<and> t = attack\<langle>l\<rangle>"
     when ts: "receive\<langle>ts\<rangle> \<in> set (unlabel \<A>)" "attack\<langle>l\<rangle> \<in> set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" for ts
     using \<A> ts(1)
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     obtain t where t: "t \<in> set ts" "attack\<langle>l\<rangle> = t \<cdot> \<I>" using ts(2) by blast
     hence t_in_ik: "t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> @ dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       using step.prems(1) in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of t] by blast
 
     have t_attack_eq: "t = attack\<langle>l\<rangle>"
     proof (cases t)
       case (Var x) 
       hence "TAtom AttackType \<notin> subterms (\<Gamma> t)"
         using t_in_ik 1[OF reachable_constraints.step[OF step.hyps]] by fastforce
       thus ?thesis using t(2) wt_subst_trm''[OF \<I>'(4), of t] by force
     qed (use t(2) in simp)
 
     show ?case
     proof (cases "receive\<langle>ts\<rangle> \<in> set (unlabel \<A>)")
       case False
       then obtain l' where l':
           "(l', receive\<langle>ts\<rangle>) \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
         using step.prems(1) unfolding unlabel_def by force
       then obtain ts' where ts':
           "ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "(l', send\<langle>ts'\<rangle>) \<in> set (transaction_strand T)"
         using 5 by meson
       then obtain t' where t': "t' \<in> set ts'" "t' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = attack\<langle>l\<rangle>"
         using t(1) t_attack_eq by force
 
       note * = t'(1) 4[OF t'(2) step.hyps(3-5)]
 
       have "send\<langle>ts'\<rangle> \<in> set (unlabel (transaction_strand T))"
         using ts'(2) step.hyps(2) P(2) unfolding unlabel_def by force
       hence "length ts' = 1"
         using step.hyps(2) P(2,3) * unfolding admissible_transaction_terms_def by fastforce
       hence "ts' = [attack\<langle>l\<rangle>]" using * P(3) step.hyps(2) by (cases ts') auto
       thus ?thesis by (simp add: ts'(1))
     qed (use step.IH in simp)
   qed simp
 
   show "attack\<langle>l\<rangle> \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     using private_const_deduct[OF _ l] 3 by simp
   then obtain ts where ts: "receive\<langle>ts\<rangle> \<in> set (unlabel \<A>)" "attack\<langle>l\<rangle> \<in> set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     using in_ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t_iff[of _ \<A>] unfolding unlabel_def by force
   then obtain t where "ts = [t]" "t = attack\<langle>l\<rangle>"
     using 7 by blast
   thus "receive\<langle>[attack\<langle>l\<rangle>]\<rangle> \<in> set (unlabel \<A>)"
     using ts(1) by blast
   hence "\<exists>l'. (l', receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set \<A>"
     unfolding unlabel_def by fastforce
   thus "(l,receive\<langle>[attack\<langle>l\<rangle>]\<rangle>) \<in> set \<A>" when ?Q
     using that 6 by fast
 qed
 
 lemma reachable_constraints_receive_attack_if_attack':
   assumes \<A>: "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and n: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> attack\<langle>n\<rangle>"
   shows "attack\<langle>n\<rangle> \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     and "receive\<langle>[attack\<langle>n\<rangle>]\<rangle> \<in> set (unlabel \<A>)"
 proof -
   have P': "\<forall>T \<in> set P. wellformed_transaction T"
            "\<forall>T \<in> set P. admissible_transaction_terms T"
            "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
            "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x"
     using admissible_transaction_is_wellformed_transaction(1,4)[OF bspec[OF P]]
           admissible_transactionE(2,15)[OF bspec[OF P]]
     by (blast, blast, blast, blast)
 
   show "attack\<langle>n\<rangle> \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "receive\<langle>[attack\<langle>n\<rangle>]\<rangle> \<in> set (unlabel \<A>)"
     using reachable_constraints_receive_attack_if_attack(1,2)[OF \<A> P'(1,2) _ P'(4) \<I> n] P'(3)
     by (metis, metis)
 qed
 
 lemma constraint_model_Value_term_is_Val:
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and x: "\<Gamma>\<^sub>v x = TAtom Value" "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   shows "\<exists>n. I x = Fun (Val n) []"
 using reachable_constraints_occurs_fact_send_ex[OF \<A>_reach P P_occ x]
       reachable_constraints_occurs_fact_send_in_ik[OF \<A>_reach \<I> P P_occ]
       reachable_constraints_occurs_fact_ik_case[OF \<A>_reach P P_occ]
 by fast
 
 lemma constraint_model_Value_term_is_Val':
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model I A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and x: "(TAtom Value, m) \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   shows "\<exists>n. I (TAtom Value, m) = Fun (Val n) []"
 using constraint_model_Value_term_is_Val[OF \<A>_reach \<I> P P_occ _ x] by simp
 
 (* We use this lemma to show that fresh constants first occur in \<I>(\<A>) at the point where they were generated *)
 lemma constraint_model_Value_var_in_constr_prefix:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
   shows "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow> (\<exists>B. prefix B \<A> \<and> x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<and> \<I> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
     (is "\<forall>x \<in> ?X \<A>. ?R x \<longrightarrow> ?Q x \<A>")
 using \<A>_reach \<I>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   let ?P = "\<lambda>\<A>. \<forall>x \<in> ?X \<A>. ?R x \<longrightarrow> ?Q x \<A>"
 
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   have IH: "?P \<A>" using step welltyped_constraint_model_prefix by fast
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF bspec[OF P step.hyps(2)] step.hyps(3)]
 
   have T_adm: "admissible_transaction' T" by (metis P step.hyps(2))
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have \<I>_is_T_model: "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) (set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)) (unlabel T') \<I>"
     using step.prems unlabel_append[of \<A> T'] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>" \<I> "[]"]
           strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "unlabel T'" \<I>]
     by (simp add: T'_def welltyped_constraint_model_def constraint_model_def db\<^sub>s\<^sub>s\<^sub>t_def)
 
   have \<I>_interp: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
     by (metis \<I> welltyped_constraint_model_def constraint_model_def,
         metis \<I> welltyped_constraint_model_def,
         metis \<I> welltyped_constraint_model_def constraint_model_def)
 
   have 1: "?Q x \<A>" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<Gamma>\<^sub>v x = TAtom Value" for x
   proof -
     obtain n where n: "\<I> x = Fun n []" "is_Val n" "\<not>public n"
       using constraint_model_Value_term_is_Val[
               OF reachable_constraints.step[OF step.hyps] step.prems P P_occ x(2)]
             x(1) fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel T'"] unlabel_append[of \<A> T']
-      unfolding T'_def by moura
+      unfolding T'_def by force
 
     have "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using x(1) fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unfolding T'_def by fastforce
     then obtain y where y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)" "x \<in> fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y)"
       using fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var[of x "unlabel (transaction_strand T)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
       by auto
 
     have y_x: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y = Var x" and y_not_fresh: "y \<notin> set (transaction_fresh T)"
       using y(2) transaction_decl_fresh_renaming_substs_range[OF step.hyps(3-5), of y]
       by (force, fastforce)
 
     have "\<Gamma> ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y) = TAtom Value" using x(2) y_x by simp
     moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       by (rule transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)])
     ultimately have y_val: "\<Gamma>\<^sub>v y = TAtom Value"
       by (metis wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def \<Gamma>.simps(1))
 
     have "Fun n [] = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>" using n y_x by simp
     hence y_n: "Fun n [] = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>) y"
       by (metis subst_subst_compose[of "Var y" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I>] eval_term.simps(1))
 
     have \<A>_ik_\<I>_vals: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>). \<exists>f. \<I> x = Fun f []"
     proof -
       have "\<exists>a. \<Gamma> (\<I> x) = Var a" when "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" for x
         using that reachable_constraints_vars_TAtom_typed[OF step.hyps(1) P, of x]
               vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"] wt_subst_trm''[OF \<I>_wt, of "Var x"]
         by force
       hence "\<exists>f. \<I> x = Fun f []" when "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" for x
         using that wf_trm_subst[OF \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s, of "Var x"] wf_trm_Var[of x] const_type_inv_wf
               empty_fv_exists_fun[OF interpretation_grounds[OF \<I>_interp], of "Var x"] 
         by (metis eval_term.simps(1)[of _ x \<I>])
       thus ?thesis
         using fv_ik_subset_fv_sst'[of "unlabel \<A>"] vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"]
         by blast
     qed
     hence \<A>_subterms_subst_cong: "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) = subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
       by (metis ik\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel \<A>" \<I>] unlabel_subst[of \<A> \<I>] subterms_subst_lsst_ik[of \<A> \<I>])
 
     have x_nin_\<A>: "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
     proof -
       have "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
         using x(1) fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unfolding T'_def by fast
       hence "x \<in> fv\<^sub>s\<^sub>s\<^sub>t ((unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<sigma>) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>)"
         using transaction_fresh_subst_grounds_domain[OF step.hyps(4)] step.hyps(4)
               labeled_stateful_strand_subst_comp[of \<sigma> "transaction_strand T" \<alpha>]
               unlabel_subst[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<sigma>" \<alpha>]
               unlabel_subst[of "transaction_strand T" \<sigma>]
         by (simp add: \<xi>_empty transaction_fresh_subst_def range_vars_alt_def)
       then obtain y where "\<alpha> y = Var x"
         using transaction_renaming_subst_var_obtain(1)[OF step.hyps(5)] by blast
       thus ?thesis
         using transaction_renaming_subst_range_notin_vars[OF step.hyps(5), of y]
               vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"]
         by auto
     qed
 
     from admissible_transaction_fv_in_receives_or_selects[OF T_adm y(1) y_not_fresh]
     have n_cases: "Fun n [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<or> (\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<Gamma>\<^sub>v z = TAtom Value \<and> \<I> z = Fun n [])"
     proof
       assume y_in: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
       then obtain ts where ts:
           "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))" "y \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts)"
         using admissible_transaction_strand_step_cases(1)[OF T_adm]
         by force
       hence ts_deduct: "list_all (\<lambda>t. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I>) ts"
         using wellformed_transaction_sem_receives[
                 OF T_wf, of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I> "ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
               \<I>_is_T_model
               subst_lsst_unlabel_member[of "receive\<langle>ts\<rangle>" "transaction_receive T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
         unfolding T'_def list_all_iff by force
 
       obtain ty where ty: "ty \<in> set ts" "y \<in> fv ty" using ts(2) by fastforce
       
       have "Fun n [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<or> (\<exists>z \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>). \<Gamma>\<^sub>v z = TAtom Value \<and> \<I> z = Fun n [])"
       proof -
         have "Fun n [] \<sqsubseteq> ty \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I>"
           using imageI[of "Var y" "subterms ty" "\<lambda>x. x \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>"]
                 var_is_subterm[OF ty(2)] subterms_subst_subset[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>" ty]
                 subst_subst_compose[of ty "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I>] y_n
           by (auto simp del: subst_subst_compose)
         hence "Fun n [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
           using ty(1) private_fun_deduct_in_ik[of _ _ n "[]"] n(2,3) ts_deduct
           unfolding is_Val_def is_Abs_def list_all_iff by fast
         hence "Fun n [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<or> (\<exists>z \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>). \<I> z = Fun n [])"
           using const_subterm_subst_cases[of n _ \<I>] \<A>_ik_\<I>_vals by fastforce
         thus ?thesis
           using \<I>_wt n(2) unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def is_Val_def is_Abs_def by force
       qed
       thus ?thesis
         using fv_ik_subset_fv_sst' ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset[of "unlabel \<A>"] \<A>_subterms_subst_cong
         by fast
     next
       assume y_in: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
                     (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> y \<in> fv t \<union> fv s)"
       then obtain s where s: "select\<langle>Var y,Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))"
         using admissible_transaction_strand_step_cases(2)[OF T_adm] by force
       hence "select\<langle>(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y, Fun (Set s) []\<rangle> \<in>
               set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
         using subst_lsst_unlabel_member
         by fastforce
       hence n_in_db: "(Fun n [], Fun (Set s) []) \<in> set (db'\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> [])"
         using wellformed_transaction_sem_pos_checks(1)[
                 OF T_wf, of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I>
                                assign "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y" "Fun (Set s) []"]
               \<I>_is_T_model n y_x
         unfolding T'_def db\<^sub>s\<^sub>s\<^sub>t_def
         by fastforce
 
       obtain tn sn where tsn: "insert\<langle>tn,sn\<rangle> \<in> set (unlabel \<A>)" "Fun n [] = tn \<cdot> \<I>"
         using db\<^sub>s\<^sub>s\<^sub>t_in_cases[OF n_in_db] by force
 
       have "Fun n [] = tn \<or> (\<exists>z. \<Gamma>\<^sub>v z = TAtom Value \<and> tn = Var z)"
         using \<I>_wt tsn(2) n(2) unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def is_Val_def is_Abs_def by (cases tn) auto
       moreover have "tn \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" "fv tn \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
         using tsn(1) in_subterms_Union by force+
       ultimately show ?thesis using tsn(2) by auto
     qed
 
     from n_cases show ?thesis
     proof
       assume "\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<Gamma>\<^sub>v z = TAtom Value \<and> \<I> z = Fun n []"
       then obtain B where B: "prefix B \<A>" "Fun n [] \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
         by (metis IH n(1))
       thus ?thesis
         using n x_nin_\<A> trms\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset(1)[of B]
         by (metis (no_types, opaque_lifting) self_append_conv subset_iff subterms\<^sub>s\<^sub>e\<^sub>t_mono prefix_def)
     qed (use n x_nin_\<A> in fastforce)
   qed
 
   have "?P (\<A>@T')"
   proof (intro ballI impI)
     fix x assume x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T')" "\<Gamma>\<^sub>v x = TAtom Value"
     show "?Q x (\<A>@T')"
     proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>")
       case False
       hence "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" using x(1) unlabel_append[of \<A>] fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] by simp
       then obtain B where B: "prefix B \<A>" "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" "\<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
-        using x(2) 1 by moura
+        using x(2) 1 by blast
       thus ?thesis using prefix_prefix by fast
     qed (use x(2) IH prefix_prefix in fast)
   qed
   thus ?case unfolding T'_def by blast
 qed simp
 
 lemma constraint_model_Val_const_in_constr_prefix:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and P: "\<forall>T \<in> set P. wellformed_transaction T"
            "\<forall>T \<in> set P. admissible_transaction_terms T"
     and n: "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
   shows "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
 proof -
   have *: "wf\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)"
           "constr_sem_stateful \<I> (unlabel \<A>)"
           "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
           "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
           "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     using reachable_constraints_wf(1)[OF P(1) _ \<A>_reach]
           admissible_transaction_terms_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s \<I> P(2) n
     unfolding welltyped_constraint_model_def constraint_model_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code by fast+
 
   show ?thesis
     using constraint_model_priv_const_in_constr_prefix[OF * _ _ n]
     by simp
 qed
 
 lemma constraint_model_Val_const_in_constr_prefix':
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and n: "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
   shows "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
 using constraint_model_Val_const_in_constr_prefix[OF \<A>_reach \<I> _ _ n]
       P admissible_transaction_is_wellformed_transaction(1,4)
 by fast
 
 lemma constraint_model_Value_in_constr_prefix_fresh_action':
   fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction_terms T"
            "\<forall>T \<in> set P. transaction_decl T () = []"
            "\<forall>T \<in> set P. bvars_transaction T = {}"
     and n: "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   obtains B T \<xi> \<sigma> \<alpha> where "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
     and "B \<in> reachable_constraints P" "T \<in> set P" "transaction_decl_subst \<xi> T"
         "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)" "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
     and "Fun (Val n) [] \<in> subst_range \<sigma>"
 proof -
   define f where "f \<equiv>
     \<lambda>(T::('fun, 'atom, 'sets, 'lbl) prot_transaction,
       \<xi>::('fun, 'atom, 'sets, 'lbl) prot_subst,
       \<sigma>::('fun, 'atom, 'sets, 'lbl) prot_subst,
       \<alpha>::('fun, 'atom, 'sets, 'lbl) prot_subst).
         dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   define g where "g \<equiv> concat \<circ> map f"
 
   obtain Ts where Ts:
       "A = g Ts" "\<forall>B. prefix B Ts \<longrightarrow> g B \<in> reachable_constraints P"
       "\<forall>B T \<xi> \<sigma> \<alpha>. prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts \<longrightarrow>
                         T \<in> set P \<and> transaction_decl_subst \<xi> T \<and>
                         transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B)) \<and>
                         transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
     using reachable_constraints_as_transaction_lists[OF A] unfolding g_def f_def by blast
 
   obtain T \<xi> \<sigma> \<alpha> where T:
       "(T, \<xi>, \<sigma>, \<alpha>) \<in> set Ts" "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using n trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unlabel_subst
     unfolding Ts(1) g_def f_def unlabel_def trms\<^sub>s\<^sub>s\<^sub>t_def
     by fastforce
   
   obtain B where B:
       "prefix (B@[(T, \<xi>, \<sigma>, \<alpha>)]) Ts" "g B \<in> reachable_constraints P" "T \<in> set P"
       "transaction_decl_subst \<xi> T" "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
       "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g B))"
   proof -
     obtain B where "\<exists>C. B@(T, \<xi>, \<sigma>, \<alpha>)#C = Ts" by (metis T(1) split_list)
     thus ?thesis using Ts(2-) that[of B] by auto
   qed
 
   note T_adm_terms = bspec[OF P(1) B(3)]
   note T_decl_empty = bspec[OF P(2) B(3)]
   note T_no_bvars = bspec[OF P(3) B(3)]
   note \<xi>_empty = admissible_transaction_decl_subst_empty'[OF T_decl_empty B(4)]
 
   have "trms\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = trms_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     using trms\<^sub>s\<^sub>s\<^sub>t_subst[of _ "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] T_no_bvars by blast
   hence "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     by (metis T(2) unlabel_subst)
   hence "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using admissible_transaction_terms_no_Value_consts(1)[OF T_adm_terms]
           const_subterms_subst_cases'[of "Val n" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "trms_transaction T"]
     by blast
   then obtain tn where tn: "tn \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" "Fun (Val n) [] \<sqsubseteq> tn" "is_Fun tn"
     by fastforce
 
   have "Fun (Val n) [] \<in> subst_range \<sigma>"
     using tn(1-) transaction_decl_fresh_renaming_substs_range'(2,4)[OF B(4-6) tn(1) \<xi>_empty]
     by fastforce
   moreover have "prefix (g B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
     using Ts(1) B(1) unfolding g_def f_def prefix_def by fastforce
   ultimately show thesis using that B(2-) by blast
 qed
 
 lemma constraint_model_Value_in_constr_prefix_fresh_action:
   fixes P::"('fun, 'atom, 'sets, 'lbl) prot_transaction list"
   assumes A: "A \<in> reachable_constraints P"
     and P_adm: "\<forall>T \<in> set P. admissible_transaction' T"
     and n: "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   obtains B T \<xi> \<sigma> \<alpha> where "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
     and "B \<in> reachable_constraints P" "T \<in> set P" "transaction_decl_subst \<xi> T"
         "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)" "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
     and "Fun (Val n) [] \<in> subst_range \<sigma>"
 proof -
   have P: "\<forall>T \<in> set P. admissible_transaction_terms T"
           "\<forall>T \<in> set P. transaction_decl T () = []"
           "\<forall>T \<in> set P. bvars_transaction T = {}"
   using P_adm admissible_transactionE(1) admissible_transaction_no_bvars(2)
         admissible_transaction_is_wellformed_transaction(4)
   by (blast,blast,blast)
 
   show ?thesis using that constraint_model_Value_in_constr_prefix_fresh_action'[OF A P n] by blast
 qed
 
 lemma reachable_constraints_occurs_fact_ik_case':
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and val: "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   shows "occurs (Fun (Val n) []) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 proof -
   obtain B T \<xi> \<sigma> \<alpha> where B:
       "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
       "B \<in> reachable_constraints P"
       "T \<in> set P"
       "transaction_decl_subst \<xi> T"
       "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       "Fun (Val n) [] \<in> subst_range \<sigma>"
     using constraint_model_Value_in_constr_prefix_fresh_action[OF \<A>_reach P val]
     by blast
 
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   have T_adm: "admissible_transaction' T" using P B(3) by blast
   hence T_wf: "wellformed_transaction T" "admissible_transaction_occurs_checks T"
     using admissible_transaction_is_wellformed_transaction(1) bspec[OF P_occ B(3)] by (blast,blast)
 
   obtain x where x: "x \<in> set (transaction_fresh T)" "\<theta> x = Fun (Val n) []"
     using transaction_fresh_subst_domain[OF B(5)] B(7)
           admissible_transaction_decl_subst_empty[OF T_adm B(4)]
     by (force simp add: subst_compose \<theta>_def)
 
   obtain ts where ts: "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))" "occurs (Var x) \<in> set ts"
     using admissible_transaction_occurs_checksE2[OF T_wf(2) x(1)]
     by (metis (mono_tags, lifting) list.set_intros(1) unlabel_Cons(1))
 
   have "occurs (Var x) \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
     using ts by force
   hence "occurs (Var x) \<cdot> \<theta> \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     using dual_transaction_ik_is_transaction_send'[OF T_wf(1), of \<theta>] by fast
   hence "occurs (Fun (Val n) []) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     using x(2) by simp
   thus ?thesis
     using B(1)[unfolded \<theta>_def[symmetric]]
           unlabel_append[of B "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"]
           ik\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel B" "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"]
     unfolding prefix_def by force
 qed
 
 lemma reachable_constraints_occurs_fact_ik_case'':
   fixes A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "A \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> A"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and val: "Fun (Val n) [] \<sqsubseteq> t" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t"
   shows "occurs (Fun (Val n) []) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 proof -
   obtain f ts where t: "t = Fun f ts" using val(1) by (cases t) simp_all
 
   show ?thesis
     using private_fun_deduct_in_ik[OF val(2,1)[unfolded t]]
           constraint_model_Val_const_in_constr_prefix'[OF \<A>_reach \<I> P, of n]
           reachable_constraints_occurs_fact_ik_case'[OF \<A>_reach P P_occ, of n]
     by fastforce
 qed
 
 lemma admissible_transaction_occurs_checks_prop:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and f: "f \<in> \<Union>(funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
   shows "\<not>is_PubConstValue f"
     and "\<not>is_Abs f"
 proof -
-  obtain x where x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "f \<in> funs_term (\<I> x)" using f by moura
-  obtain T where T: "Fun f T \<sqsubseteq> \<I> x" using funs_term_Fun_subterm[OF x(2)] by moura
+  obtain x where x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "f \<in> funs_term (\<I> x)" using f by force
+  obtain T where T: "Fun f T \<sqsubseteq> \<I> x" using funs_term_Fun_subterm[OF x(2)] by force
 
   have \<I>_interp: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
     by (metis \<I> welltyped_constraint_model_def constraint_model_def,
         metis \<I> welltyped_constraint_model_def,
         metis \<I> welltyped_constraint_model_def constraint_model_def)
 
   note 0 = x(1) reachable_constraints_vars_TAtom_typed[OF \<A>_reach P, of x] 
            vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"]
 
   have 1: "\<Gamma> (Var x) = \<Gamma> (\<I> x)" using wt_subst_trm''[OF \<I>_wt, of "Var x"] by simp
   hence "\<exists>a. \<Gamma> (\<I> x) = Var a" using 0 by force
   hence "\<exists>f. \<I> x = Fun f []"
     using x(1) wf_trm_subst[OF \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s, of "Var x"] wf_trm_Var[of x] const_type_inv_wf
           empty_fv_exists_fun[OF interpretation_grounds[OF \<I>_interp], of "Var x"] 
     by (metis eval_term.simps(1)[of _ x \<I>])
   hence 2: "\<I> x = Fun f []" using x(2) by force
 
   have 3: "\<Gamma>\<^sub>v x \<noteq> TAtom AbsValue" using 0 by force
 
   have "\<not>is_PubConstValue f \<and> \<not>is_Abs f"
   proof (cases "\<Gamma>\<^sub>v x = TAtom Value")
     case True
     then obtain B where B: "prefix B \<A>" "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" "\<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       using constraint_model_Value_var_in_constr_prefix[OF \<A>_reach \<I> P P_occ] x(1)
       by fast
   
     have "\<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       using B(1,3) trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel B"] unlabel_append[of B]
       unfolding prefix_def by auto
     hence "f \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       using x(2) funs_term_subterms_eq(2)[of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"] by blast
     thus ?thesis
       using reachable_constraints_val_funs_private[OF \<A>_reach P]
       by blast+
   next
     case False thus ?thesis using x 1 2 3 unfolding is_PubConstValue_def by (cases f) auto
   qed
   thus "\<not>is_PubConstValue f" "\<not>is_Abs f" by metis+
 qed
 
 lemma admissible_transaction_occurs_checks_prop':
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and f: "f \<in> \<Union>(funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
   shows "\<nexists>n. f = PubConst Value n"
     and "\<nexists>n. f = Abs n"
 using admissible_transaction_occurs_checks_prop[OF \<A>_reach \<I> P P_occ f]
 unfolding is_PubConstValue_def by auto
 
 lemma transaction_var_becomes_Val:
   assumes \<A>_reach: "\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and T: "T \<in> set P"
     and x: "x \<in> fv_transaction T" "fst x = TAtom Value"
   shows "\<exists>n. Fun (Val n) [] = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I>"
 proof -
   obtain m where m: "x = (TAtom Value, m)" by (metis x(2) eq_fst_iff)
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF bspec[OF P T] \<xi>]
 
   have x_not_bvar: "x \<notin> bvars_transaction T" "fv ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x) \<inter> bvars_transaction T = {}"
     using x(1) admissible_transactions_fv_bvars_disj[OF P] T
           transaction_decl_fresh_renaming_substs_vars_disj(2)[OF \<xi> \<sigma> \<alpha>, of x]
           vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
     by (blast, blast)
 
   have \<sigma>x_type: "\<Gamma> (\<sigma> x) = TAtom Value"
     using \<sigma> x \<Gamma>\<^sub>v_TAtom''(2)[of x] wt_subst_trm''[of \<sigma> "Var x"]
     unfolding transaction_fresh_subst_def by simp
 
   show ?thesis
   proof (cases "x \<in> subst_domain \<sigma>")
     case True
     then obtain c where c: "\<sigma> x = Fun c []" "\<not>public c" "arity c = 0"
       using \<sigma> unfolding transaction_fresh_subst_def by fastforce
     then obtain n where n: "c = Val n" using \<sigma>x_type by (cases c) (auto split: option.splits)
     show ?thesis using c n subst_compose[of \<sigma> \<alpha> x] \<xi>_empty by simp
   next
     case False
     hence "\<sigma> x = Var x" by auto
     then obtain n where n: "(\<sigma> \<circ>\<^sub>s \<alpha>) x = Var (TAtom Value, n)"
       using m transaction_renaming_subst_is_renaming(1)[OF \<alpha>] subst_compose[of \<sigma> \<alpha> x]
       by force
     hence "(TAtom Value, n) \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using x_not_bvar fv\<^sub>s\<^sub>s\<^sub>t_subst_fv_subset[OF x(1), of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] \<xi>_empty
       by force
     hence "\<exists>n'. \<I> (TAtom Value, n) = Fun (Val n') []"
       using constraint_model_Value_term_is_Val'[OF \<A>_reach \<I> P P_occ, of n] x
             fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] unlabel_append[of \<A>]
       by fastforce
     thus ?thesis using n \<xi>_empty by simp
   qed
 qed
 
 lemma reachable_constraints_SMP_subset:
   assumes \<A>: "\<A> \<in> reachable_constraints P"
   shows "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<subseteq> SMP (\<Union>T \<in> set P. trms_transaction T)" (is "?A \<A>")
     and "SMP (pair`setops\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)) \<subseteq> SMP (\<Union>T\<in>set P. pair`setops_transaction T)" (is "?B \<A>")
 proof -
   have "?A \<A> \<and> ?B \<A>" using \<A>
   proof (induction \<A> rule: reachable_constraints.induct)
     case (step A T \<xi> \<sigma> \<alpha>)
     define T' where "T' \<equiv> transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     define M where "M \<equiv> \<Union>T \<in> set P. trms_transaction T"
     define N where "N \<equiv> \<Union>T \<in> set P. pair ` setops_transaction T"
   
     let ?P = "\<lambda>t. \<exists>s \<delta>. s \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> t = s \<cdot> \<delta>"
     let ?Q = "\<lambda>t. \<exists>s \<delta>. s \<in> N \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> t = s \<cdot> \<delta>"
   
     have IH: "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<subseteq> SMP M" "SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)) \<subseteq> SMP N"
       using step.IH by (metis M_def, metis N_def)
   
     note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
     note \<xi>\<sigma>\<alpha>_wf = transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
 
     have 0: "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')) = SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<union> SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
             "SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'))) =
               SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)) \<union> SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel T'))"
       using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of T']
             setops\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of T']
             trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A" "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"]
             setops\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A" "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"]
             unlabel_append[of A "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"]
             image_Un[of pair "setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "setops\<^sub>s\<^sub>s\<^sub>t (unlabel T')"]
             SMP_union[of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"]
             SMP_union[of "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel T')"]
       by argo+
   
     have 1: "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<subseteq> SMP M"
     proof (intro SMP_subset_I ballI)
       fix t show "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<Longrightarrow> ?P t"
         using trms\<^sub>s\<^sub>s\<^sub>t_wt_subst_ex[OF \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_wf, of t "unlabel (transaction_strand T)"]
               unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] step.hyps(2)
         unfolding T'_def M_def by auto
     qed
   
     have 2: "SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel T')) \<subseteq> SMP N"
     proof (intro SMP_subset_I ballI)
       fix t show "t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel T') \<Longrightarrow> ?Q t"
         using setops\<^sub>s\<^sub>s\<^sub>t_wt_subst_ex[OF \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_wf, of t "unlabel (transaction_strand T)"]
               unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] step.hyps(2)
         unfolding T'_def N_def by auto
     qed
   
     have "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')) \<subseteq> SMP M"
          "SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'))) \<subseteq> SMP N"
       using 0 1 2 IH by blast+
     thus ?case unfolding T'_def M_def N_def by blast
   qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def)
   thus "?A \<A>" "?B \<A>" by metis+
 qed
 
 lemma reachable_constraints_no_Pair_fun':
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
            "\<forall>T \<in> set P. transaction_decl T () = []"
            "\<forall>T \<in> set P. admissible_transaction_terms T"
            "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
   shows "Pair \<notin> \<Union>(funs_term ` SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))"
 using A
 proof (induction A rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   note T_fresh_type = bspec[OF P(1) step.hyps(2)]
 
   note \<xi>_empty =
     admissible_transaction_decl_subst_empty'[OF bspec[OF P(2) step.hyps(2)] step.hyps(3)]
 
   note T_adm_terms = bspec[OF P(3) step.hyps(2)]
 
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
   note \<xi>\<sigma>\<alpha>_wf = transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
 
   have 0: "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T')) = SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<union> SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
     using SMP_union[of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"]
           unlabel_append[of A T'] trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A" "unlabel T'"]
     by simp
 
   have 1: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
     using reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s[OF _ reachable_constraints.step[OF step.hyps]]
           admissible_transaction_terms_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(3)
           trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A"] unlabel_append[of A]
     unfolding T'_def by force
 
   have 2: "Pair \<notin> \<Union>(funs_term ` (subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)))"
     using transaction_decl_fresh_renaming_substs_range'(3)[
             OF step.hyps(3-5) _ \<xi>_empty T_fresh_type]
     by force
 
   have "Pair \<notin> \<Union>(funs_term ` (trms_transaction T))"
     using T_adm_terms unfolding admissible_transaction_terms_def by blast
   hence "Pair \<notin> funs_term t"
     when t: "t \<in> trms\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" for t
     using 2 trms\<^sub>s\<^sub>s\<^sub>t_funs_term_cases[OF t]
     by force
   hence 3: "Pair \<notin> funs_term t" when t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for t
     using t unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     unfolding T'_def by metis
 
   have "\<exists>a. \<Gamma>\<^sub>v x = TAtom a" when "x \<in> vars_transaction T" for x
     using that protocol_transaction_vars_TAtom_typed(1) bspec[OF P(4) step.hyps(2)]
     by fast
   hence "\<exists>a. \<Gamma>\<^sub>v x = TAtom a" when "x \<in> vars\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" for x
     using wt_subst_fv\<^sub>s\<^sub>e\<^sub>t_termtype_subterm[OF _ \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_wf, of x "vars_transaction T"]
           vars\<^sub>s\<^sub>s\<^sub>t_subst_cases[OF that]
     by fastforce
   hence "\<exists>a. \<Gamma>\<^sub>v x = TAtom a" when "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for x
     using that unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           vars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     unfolding T'_def
     by simp
   hence "\<exists>a. \<Gamma>\<^sub>v x = TAtom a" when "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')" for x
     using that fv_trms\<^sub>s\<^sub>s\<^sub>t_subset(1) by fast
   hence "Pair \<notin> funs_term (\<Gamma> (Var x))" when "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')" for x
     using that by fastforce
   moreover have "Pair \<in> funs_term s"
     when s: "Ana s = (K, M)" "Pair \<in> \<Union>(funs_term ` set K)"
     for s::"('fun,'atom,'sets,'lbl) prot_term" and K M
   proof (cases s)
     case (Fun f S) thus ?thesis using s Ana_Fu_keys_not_pairs[of _ S K M] by (cases f) force+
   qed (use s in simp)
   ultimately have "Pair \<notin> funs_term t" when t: "t \<in> SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')" for t
     using t 3 SMP_funs_term[OF t _ _ 1, of Pair] funs_term_type_iff by fastforce
   thus ?case using 0 step.IH(1) unfolding T'_def by blast
 qed simp
 
 lemma reachable_constraints_no_Pair_fun:
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
   shows "Pair \<notin> \<Union>(funs_term ` SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A))"
 using reachable_constraints_no_Pair_fun'[OF A]
       P admissible_transactionE(1,2,3)
       admissible_transaction_is_wellformed_transaction(4)
 by blast
 
 lemma reachable_constraints_setops_form:
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and t: "t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)"
   shows "\<exists>c s. t = pair (c, Fun (Set s) []) \<and> \<Gamma> c = TAtom Value"
 using A t
 proof (induction A rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>) 
 
   have T_adm: "admissible_transaction' T" when "T \<in> set P" for T
     using P that unfolding list_all_iff by simp
 
   note T_adm' = admissible_transaction_is_wellformed_transaction(2,3)[OF T_adm]
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
   note \<xi>\<sigma>\<alpha>_wf = transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
   
   show ?case using step.IH
   proof (cases "t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)")
     case False
     hence "t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using step.prems setops\<^sub>s\<^sub>s\<^sub>t_append unlabel_append
             setops\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
             unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
       by fastforce
     then obtain t' \<delta> where t':
         "t' \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
         "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "t = t' \<cdot> \<delta>"
       using setops\<^sub>s\<^sub>s\<^sub>t_wt_subst_ex[OF \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_wf] by blast
     then obtain s s' where s: "t' = pair (s,s')"
       using setops\<^sub>s\<^sub>s\<^sub>t_are_pairs by fastforce
     moreover have "InSet ac s s' = InSet Assign s s' \<or> InSet ac s s' = InSet Check s s'" for ac
       by (cases ac) simp_all
     ultimately have "\<exists>n. s = Var (Var Value, n)" "\<exists>u. s' = Fun (Set u) []"
       using t'(1) setops\<^sub>s\<^sub>s\<^sub>t_member_iff[of s s' "unlabel (transaction_strand T)"]
             pair_in_pair_image_iff[of s s']
             transaction_inserts_are_Value_vars[
               OF T_wf[OF step.hyps(2)] T_adm'(2)[OF step.hyps(2)], of s s']
             transaction_deletes_are_Value_vars[
               OF T_wf[OF step.hyps(2)] T_adm'(2)[OF step.hyps(2)], of s s']
             transaction_selects_are_Value_vars[
               OF T_wf[OF step.hyps(2)] T_adm'(1)[OF step.hyps(2)], of s s']
             transaction_inset_checks_are_Value_vars[
               OF T_adm[OF step.hyps(2)], of s s']
             transaction_notinset_checks_are_Value_vars[
               OF T_adm[OF step.hyps(2)], of _ _ _ s s']
       by metis+
     then obtain ss n where ss: "t = pair (\<delta> (Var Value, n), Fun (Set ss) [])"
       using t'(4) s unfolding pair_def by force
 
     have "\<Gamma> (\<delta> (Var Value, n)) = TAtom Value" "wf\<^sub>t\<^sub>r\<^sub>m (\<delta> (Var Value, n))"
       using t'(2) wt_subst_trm''[OF t'(2), of "Var (Var Value, n)"] apply simp
       using t'(3) by (cases "(Var Value, n) \<in> subst_domain \<delta>") auto
     thus ?thesis using ss by blast
   qed simp
 qed (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def)
 
 lemma reachable_constraints_insert_delete_form:
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and t: "insert\<langle>t,s\<rangle> \<in> set (unlabel A) \<or> delete\<langle>t,s\<rangle> \<in> set (unlabel A)" (is "?Q t s A")
   shows "\<exists>k. s = Fun (Set k) []" (is ?A)
     and "\<Gamma> t = TAtom Value" (is ?B)
     and "(\<exists>x. t = Var x) \<or> (\<exists>n. t = Fun (Val n) [])" (is ?C)
 proof -
   have 0: "pair (t,s) \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" using t unfolding setops\<^sub>s\<^sub>s\<^sub>t_def by force
 
   show 1: ?A ?B using reachable_constraints_setops_form[OF A P 0] by (fast,fast)
 
   show ?C using A t
   proof (induction A rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     let ?T' = "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
     note T_adm = bspec[OF P step.hyps(2)]
     note T_wf = admissible_transaction_is_wellformed_transaction(1,3)[OF T_adm]
 
     have "?Q t s \<A> \<or> ?Q t s ?T'"
       using step.prems dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(4,5)[of t s ?T']
       unfolding unlabel_append by auto
     thus ?case
     proof
       assume "?Q t s ?T'"
       then obtain u v where u: "?Q u v (transaction_strand T)" "t = u \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
         by (metis (no_types, lifting) stateful_strand_step_mem_substD(4,5) unlabel_subst)
 
       obtain x where x: "u = Var x"
         using u(1) transaction_inserts_are_Value_vars(1)[OF T_wf, of u v]
               transaction_deletes_are_Value_vars(1)[OF T_wf, of u v]
         by fastforce
 
       show ?case
         using u(2) x
               transaction_decl_fresh_renaming_substs_range'(3)[
                 OF step.hyps(3,4,5) _
                    admissible_transaction_decl_subst_empty[OF T_adm step.hyps(3)]
                    admissible_transactionE(2)[OF T_adm],
                 of t]
         by (cases "t \<in> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)")
            (blast, metis eval_term.simps(1) subst_imgI)
     qed (use step.IH in fastforce)
   qed simp
 qed
 
 lemma reachable_constraints_setops_type:
   fixes t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and t: "t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)"
   shows "\<Gamma> t = TComp Pair [TAtom Value, TAtom SetType]"
 proof -
   obtain s c where s: "t = pair (c, Fun (Set s) [])" "\<Gamma> c = TAtom Value"
-    using reachable_constraints_setops_form[OF A P t] by moura
+    using reachable_constraints_setops_form[OF A P t] by force
   hence "(Fun (Set s) []::('fun,'atom,'sets,'lbl) prot_term) \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
     using t setops\<^sub>s\<^sub>s\<^sub>t_member_iff[of c "Fun (Set s) []" "unlabel A"]
     by force
   hence "wf\<^sub>t\<^sub>r\<^sub>m (Fun (Set s) []::('fun,'atom,'sets,'lbl) prot_term)"
     using reachable_constraints_wf(2) P A admissible_transaction_is_wellformed_transaction(1,4)
     unfolding admissible_transaction_terms_def by blast
   hence "arity (Set s) = 0" unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by simp
   thus ?thesis using s unfolding pair_def by fastforce
 qed
 
 lemma reachable_constraints_setops_same_type_if_unifiable:
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
   shows "\<forall>s \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A). \<forall>t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A).
           (\<exists>\<delta>. Unifier \<delta> s t) \<longrightarrow> \<Gamma> s = \<Gamma> t"
     (is "?P A")
 using reachable_constraints_setops_type[OF A P] by simp
 
 lemma reachable_constraints_setops_unifiable_if_wt_instance_unifiable:
   assumes A: "A \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
   shows "\<forall>s \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A). \<forall>t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A).
           (\<exists>\<sigma> \<theta> \<rho>. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<sigma> \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<sigma>) \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<theta>) \<and>
                    Unifier \<rho> (s \<cdot> \<sigma>) (t \<cdot> \<theta>))
           \<longrightarrow> (\<exists>\<delta>. Unifier \<delta> s t)"
 proof (intro ballI impI)
   fix s t assume st: "s \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" "t \<in> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel A)" and
     "\<exists>\<sigma> \<theta> \<rho>. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<sigma> \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<sigma>) \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<theta>) \<and>
              Unifier \<rho> (s \<cdot> \<sigma>) (t \<cdot> \<theta>)"
   then obtain \<sigma> \<theta> \<rho> where \<sigma>:
       "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<sigma>" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<sigma>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<theta>)"
       "Unifier \<rho> (s \<cdot> \<sigma>) (t \<cdot> \<theta>)"
-    by moura
+    by force
 
   obtain fs ft cs ct where c:
       "s = pair (cs, Fun (Set fs) [])" "t = pair (ct, Fun (Set ft) [])"
       "\<Gamma> cs = TAtom Value" "\<Gamma> ct = TAtom Value" 
     using reachable_constraints_setops_form[OF A P st(1)]
           reachable_constraints_setops_form[OF A P st(2)]
-    by moura
+    by force
 
   have "cs \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" "ct \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     using c(1,2) setops_subterm_trms[OF st(1), of cs] setops_subterm_trms[OF st(2), of ct]
           Fun_param_is_subterm[of cs "args s"] Fun_param_is_subterm[of ct "args t"]
     unfolding pair_def by simp_all
   moreover have
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
     using P admissible_transaction_is_wellformed_transaction(1,4)
     unfolding admissible_transaction_terms_def by fast+
   ultimately have *: "wf\<^sub>t\<^sub>r\<^sub>m cs" "wf\<^sub>t\<^sub>r\<^sub>m ct"
     using reachable_constraints_wf(2)[OF _ _ A] wf_trms_subterms by blast+
 
   have "(\<exists>x. cs = Var x) \<or> (\<exists>c d. cs = Fun c [])"
     using const_type_inv_wf c(3) *(1) by (cases cs) auto
   moreover have "(\<exists>x. ct = Var x) \<or> (\<exists>c d. ct = Fun c [])"
     using const_type_inv_wf c(4) *(2) by (cases ct) auto
   ultimately show "\<exists>\<delta>. Unifier \<delta> s t"
     using reachable_constraints_setops_form[OF A P] reachable_constraints_setops_type[OF A P] st \<sigma> c
     unfolding pair_def by auto
 qed
 
 lemma reachable_constraints_tfr:
   assumes M:
       "M \<equiv> \<Union>T \<in> set P. trms_transaction T"
       "has_all_wt_instances_of \<Gamma> M N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. admissible_transaction T"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and \<A>: "\<A> \<in> reachable_constraints P"
   shows "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)"
 using \<A>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   have P': "\<forall>T \<in> set P. admissible_transaction' T" using P(1) admissible_transactionE'(1) by blast
 
   have AT'_reach: "A@T' \<in> reachable_constraints P"
     using reachable_constraints.step[OF step.hyps] unfolding T'_def by metis
 
   note T_adm = bspec[OF P(1) step.hyps(2)]
   note T_adm' = bspec[OF P'(1) step.hyps(2)]
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm' step.hyps(3)]
 
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
   note \<xi>\<sigma>\<alpha>_wf = transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
 
   have \<xi>\<sigma>\<alpha>_bvars_disj: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}"
     using transaction_decl_fresh_renaming_substs_vars_disj(4)[OF step.hyps(3,4,5,2)] \<xi>_empty
     by simp
 
   have wf_trms_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M"
     using admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P'(1) unfolding M(1) by blast
 
   have "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T'))"
     using reachable_constraints_SMP_subset(1)[OF AT'_reach]
           tfr_subset(3)[OF M(4), of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T')"]
           SMP_SMP_subset[of M N] SMP_I'[OF wf_trms_M M(5,2)]
     unfolding M(1) by blast
   moreover have "\<forall>p. Ana (pair p) = ([],[])" unfolding pair_def by auto
   ultimately have 1: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T') \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T')))"
     using tfr_setops_if_tfr_trms[of "unlabel (A@T')"]
           reachable_constraints_no_Pair_fun[OF AT'_reach P']
           reachable_constraints_setops_same_type_if_unifiable[OF AT'_reach P']
           reachable_constraints_setops_unifiable_if_wt_instance_unifiable[OF AT'_reach P']
     by blast
 
   have "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     using step.hyps(2) P(2) tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p
     unfolding comp_tfr\<^sub>s\<^sub>s\<^sub>t_def tfr\<^sub>s\<^sub>s\<^sub>t_def by fastforce
   hence "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel T')"
     using tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_all_wt_subst_apply[OF _ \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_wf \<xi>\<sigma>\<alpha>_bvars_disj]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     unfolding T'_def by argo
   hence 2: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (A@T'))"
     using step.IH unlabel_append
     unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by auto
 
   have "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T'))" using 1 2 by (metis tfr\<^sub>s\<^sub>s\<^sub>t_def)
   thus ?case by (metis T'_def)
 qed simp
 
 lemma reachable_constraints_tfr':
   assumes M:
       "M \<equiv> \<Union>T \<in> set P. trms_transaction T \<union> pair' Pair ` setops_transaction T"
       "has_all_wt_instances_of \<Gamma> M N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and \<A>: "\<A> \<in> reachable_constraints P"
   shows "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)"
 using \<A>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   have AT'_reach: "A@T' \<in> reachable_constraints P"
     using reachable_constraints.step[OF step.hyps] unfolding T'_def by metis
 
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
   note \<xi>\<sigma>\<alpha>_wf = transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
 
   have \<xi>\<sigma>\<alpha>_bvars_disj: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<inter> range_vars (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = {}"
     by (rule transaction_decl_fresh_renaming_substs_vars_disj(4)[OF step.hyps(3,4,5,2)])
 
   have wf_trms_M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M"
     using P(1) setops\<^sub>s\<^sub>s\<^sub>t_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s(2) unfolding M(1) pair_code wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric] by fast
 
   have "SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T')) \<subseteq> SMP M" "SMP (pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T'))) \<subseteq> SMP M"
     using reachable_constraints_SMP_subset[OF AT'_reach]
           SMP_mono[of "\<Union>T \<in> set P. trms_transaction T" M]
           SMP_mono[of "\<Union>T \<in> set P. pair ` setops_transaction T" M]
     unfolding M(1) pair_code[symmetric] by blast+
   hence 1: "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T') \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T')))"
     using tfr_subset(3)[OF M(4), of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T') \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T'))"]
           SMP_union[of "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@T')" "pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T'))"]
           SMP_SMP_subset[of M N] SMP_I'[OF wf_trms_M M(5,2)]
     by blast
 
   have "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     using step.hyps(2) P(2) tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p
     unfolding comp_tfr\<^sub>s\<^sub>s\<^sub>t_def tfr\<^sub>s\<^sub>s\<^sub>t_def by fastforce
   hence "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel T')"
     using tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_all_wt_subst_apply[OF _ \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_wf \<xi>\<sigma>\<alpha>_bvars_disj]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
           unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
     unfolding T'_def by argo
   hence 2: "list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (A@T'))"
     using step.IH unlabel_append
     unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by auto
 
   have "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel (A@T'))" using 1 2 by (metis tfr\<^sub>s\<^sub>s\<^sub>t_def)
   thus ?case by (metis T'_def)
 qed simp
 
 lemma reachable_constraints_typing_cond\<^sub>s\<^sub>s\<^sub>t:
   assumes M:
       "M \<equiv> \<Union>T \<in> set P. trms_transaction T \<union> pair' Pair ` setops_transaction T"
       "has_all_wt_instances_of \<Gamma> M N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and \<A>: "\<A> \<in> reachable_constraints P"
   shows "typing_cond\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)"
 using reachable_constraints_wf[OF P(1,2) \<A>] reachable_constraints_tfr'[OF M P(2,3) \<A>]
 unfolding typing_cond\<^sub>s\<^sub>s\<^sub>t_def by blast
 
 context
 begin
 private lemma reachable_constraints_typing_result_aux:
   assumes 0: "wf\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)" "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "wf\<^sub>s\<^sub>s\<^sub>t (unlabel (\<A>@[(l,send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]))" "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel (\<A>@[(l,send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]))"
         "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@[(l,send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]))"
 proof -
   let ?n = "[(l,send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]"
   let ?A = "\<A>@?n"
 
   show "wf\<^sub>s\<^sub>s\<^sub>t (unlabel ?A)"
     using 0(1) wf\<^sub>s\<^sub>s\<^sub>t_append_suffix'[of "{}" "unlabel \<A>" "unlabel ?n"] unlabel_append[of \<A> ?n]
     by simp
 
   show "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?A)"
     using 0(3) trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel ?n"] unlabel_append[of \<A> ?n]
     by fastforce
 
   have "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?n \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ?n). \<exists>c. t = Fun c []"
        "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?n \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ?n). Ana t = ([],[])"
     by (simp_all add: setops\<^sub>s\<^sub>s\<^sub>t_def)
   hence "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<union>
                 (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?n \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel ?n)))"
     using 0(2) tfr_consts_mono unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by blast
   hence "tfr\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@?n) \<union> pair ` setops\<^sub>s\<^sub>s\<^sub>t (unlabel (\<A>@?n)))"
     using unlabel_append[of \<A> ?n] trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel ?n"]
           setops\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel ?n"]
     by (simp add: setops\<^sub>s\<^sub>s\<^sub>t_def)
   thus "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel ?A)"
     using 0(2) unlabel_append[of ?A ?n]
     unfolding tfr\<^sub>s\<^sub>s\<^sub>t_def by auto
 qed
 
 lemma reachable_constraints_typing_result:
   fixes P
   assumes M:
       "has_all_wt_instances_of \<Gamma> (\<Union>T \<in> set P. trms_transaction T) N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. admissible_transaction T"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and A: "\<A> \<in> reachable_constraints P"
     and \<I>: "constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
   shows "\<exists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 proof -
   have I:
       "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
       "constr_sem_stateful \<I> (unlabel (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]))"
     using \<I> unfolding constraint_model_def by metis+
 
   note 0 = admissible_transaction_is_wellformed_transaction(1,4)[OF admissible_transactionE'(1)]
 
   have 1: "\<forall>T \<in> set P. wellformed_transaction T"
     using P(1) 0(1) by blast
   
   have 2: "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
     using P(1) 0(2) unfolding admissible_transaction_terms_def by blast
   
   have 3: "wf\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)" "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     using reachable_constraints_tfr[OF _ M P A] reachable_constraints_wf[OF 1(1) 2 A] by metis+
 
   show ?thesis
     using stateful_typing_result[OF reachable_constraints_typing_result_aux[OF 3] I(1,3)]
     by (metis welltyped_constraint_model_def constraint_model_def)
 qed
 
 lemma reachable_constraints_typing_result':
   fixes P
   assumes M:
       "M \<equiv> \<Union>T \<in> set P. trms_transaction T \<union> pair' Pair ` setops_transaction T"
       "has_all_wt_instances_of \<Gamma> M N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and A: "\<A> \<in> reachable_constraints P"
     and \<I>: "constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
   shows "\<exists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 proof -
   have I:
       "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
       "constr_sem_stateful \<I> (unlabel (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]))"
     using \<I> unfolding constraint_model_def by metis+
 
   have 0: "wf\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)" "tfr\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     using reachable_constraints_tfr'[OF M P(2-3) A]
           reachable_constraints_wf[OF P(1,2) A]
     by metis+
 
   show ?thesis
     using stateful_typing_result[OF reachable_constraints_typing_result_aux[OF 0] I(1,3)]
     by (metis welltyped_constraint_model_def constraint_model_def)
 qed
 end
 
 lemma reachable_constraints_transaction_proj:
   assumes "\<A> \<in> reachable_constraints P"
   shows "proj n \<A> \<in> reachable_constraints (map (transaction_proj n) P)"
 using assms
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>) show ?case
     using step.hyps(2) reachable_constraints.step[OF
             step.IH _ transaction_decl_subst_proj[OF step.hyps(3)]
             transaction_fresh_subst_proj[OF step.hyps(4)]
             transaction_renaming_subst_proj[OF step.hyps(5)]]
     by (simp add: proj_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t proj_subst transaction_strand_proj)
 qed (simp add: reachable_constraints.init)
 
 context
 begin
 private lemma reachable_constraints_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_aux:
   fixes P
   defines "Ts \<equiv> concat (map transaction_strand P)"
   assumes A: "A \<in> reachable_constraints P"
   shows "\<forall>b \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A). \<exists>a \<in> set Ts. \<exists>\<delta>. b = a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<delta> \<and>
       wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and>
       (\<forall>t \<in> subst_range \<delta>. (\<exists>x. t = Var x) \<or> (\<exists>c. t = Fun c []))"
     (is "\<forall>b \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A). \<exists>a \<in> set Ts. ?P b a")
 using A
 proof (induction A rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   define Q where "Q \<equiv> ?P"
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   let ?R = "\<lambda>A Ts. \<forall>b \<in> set A. \<exists>a \<in> set Ts. Q b a"
 
   have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<theta>)"
        "\<forall>t \<in> subst_range \<theta>. (\<exists>x. t = Var x) \<or> (\<exists>c. t = Fun c [])"
     using transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
           transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
           transaction_decl_fresh_renaming_substs_range'(1)[OF step.hyps(3-5)]
     unfolding \<theta>_def by (metis,metis,fastforce)
   hence "?R (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) (transaction_strand T)"
     using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_self_inverse[of "transaction_strand T"]
     by (auto simp add: Q_def subst_apply_labeled_stateful_strand_def)
   hence "?R (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) (transaction_strand T)"
     by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst)
   hence "?R (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) Ts"
     using step.hyps(2) unfolding Ts_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by fastforce
   thus ?case using step.IH unfolding Q_def \<theta>_def by auto
 qed simp
 
 lemma reachable_constraints_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t:
   fixes P
   defines "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}}"
     and "Ts \<equiv> concat (map transaction_strand P)"
   assumes P_pc: "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \<Gamma> Pair Ts M S"
     and A: "A \<in> reachable_constraints P"
   shows "par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t A ((f S) - {m. intruder_synth {} m})"
 using par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_if_comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t'[OF P_pc, of "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A", THEN par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t]
       reachable_constraints_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_aux[OF A, unfolded Ts_def[symmetric]]
 unfolding f_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_self_inverse by fast
 end
 
 lemma reachable_constraints_par_comp_constr:
   fixes P f S
   defines "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}}"
     and "Ts \<equiv> concat (map transaction_strand P)"
     and "Sec \<equiv> f S - {m. intruder_synth {} m}"
     and "M \<equiv> \<Union>T \<in> set P. trms_transaction T \<union> pair' Pair ` setops_transaction T"
   assumes M:
       "has_all_wt_instances_of \<Gamma> M N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
       "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \<Gamma> Pair Ts M_fun S"   
     and \<A>: "\<A> \<in> reachable_constraints P"
     and \<I>: "constraint_model \<I> \<A>"
   shows "\<exists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> \<A> \<and>
               ((\<forall>n. welltyped_constraint_model \<I>\<^sub>\<tau> (proj n \<A>)) \<or>
                (\<exists>\<A>' l t. prefix \<A>' \<A> \<and> suffix [(l, receive\<langle>t\<rangle>)] \<A>' \<and> strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' Sec \<I>\<^sub>\<tau>))"
 proof -
   have \<I>': "constr_sem_stateful \<I> (unlabel \<A>)" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     using \<I> unfolding constraint_model_def by blast+
 
   show ?thesis
     using reachable_constraints_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t[OF P(4)[unfolded Ts_def] \<A>]
           reachable_constraints_typing_cond\<^sub>s\<^sub>s\<^sub>t[OF M_def M P(1-3) \<A>]
           par_comp_constr_stateful[OF _ _ \<I>', of Sec]
     unfolding f_def Sec_def welltyped_constraint_model_def constraint_model_def by blast
 qed
 
 lemma reachable_constraints_component_leaks_if_composed_leaks:
   fixes Sec Q
   defines "leaks \<equiv> \<lambda>\<A>. \<exists>\<I>\<^sub>\<tau> \<A>'.
     Q \<I>\<^sub>\<tau> \<and> prefix \<A>' \<A> \<and> (\<exists>l' t. suffix [(l', receive\<langle>t\<rangle>)] \<A>') \<and> strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' Sec \<I>\<^sub>\<tau>"
   assumes Sec: "\<forall>s \<in> Sec. \<not>{} \<turnstile>\<^sub>c s" "ground Sec"
     and composed_leaks: "\<exists>\<A> \<in> reachable_constraints Ps. leaks \<A>"
   shows "\<exists>l. \<exists>\<A> \<in> reachable_constraints (map (transaction_proj l) Ps). leaks \<A>"
 proof -
   from composed_leaks obtain \<A> \<I>\<^sub>\<tau> \<A>' s n where
       \<A>: "\<A> \<in> reachable_constraints Ps" and
       \<A>': "prefix \<A>' \<A>" "constr_sem_stateful \<I>\<^sub>\<tau> (proj_unl n \<A>'@[send\<langle>[s]\<rangle>])" and
       \<I>\<^sub>\<tau>: "Q \<I>\<^sub>\<tau>" and
       s: "s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau>"
     unfolding leaks_def strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by fast
 
   have "\<not>{} \<turnstile>\<^sub>c s" "s \<cdot> \<I>\<^sub>\<tau> = s" using s Sec by auto
   then obtain B k' u where
       "constr_sem_stateful \<I>\<^sub>\<tau> (proj_unl n B@[send\<langle>[s]\<rangle>])"
       "prefix (proj n B) (proj n \<A>)" "suffix [(k', receive\<langle>u\<rangle>)] (proj n B)"
       "s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n B) \<I>\<^sub>\<tau>"
     using constr_sem_stateful_proj_priv_term_prefix_obtain[OF \<A>' s]
     unfolding welltyped_constraint_model_def constraint_model_def by metis
   thus ?thesis
     using \<I>\<^sub>\<tau> reachable_constraints_transaction_proj[OF \<A>, of n] proj_idem[of n B]
     unfolding leaks_def strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def
     by metis
 qed
 
 lemma reachable_constraints_preserves_labels:
   assumes \<A>: "\<A> \<in> reachable_constraints P"
   shows "\<forall>a \<in> set \<A>. \<exists>T \<in> set P. \<exists>b \<in> set (transaction_strand T). fst b = fst a"
     (is "\<forall>a \<in> set \<A>. \<exists>T \<in> set P. ?P T a")
 using \<A>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   have "\<forall>a \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)). ?P T a"
   proof
     fix a assume a: "a \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     then obtain b where b: "b \<in> set (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" "a = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p b"
       unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto
     then obtain c where c: "c \<in> set (transaction_strand T)" "b = c \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       unfolding subst_apply_labeled_stateful_strand_def by auto
 
     have "?P T c" using c(1) by blast
     hence "?P T b" using c(2) by (simp add: subst_lsstp_fst_eq)
     thus "?P T a" using b(2) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p_fst_eq[of b] by presburger
   qed
   thus ?case using step.IH step.hyps(2) by (metis Un_iff set_append)
 qed simp
 
 lemma reachable_constraints_preserves_labels':
   assumes P: "\<forall>T \<in> set P. \<forall>a \<in> set (transaction_strand T). has_LabelN l a \<or> has_LabelS a"
     and \<A>: "\<A> \<in> reachable_constraints P"
   shows "\<forall>a \<in> set \<A>. has_LabelN l a \<or> has_LabelS a"
 using reachable_constraints_preserves_labels[OF \<A>] P by fastforce
 
 lemma reachable_constraints_transaction_proj_proj_eq:
   assumes \<A>: "\<A> \<in> reachable_constraints (map (transaction_proj l) P)"
   shows "proj l \<A> = \<A>"
     and "prefix \<A>' \<A> \<Longrightarrow> proj l \<A>' = \<A>'"
 using \<A>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   let ?T = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   note A = reachable_constraints.step[OF step.hyps]
 
   have P: "\<forall>T \<in> set (map (transaction_proj l) P).
             \<forall>a \<in> set (transaction_strand T). has_LabelN l a \<or> has_LabelS a"
     using transaction_proj_labels[of l] unfolding list_all_iff by auto
 
   note * = reachable_constraints_preserves_labels'[OF P A]
 
   have **: "\<forall>a \<in> set \<A>'. has_LabelN l a \<or> has_LabelS a"
     when "\<forall>a \<in> set B. has_LabelN l a \<or> has_LabelS a" "prefix \<A>' B" for B
     using that assms unfolding prefix_def by auto
 
   note *** = proj_ident[unfolded list_all_iff]
 
   { case 1 thus ?case using *[THEN ***] by blast }
   { case 2 thus ?case using *[THEN **, THEN ***] by blast }
 qed (simp_all add: reachable_constraints.init)
 
 lemma reachable_constraints_transaction_proj_star_proj:
   assumes \<A>: "\<A> \<in> reachable_constraints (map (transaction_proj l) P)"
     and k_neq_l: "k \<noteq> l"
   shows "proj k \<A> \<in> reachable_constraints (map transaction_star_proj P)"
 using \<A>
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   have "map (transaction_proj k) (map (transaction_proj l) P) = map transaction_star_proj P"
     using transaction_star_proj_negates_transaction_proj(2)[OF k_neq_l]
     by fastforce
   thus ?case
     using reachable_constraints_transaction_proj[OF reachable_constraints.step[OF step.hyps], of k]
     by argo
 qed (simp add: reachable_constraints.init)
 
 lemma reachable_constraints_aligned_prefix_ex:
   fixes P
   defines "f \<equiv> \<lambda>T.
     list_all is_Receive (unlabel (transaction_receive T)) \<and>
     list_all is_Check_or_Assignment (unlabel (transaction_checks T)) \<and>
     list_all is_Update (unlabel (transaction_updates T)) \<and>
     list_all is_Send (unlabel (transaction_send T))"
   assumes P: "list_all f P" "list_all ((list_all (Not \<circ> has_LabelS)) \<circ> tl \<circ> transaction_send) P"
     and s: "\<not>{} \<turnstile>\<^sub>c s" "fv s = {}"
     and A: "A \<in> reachable_constraints P" "prefix B A"
     and B: "\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] B"
            "constr_sem_stateful \<I> (unlabel B@[send\<langle>[s]\<rangle>])"
   shows "\<exists>C \<in> reachable_constraints P.
           prefix C A \<and> (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] C) \<and>
           declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<I> = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t C \<I> \<and>
           constr_sem_stateful \<I> (unlabel C@[send\<langle>[s]\<rangle>])"
 using A
 proof (induction A rule: reachable_constraints.induct)
   case (step A T \<xi> \<sigma> \<alpha>)
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   let ?T = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   note AT_reach = reachable_constraints.step[OF step.hyps]
 
   obtain lb tsb B' where B': "B = B'@[(lb, receive\<langle>tsb\<rangle>)]" using B(1) unfolding suffix_def by blast
 
   define decl_ik where "decl_ik \<equiv> \<lambda>S::('fun,'atom,'sets,'lbl) prot_strand.
     \<Union>{set ts |ts. \<langle>\<star>, receive\<langle>ts\<rangle>\<rangle> \<in> set S} \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
 
   have decl_ik_append: "decl_ik (M@N) = decl_ik M \<union> decl_ik N" for M N
     unfolding decl_ik_def by fastforce
 
   have "\<langle>\<star>, receive\<langle>ts\<rangle>\<rangle> \<notin> set N"
     when "\<star> \<notin> fst ` set N" for ts and N::"('fun, 'atom, 'sets, 'lbl) prot_strand"
     using that by force
   hence decl_ik_star: "decl_ik M = decl_ik (M@N)" when "\<star> \<notin> fst ` set N" for M N
     using that unfolding decl_ik_def by simp 
 
   have decl_decl_ik: "declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<I> = {t. decl_ik S \<turnstile> t}" for S
     unfolding declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_alt_def decl_ik_def by blast
 
   have "f T" using P(1) step.hyps(2) by (simp add: list_all_iff)
   hence "list_all is_Send (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
         "list_all is_Check_or_Assignment (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
         "list_all is_Update (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
         "list_all is_Receive (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
     using subst_sst_list_all(2)[of "unlabel (transaction_receive T)" \<theta>]
           subst_sst_list_all(11)[of "unlabel (transaction_checks T)" \<theta>]
           subst_sst_list_all(10)[of "unlabel (transaction_updates T)" \<theta>]
           subst_sst_list_all(1)[of "unlabel (transaction_send T)" \<theta>]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(1)[of "transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(11)[of "transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(10)[of "transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(2)[of "transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
     unfolding f_def by (metis unlabel_subst[of _ \<theta>])+
   hence "\<not>list_ex is_Receive (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
         "\<not>list_ex is_Receive (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
         "\<not>list_ex is_Receive (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
         "list_all is_Receive (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
     unfolding list_ex_iff list_all_iff by blast+
   then obtain TA TB where T:
       "?T = TA@TB" "\<not>list_ex is_Receive (unlabel TA)" "list_all is_Receive (unlabel TB)"
       "TB = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     using transaction_dual_subst_unfold[of T \<theta>] unfolding \<theta>_def by fastforce
 
   have 0: "prefix B (A@TA@TB)" using step.prems B' T by argo
 
   have 1: "prefix B A" when "prefix B (A@TA)"
     using that T(2) B' prefix_prefix_inv
     unfolding list_ex_iff unlabel_def by fastforce
   
   have 2: "\<star> \<notin> fst ` set TB2" when "TB = TB1@(l,x)#TB2" for TB1 l x TB2
   proof -
     have "k \<noteq> \<star>" when "k \<in> set (map fst (tl (transaction_send T)))" for k
       using that P(2) step.hyps(2) unfolding list_all_iff by auto
     hence "k \<noteq> \<star>" when "k \<in> set (map fst (tl TB))" for k
       using that subst_lsst_map_fst_eq[of "tl (transaction_send T)" \<theta>]
             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_map_fst_eq[of "tl (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"]
       unfolding T(4) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_tl subst_lsst_tl by simp
     moreover have "set TB2 \<subseteq> set (tl TB)"
       using that
       by (metis (no_types, lifting) append_eq_append_conv2 order.eq_iff list.sel(3) self_append_conv
                 set_mono_suffix suffix_appendI suffix_tl tl_append2)
     ultimately show ?thesis by auto
   qed
 
   have 3: "declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t TB \<I> = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t (TB1@[(l,x)]) \<I>"
     when "TB = TB1@(l,x)#TB2" for TB1 l x TB2
     using decl_ik_star[OF 2[OF that], of "TB1@[(l,x)]"] unfolding that decl_decl_ik by simp
 
   show ?case
   proof (cases "prefix B A")
     case False
     hence 4: "\<not>prefix B (A@TA)" using 1 by blast
 
     have 5: "\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] (A@?T)"
     proof -
       have "(lb, receive\<langle>tsb\<rangle>) \<in> set TB"
         using 0 4 prefix_prefix_inv[OF _ suffixI[OF B'], of "A@TA" TB] by (metis append_assoc)
       hence "receive\<langle>tsb\<rangle> \<in> set (unlabel TB)"
         unfolding unlabel_def by force
       hence "\<exists>ts. suffix [receive\<langle>ts\<rangle>] (unlabel TB)"
         using T(3) unfolding list_all_iff is_Receive_def suffix_def
         by (metis in_set_conv_decomp list.distinct(1) list.set_cases rev_exhaust)
       then obtain TB' ts where "unlabel TB = TB'@[receive\<langle>ts\<rangle>]" unfolding suffix_def by blast
       then obtain TB'' x where "TB = TB''@[x]" "snd x = receive\<langle>ts\<rangle>"
         by (metis (no_types, opaque_lifting) append1_eq_conv list.distinct(1) rev_exhaust
               rotate1.simps(2) rotate1_is_Nil_conv unlabel_Cons(2) unlabel_append unlabel_nil)
       then obtain l where "suffix [(l, receive\<langle>ts\<rangle>)] TB"
         by (metis surj_pair prod.sel(2) suffix_def)
       thus ?thesis
         using T(4) transaction_dual_subst_unfold[of T \<theta>]
               suffix_append[of "[(l, receive\<langle>ts\<rangle>)]"]
         unfolding \<theta>_def by metis
     qed
 
     obtain TB1 where TB:
         "B = A@TA@TB1@[(lb, receive\<langle>tsb\<rangle>)]" "prefix (TB1@[(lb, receive\<langle>tsb\<rangle>)]) TB"
       using 0 4 B' prefix_snoc_obtain[of B' "(lb, receive\<langle>tsb\<rangle>)" "A@TA" TB thesis]
       by (metis append_assoc)
     then obtain TB2 where TB2: "TB = TB1@(lb, receive\<langle>tsb\<rangle>)#TB2"
       unfolding prefix_def by fastforce
     hence TB2': "list_all is_Receive (unlabel TB2)"
       using T(3) unfolding list_all_iff is_Receive_def proj_def unlabel_def by auto
 
     have 6: "constr_sem_stateful \<I> (unlabel B)" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> s \<cdot> \<I>"
       using B(2) strand_sem_append_stateful[of "{}" "{}" "unlabel B" "[send\<langle>[s]\<rangle>]" \<I>]
       by auto
 
     have "constr_sem_stateful \<I> (unlabel (A@TA@TB1@[(lb, receive\<langle>tsb\<rangle>)]))"
       using 6(1) TB(1) by blast
     hence "constr_sem_stateful \<I> (unlabel (A@?T))"
       using T(1) TB2 strand_sem_receive_prepend_stateful[
               of "{}" "{}" "unlabel (A@TA@TB1@[(lb, receive\<langle>tsb\<rangle>)])" \<I>,
               OF _ TB2']
       by auto
     moreover have "set (unlabel B) \<subseteq> set (unlabel (A@?T))"
       using step.prems(1) unfolding prefix_def by force
     hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@?T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> s \<cdot> \<I>"
       using ideduct_mono[OF 6(2)] subst_all_mono[of _ _ \<I>]
             ik\<^sub>s\<^sub>s\<^sub>t_set_subset[of "unlabel B" "unlabel (A@?T)"]
       by meson
     ultimately have 7: "constr_sem_stateful \<I> (unlabel (A@?T)@[send\<langle>[s]\<rangle>])"
       using strand_sem_append_stateful[of "{}" "{}" "unlabel (A@?T)" "[send\<langle>[s]\<rangle>]" \<I>]
       by auto
 
     have "declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<I> = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@?T) \<I>"
     proof -
       have "declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t TB \<I> = declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t (TB1@[(lb, receive\<langle>tsb\<rangle>)]) \<I>"
         using 3[of _ lb "receive\<langle>tsb\<rangle>"] TB(2) unfolding prefix_def by auto
       hence "(decl_ik TB \<turnstile> t) \<longleftrightarrow> decl_ik (TB1@[(lb,receive\<langle>tsb\<rangle>)]) \<turnstile> t" for t
         unfolding TB(1) T(1) decl_decl_ik by blast
       hence "(decl_ik (A@TA@TB) \<turnstile> t) \<longleftrightarrow> decl_ik (A@TA@TB1@[(lb,receive\<langle>tsb\<rangle>)]) \<turnstile> t" for t
         using ideduct_mono_eq[of "decl_ik TB" "decl_ik (TB1@[(lb,receive\<langle>tsb\<rangle>)])" "decl_ik (A@TA)"]
         by (metis decl_ik_append[of "A@TA"] Un_commute[of _ "decl_ik (A@TA)"] append_assoc)
       thus ?thesis unfolding TB(1) T(1) decl_decl_ik by blast
     qed
     thus ?thesis using step.prems AT_reach B(1) 5 7 by force
   qed (use step.IH prefix_append in blast)
 qed (use B(1) suffix_def in simp)
 
 lemma reachable_constraints_secure_if_filter_secure_case:
   fixes f l n
     and P::"('fun,'atom,'sets,'lbl) prot_transaction list"
   defines "has_attack \<equiv> \<lambda>P.
       \<exists>\<A> \<in> reachable_constraints P. \<exists>\<I>. constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
     and "f \<equiv> \<lambda>T. list_ex (\<lambda>a. is_Update (snd a) \<or> is_Send (snd a)) (transaction_strand T)"
     and "g \<equiv> \<lambda>T. transaction_fresh T = [] \<longrightarrow> f T"
   assumes att: "has_attack P"
   shows "has_attack (filter g P)"
 proof -
   let ?attack = "\<lambda>A I. constraint_model I (A@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 
   define constr' where "constr' \<equiv>
     \<lambda>(T::('fun,'atom,'sets,'lbl) prot_transaction,\<xi>::('fun,'atom,'sets,'lbl) prot_subst,
       \<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>::('fun,'atom,'sets,'lbl) prot_subst).
       dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   define constr where "constr \<equiv> \<lambda>Ts. concat (map constr' Ts)"
 
   define h where "h \<equiv>
     \<lambda>(T::('fun,'atom,'sets,'lbl) prot_transaction,_::('fun,'atom,'sets,'lbl) prot_subst,
       _::('fun,'atom,'sets,'lbl) prot_subst,_::('fun,'atom,'sets,'lbl) prot_subst).
       g T"
 
   obtain A I where A: "A \<in> reachable_constraints P" "?attack A I"
     using att unfolding has_attack_def by blast
 
   obtain Ts where Ts:
       "A = constr Ts"
       "\<forall>B. prefix B Ts \<longrightarrow> constr B \<in> reachable_constraints P"
       "\<forall>B T \<xi> \<sigma> \<alpha>. prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts \<longrightarrow>
           T \<in> set P \<and> transaction_decl_subst \<xi> T \<and>
           transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr B)) \<and>
           transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr B))"
     using reachable_constraints_as_transaction_lists[OF A(1)] constr_def constr'_def by auto
 
   define B where "B \<equiv> constr (filter h Ts)"
 
   have Ts': "T \<in> set P" when "(T,\<xi>,\<sigma>,\<alpha>) \<in> set Ts" for T \<xi> \<sigma> \<alpha>
     using that Ts(3) by (meson prefix_snoc_in_iff) 
 
   have constr_Cons: "constr (p#Ts) = constr' p@constr Ts" for p Ts unfolding constr_def by simp
 
   have constr_snoc: "constr (Ts@[p]) = constr Ts@constr' p" for p Ts unfolding constr_def by simp
 
   have 0: "?attack B I" when A_att: "?attack A I"
   proof -
     have not_f_T_case: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr' p) = {}" "\<And>D. dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (constr' p)) I D = D"
       when not_f_T: "\<not>(f T)" and p: "p = (T,\<xi>,\<sigma>,\<alpha>)" for p T \<xi> \<sigma> \<alpha>
     proof -
       have constr_p: "constr' p = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
         unfolding p constr'_def by fast
 
       have "\<not>is_Receive a" when a: "(l,a) \<in> set (constr' p)" for l a
       proof
         assume "is_Receive a"
         then obtain ts where ts: "a = receive\<langle>ts\<rangle>" by (cases a) auto
         then obtain ts' where ts':
           "(l,send\<langle>ts'\<rangle>) \<in> set (transaction_strand T)" "ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
           using a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(1)[of l ts] subst_lsst_memD(2)[of l _ "transaction_strand T"]
           unfolding constr_p by blast
         thus False using not_f_T unfolding f_def list_ex_iff by fastforce
       qed
       thus "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr' p) = {}" using in_ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t_iff by fastforce
 
       have "\<not>is_Update a" when a: "(l,a) \<in> set (constr' p)" for l a
       proof
         assume "is_Update a"
         then obtain t s where ts: "a = insert\<langle>t,s\<rangle> \<or> a = delete\<langle>t,s\<rangle>" by (cases a) auto
         then obtain t' s' where ts':
           "(l,insert\<langle>t',s'\<rangle>) \<in> set (transaction_strand T) \<or>
                (l,delete\<langle>t',s'\<rangle>) \<in> set (transaction_strand T)"
           "t = t' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "s = s' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
           using a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(4,5)[of l]
             subst_lsst_memD(4,5)[of l _ _ "transaction_strand T"]
           unfolding constr_p by blast
         thus False using not_f_T unfolding f_def list_ex_iff by fastforce
       qed
       thus "\<And>D. dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (constr' p)) I D = D"
         using dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd[of "unlabel (constr' p)" I] by (meson unlabel_mem_has_label) 
     qed
 
     have *: "strand_sem_stateful M D (unlabel B) I"
       when "strand_sem_stateful M D (unlabel A) I" for M D
       using that Ts' unfolding Ts(1) B_def
     proof (induction Ts arbitrary: M D)
       case (Cons p Ts)
       obtain T \<xi> \<sigma> \<alpha> where p: "p = (T,\<xi>,\<sigma>,\<alpha>)" by (cases p) simp
       have T_in: "T \<in> set P" using Cons.prems(2) unfolding p by fastforce
 
       let ?M' = "M \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr' p) \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
       let ?D' = "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (constr' p)) I D"
 
       have p_sem: "strand_sem_stateful M D (unlabel (constr' p)) I"
         and IH: "strand_sem_stateful ?M' ?D' (unlabel (constr (filter h Ts))) I"
         using Cons.IH[of ?M' ?D'] Cons.prems
               strand_sem_append_stateful[of M D "unlabel (constr' p)" "unlabel (constr Ts)" I]
         unfolding constr_Cons unlabel_append by fastforce+
 
       show ?case
       proof (cases "T \<in> set (filter g P)")
         case True
         hence h_p: "filter h (p#Ts) = p#filter h Ts" unfolding h_def p by simp
         show ?thesis
           using p_sem IH strand_sem_append_stateful[of M D "unlabel (constr' p)" _ I]
           unfolding h_p constr_Cons unlabel_append by blast
       next
         case False
         hence not_f: "\<not>(f T)"
           and not_h: "\<not>(h p)"
           using T_in unfolding g_def h_def p by auto
 
         show ?thesis
           using not_h not_f_T_case[OF not_f p] IH
           unfolding constr_Cons unlabel_append by auto
       qed
     qed simp
 
     have **: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
     proof
       show "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
         unfolding Ts(1) B_def constr_def by (induct Ts) (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def)
 
       show "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B" using Ts' unfolding Ts(1) B_def
       proof (induction Ts)
         case (Cons p Ts)
         obtain T \<xi> \<sigma> \<alpha> where p: "p = (T,\<xi>,\<sigma>,\<alpha>)" by (cases p) simp
         have T_in: "T \<in> set P" using Cons.prems unfolding p by fastforce
 
         have IH: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr Ts) \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr (filter h Ts))"
           using Cons.IH Cons.prems by auto
 
         show ?case
         proof (cases "T \<in> set (filter g P)")
           case True
           hence h_p: "filter h (p#Ts) = p#filter h Ts" unfolding h_def p by simp
           show ?thesis
             using IH unfolding h_p constr_Cons unlabel_append ik\<^sub>s\<^sub>s\<^sub>t_append by blast
         next
           case False
           hence not_f: "\<not>(f T)"
             and not_h: "\<not>(h p)"
             using T_in unfolding g_def h_def p by auto
 
           show ?thesis
             using not_h not_f_T_case[OF not_f p] IH
             unfolding constr_Cons unlabel_append by auto
         qed
       qed simp
     qed
 
     show ?thesis
       using A_att *[of "{}" "{}"] ** strand_sem_stateful_if_sends_deduct
             strand_sem_append_stateful[of "{}" "{}" _ "unlabel [(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)]" I]
       unfolding constraint_model_def unlabel_append by force
   qed
 
   have 1: "B \<in> reachable_constraints (filter g P)"
     using A(1) Ts(2,3) unfolding Ts(1) B_def
   proof (induction Ts rule: List.rev_induct)
     case (snoc p Ts)
     obtain T \<xi> \<sigma> \<alpha> where p: "p = (T,\<xi>,\<sigma>,\<alpha>)" by (cases p) simp
 
     have constr_p: "constr' p = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       unfolding constr'_def p by fastforce
 
     have T_in: "T \<in> set P"
       and \<xi>: "transaction_decl_subst \<xi> T"
       and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr Ts))"
       and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr Ts))"
       using snoc.prems(3) unfolding p by fast+
 
     have "transaction_fresh_subst s t bb"
       when "transaction_fresh_subst s t aa" "bb \<subseteq> aa"
       for s t bb aa using that unfolding transaction_fresh_subst_def by fast
           
     have "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr (filter h Ts)) \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr Ts)"
       unfolding constr_def unlabel_def by fastforce
     hence \<sigma>': "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr (filter h Ts)))"
       using \<sigma> unfolding transaction_fresh_subst_def by fast
 
     have "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr (filter h Ts)) \<subseteq> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr Ts)"
       unfolding constr_def unlabel_def vars\<^sub>s\<^sub>s\<^sub>t_def by auto
     hence \<alpha>': "transaction_renaming_subst \<alpha> (filter g P) (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (constr (filter h Ts)))"
       using \<alpha> unfolding transaction_renaming_subst_def by auto
 
     have IH: "constr (filter h Ts) \<in> reachable_constraints (filter g P)"
       using snoc.prems snoc.IH by simp
 
     show ?case
     proof (cases "h p")
       case True
       hence h_p: "filter h (Ts@[p]) = filter h Ts@[p]" by fastforce
       have T_in': "T \<in> set (filter g P)" using T_in True unfolding h_def p by fastforce
       show ?thesis
         using IH reachable_constraints.step[OF IH T_in' \<xi> \<sigma>' \<alpha>']
         unfolding h_p constr_snoc constr_p by fast
     next
       case False thus ?thesis using IH by fastforce
     qed
   qed (simp add: constr_def)
 
   show ?thesis using 0 1 A(2) unfolding has_attack_def by blast
 qed
 
 lemma reachable_constraints_fv_Value_typed:
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and A: "\<A> \<in> reachable_constraints P"
     and x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
   shows "\<Gamma>\<^sub>v x = TAtom Value"
 proof -
   obtain T where T: "T \<in> set P" "\<Gamma>\<^sub>v x \<in> \<Gamma>\<^sub>v ` fv_transaction T"
     using x P(1) reachable_constraints_var_types_in_transactions(1)[OF A(1)]
           admissible_transactionE(2) 
     by blast
 
   show ?thesis
     using T(2) admissible_transactionE(3)[OF bspec[OF P(1) T(1)]]
           vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
     by force
 qed
 
 lemma reachable_constraints_fv_Value_const_cases:
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and A: "\<A> \<in> reachable_constraints P"
     and I: "welltyped_constraint_model \<I> \<A>"
     and x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
   shows "(\<exists>n. \<I> x = Fun (Val n) []) \<or> (\<exists>n. \<I> x = Fun (PubConst Value n) [])"
 proof -
   have x': "\<Gamma> (\<I> x) = TAtom Value" "fv (\<I> x) = {}" "wf\<^sub>t\<^sub>r\<^sub>m (\<I> x)"
     using reachable_constraints_fv_Value_typed[OF P A x] I wt_subst_trm''[of \<I> "Var x"]
     unfolding welltyped_constraint_model_def constraint_model_def by auto
 
   obtain f where f: "arity f = 0" "\<I> x = Fun f []"
     using TAtom_term_cases[OF x'(3,1)] x' const_type_inv_wf[of _ _ Value] by (cases "\<I> x") force+
 
   show ?thesis
   proof (cases f)
     case (Fu g) thus ?thesis by (metis f(2) x'(1) \<Gamma>_Fu_simps(4)[of g "[]"])
   qed (use f x'(1) in auto)
 qed
 
 lemma reachable_constraints_receive_attack_if_attack'':
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and A: "\<A> \<in> reachable_constraints P"
     and wt_attack: "welltyped_constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
   shows "receive\<langle>[attack\<langle>n\<rangle>]\<rangle> \<in> set (unlabel \<A>)"
 proof -
   have I: "welltyped_constraint_model \<I> \<A>"
     using welltyped_constraint_model_prefix wt_attack by blast
 
   show ?thesis
     using wt_attack strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "[send\<langle>[attack\<langle>n\<rangle>]\<rangle>]" \<I>]
           reachable_constraints_receive_attack_if_attack'(2)[OF A(1) P I]
     unfolding welltyped_constraint_model_def constraint_model_def by simp
 qed
 
 context
 begin
 
 private lemma reachable_constraints_initial_value_transaction_aux:
   fixes P::"('fun,'atom,'sets,'lbl) prot" and N::"nat set"
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and A: "A \<in> reachable_constraints P"
     and P':
       "\<forall>T \<in> set P. \<forall>(l,a) \<in> set (transaction_strand T). \<forall>t.
         a \<noteq> select\<langle>t,\<langle>k\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t in \<langle>k\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t not in \<langle>k\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> delete\<langle>t,\<langle>k\<rangle>\<^sub>s\<rangle>"
     shows "(l,\<langle>ac: t \<in> s\<rangle>) \<in> set A \<Longrightarrow> (\<exists>u. s = \<langle>u\<rangle>\<^sub>s \<and> u \<noteq> k)" (is "?A A \<Longrightarrow> ?Q A")
       and "(l,\<langle>t not in s\<rangle>) \<in> set A \<Longrightarrow> (\<exists>u. s = \<langle>u\<rangle>\<^sub>s \<and> u \<noteq> k)" (is "?B A \<Longrightarrow> ?Q A")
       and "(l,delete\<langle>t,s\<rangle>) \<in> set A \<Longrightarrow> (\<exists>u. s = \<langle>u\<rangle>\<^sub>s \<and> u \<noteq> k)" (is "?C A \<Longrightarrow> ?Q A")
 proof -
   have "(?A A \<longrightarrow> ?Q A) \<and> (?B A \<longrightarrow> ?Q A) \<and> (?C A \<longrightarrow> ?Q A)" (is "?D A") using A
   proof (induction A rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     let ?T' = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
     note T_adm = bspec[OF P step.hyps(2)]
     note T_wf = admissible_transaction_is_wellformed_transaction[OF T_adm]
     note T_P' = bspec[OF P' step.hyps(2)]
 
     have 0: "?Q ?T'" when A: "?A ?T'"
     proof -
       obtain t' s' where t:
           "(l, \<langle>ac: t' \<in> s'\<rangle>) \<in> set (transaction_strand T)" "t = t' \<cdot> \<theta>" "s = s' \<cdot> \<theta>"
         using A dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(6) subst_lsst_memD(6) by blast
       obtain u where u: "s' = \<langle>u\<rangle>\<^sub>s"
         using 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']
               unlabel_in[OF t(1)]
         by (cases ac) auto
       show ?thesis using T_P' t(1,3) unfolding u by (cases ac) auto
     qed
 
     have 1: "?Q ?T'" when B: "?B ?T'"
     proof -
       obtain t' s' where t:
           "(l, \<langle>t' not in s'\<rangle>) \<in> set (transaction_strand T)" "t = t' \<cdot> \<theta>" "s = s' \<cdot> \<theta>"
         using B dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(7) subst_lsst_memD(9) by blast
       obtain u where u: "s' = \<langle>u\<rangle>\<^sub>s"
         using transaction_notinset_checks_are_Value_vars(2)[OF T_adm unlabel_in[OF t(1)]]
         by fastforce
       show ?thesis using T_P' t(1,3) unfolding u by auto
     qed
 
     have 2: "?Q ?T'" when C: "?C ?T'"
     proof -
       obtain t' s' where t:
           "(l, delete\<langle>t', s'\<rangle>) \<in> set (transaction_strand T)" "t = t' \<cdot> \<theta>" "s = s' \<cdot> \<theta>"
         using C dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(5) subst_lsst_memD(5) by blast
       obtain u where u: "s' = \<langle>u\<rangle>\<^sub>s"
         using transaction_deletes_are_Value_vars(2)[OF T_wf(1,3) unlabel_in[OF t(1)]] by blast
       show ?thesis using T_P' t(1,3) unfolding u by auto
     qed
 
     show ?case using 0 1 2 step.IH unfolding \<theta>_def by auto
   qed simp
   thus "?A A \<Longrightarrow> ?Q A" "?B A \<Longrightarrow> ?Q A" "?C A \<Longrightarrow> ?Q A" by fast+
 qed
 
 lemma reachable_constraints_initial_value_transaction:
   fixes P::"('fun,'atom,'sets,'lbl) prot" and N::"nat set" and k A T_upds
   defines "checks_not_k \<equiv> \<lambda>B.
             T_upds \<noteq> [] \<longrightarrow> (
              (\<forall>l t s. (l,\<langle>t in s\<rangle>) \<in> set (A@B) \<longrightarrow> (\<exists>u. s = \<langle>u\<rangle>\<^sub>s \<and> u \<noteq> k)) \<and>
              (\<forall>l t s. (l,\<langle>t not in s\<rangle>) \<in> set (A@B) \<longrightarrow> (\<exists>u. s = \<langle>u\<rangle>\<^sub>s \<and> u \<noteq> k)) \<and>
              (\<forall>l t s. (l,delete\<langle>t,s\<rangle>) \<in> set (A@B) \<longrightarrow> (\<exists>u. s = \<langle>u\<rangle>\<^sub>s \<and> u \<noteq> k)))"
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and A: "A \<in> reachable_constraints P"
     and N: "finite N" "\<forall>n \<in> N. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     and T:
       "T \<in> set P" "Var x \<in> set T_ts" "\<Gamma>\<^sub>v x = TAtom Value" "fv\<^sub>s\<^sub>e\<^sub>t (set T_ts) = {x}"
       "\<forall>n. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set T_ts)"
       "T = Transaction (\<lambda>(). []) [x] [] [] T_upds [(l1,send\<langle>T_ts\<rangle>)]"
       "T_upds = [] \<or>
        (T_upds = [(l2,insert\<langle>Var x, \<langle>k\<rangle>\<^sub>s\<rangle>)] \<and>
         (\<forall>T \<in> set P. \<forall>(l,a) \<in> set (transaction_strand T). \<forall>t.
           a \<noteq> select\<langle>t,\<langle>k\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t in \<langle>k\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t not in \<langle>k\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> delete\<langle>t,\<langle>k\<rangle>\<^sub>s\<rangle>))"
   shows "\<exists>B. A@B \<in> reachable_constraints P \<and> B \<in> reachable_constraints P \<and> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B = {} \<and>
              (T_upds = [] \<longrightarrow> list_all is_Receive (unlabel B)) \<and> 
              (T_upds \<noteq> [] \<longrightarrow> list_all (\<lambda>a. is_Insert a \<or> is_Receive a) (unlabel B)) \<and>
              (\<forall>n. Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<longrightarrow> Fun (Val n) [] \<notin> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B) \<and>
              (\<forall>n. Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<longrightarrow> Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B) \<and>
              N = {n. Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B} \<and>
              checks_not_k B \<and>
              (\<forall>l a. (l,a) \<in> set B \<and> is_Insert a \<longrightarrow>
                       (l = l2 \<and> (\<exists>n. a = insert\<langle>Fun (Val n) [],\<langle>k\<rangle>\<^sub>s\<rangle>)))"
     (is "\<exists>B. A@B \<in> ?reach P \<and> B \<in> ?reach P \<and> ?Q1 B \<and> ?Q2 B \<and> ?Q3 B \<and> ?Q4 B \<and> ?Q5 B \<and> ?Q6 N B \<and>
              checks_not_k B \<and> ?Q7 B")
 using N
 proof (induction N rule: finite_induct)
   case empty
   define B where "B \<equiv> []::('fun,'atom,'sets,'lbl) prot_constr"
 
   have 0: "A@B \<in> ?reach P" "B \<in> ?reach P"
     using A unfolding B_def by auto
 
   have 1: "?Q1 B" "?Q2 B" "?Q3 B" "?Q4 B" "?Q6 {} B"
     unfolding B_def by auto
   
   have 2: "checks_not_k B"
     using reachable_constraints_initial_value_transaction_aux[OF P 0(1)] T(7)
     unfolding checks_not_k_def by presburger
 
   have 3: "?Q5 B" "?Q7 B"
     unfolding B_def by simp_all
 
   show ?case using 0 1 2 3 by blast
 next
   case (insert n N)
   obtain B where B:
       "A@B \<in> reachable_constraints P" "B \<in> reachable_constraints P"
       "?Q1 B" "?Q2 B" "?Q3 B" "?Q4 B" "?Q5 B" "?Q6 N B" "checks_not_k B" "?Q7 B"
     using insert.IH insert.prems by blast
 
   define \<xi> where "\<xi> \<equiv> Var::('fun,'atom,'sets,'lbl) prot_subst"
 
   define \<sigma> where "\<sigma> \<equiv> Var(x := Fun (Val n) [])::('fun,'atom,'sets,'lbl) prot_subst"
 
   have \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B))"
   proof (unfold transaction_fresh_subst_def; intro conjI)
     have "subst_range \<sigma> = {Fun (Val n) []}" unfolding \<sigma>_def by simp
     moreover have "Fun (Val n) [] \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B))"
       using insert.prems insert.hyps(2) B(7,8) ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset[of "unlabel B"]
       unfolding unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_append by blast
     ultimately show "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B))" by fastforce
   next
     show "subst_domain \<sigma> = set (transaction_fresh T)" using T(6) unfolding \<sigma>_def by auto
   next
     show "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)"
       using T(5,7) unfolding \<sigma>_def T(6) by fastforce
   qed (force simp add: T(3) \<sigma>_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def)+
   hence \<sigma>': "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
     unfolding transaction_fresh_subst_def by fastforce
 
   have \<xi>: "transaction_decl_subst \<xi> T"
     using T(6) unfolding \<xi>_def transaction_decl_subst_def by fastforce
 
   obtain \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst" where \<alpha>:
       "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B))"
     unfolding transaction_renaming_subst_def by blast
   hence \<alpha>': "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
     unfolding transaction_renaming_subst_def by auto
 
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   define C where "C \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
   have \<theta>x: "\<theta> x = Fun (Val n) []" unfolding \<theta>_def \<xi>_def \<sigma>_def subst_compose by force
 
   have "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = []" "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = []"
     using T(6) unfolding \<theta>_def \<xi>_def \<sigma>_def by auto
   moreover have
       "(T_upds = [] \<and> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = []) \<or>
        (T_upds \<noteq> [] \<and> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = [(l2,insert\<langle>\<theta> x, \<langle>k\<rangle>\<^sub>s\<rangle>)])"
     using subst_lsst_cons[of "(l2,insert\<langle>Var x,\<langle>k\<rangle>\<^sub>s\<rangle>)" "[]" \<theta>] T(6,7) unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst by auto
   hence "(T_upds = [] \<and> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = []) \<or>
          (T_upds \<noteq> [] \<and> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = [(l2,insert\<langle>Fun (Val n) [],\<langle>k\<rangle>\<^sub>s\<rangle>)])"
     unfolding \<theta>_def \<xi>_def \<sigma>_def by (auto simp: subst_compose)
   moreover have "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = [(l1, receive\<langle>T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>)]"
     using subst_lsst_cons[of "(l1, receive\<langle>T_ts\<rangle>)" "[]" \<theta>] T(6) unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst by auto
   hence "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = [(l1, receive\<langle>T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>)]"
     by auto
   ultimately have C:
       "(T_upds = [] \<and> C = [(l1, receive\<langle>T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>)]) \<or>
        (T_upds \<noteq> [] \<and> C = [(l2, insert\<langle>Fun (Val n) [],\<langle>k\<rangle>\<^sub>s\<rangle>), (l1, receive\<langle>T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>)])"
     unfolding C_def transaction_dual_subst_unfold by force
 
   have C': "Fun (Val n) [] \<in> set (T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)" "Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t C"
     using T(2) in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of _ "unlabel C"] C
     unfolding \<theta>_def \<xi>_def \<sigma>_def by (force, force)
 
   have "fv (t \<cdot> \<theta>) = {}" when t: "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set T_ts" for t
   proof -
     have  "fv t \<subseteq> {x}" using t T(4) fv_subset_subterms by blast
     hence "fv (t \<cdot> \<xi> \<circ>\<^sub>s \<sigma>) = {}" unfolding \<xi>_def \<sigma>_def by (induct t) auto
     thus ?thesis unfolding \<theta>_def by (metis subst_ground_ident_compose(2))
   qed
   hence 1: "ground (set (T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>))" by auto
 
   have 2: "m = n" when m: "Fun (Val m) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t C" for m
   proof -
     have "Fun (Val m) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set (T_ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)"
       using m C in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of _ "unlabel C"] by fastforce
     hence *: "Fun (Val m) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set T_ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>" by simp
     show ?thesis using const_subterms_subst_cases[OF *] T(4,5) \<theta>x by fastforce
   qed
 
   have C_trms: "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t C \<subseteq> {Fun (Val n) [],\<langle>k\<rangle>\<^sub>s} \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t C"
     using C in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of _ "unlabel C"] by fastforce
 
   have 3: "m = n" when m: "Fun (Val m) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t C" for m
     using m 2[of m] C_trms by fastforce
 
   have Q1: "?Q1 (B@C)" using B(3) C 1 by auto
   have Q2: "?Q2 (B@C)" using B(4) C by force
   have Q3: "?Q3 (B@C)" using B(5) C by force
   have Q4: "?Q4 (B@C)" using B(6) insert.prems C 2 unfolding unlabel_append ik\<^sub>s\<^sub>s\<^sub>t_append by blast
   have Q5: "?Q5 (B@C)" using B(7) C' 3 unfolding unlabel_append ik\<^sub>s\<^sub>s\<^sub>t_append trms\<^sub>s\<^sub>s\<^sub>t_append by blast
   have Q6: "?Q6 (insert n N) (B@C)" using B(8) C' 2 unfolding unlabel_append ik\<^sub>s\<^sub>s\<^sub>t_append by blast
   have Q7: "?Q7 (B@C)" using B(10) C by fastforce
   have Q8: "checks_not_k (B@C)" using B(9) C unfolding checks_not_k_def by force
 
   have "B@C \<in> reachable_constraints P" "A@B@C \<in> reachable_constraints P"
     using reachable_constraints.step[OF B(1) T(1) \<xi> \<sigma> \<alpha>]
           reachable_constraints.step[OF B(2) T(1) \<xi> \<sigma>' \<alpha>']
     unfolding \<theta>_def[symmetric] C_def[symmetric] by simp_all
   thus ?case using Q1 Q2 Q3 Q4 Q5 Q6 Q7 Q8 by blast
 qed
 
 end
 
 
 subsection \<open>Equivalence Between the Symbolic Protocol Model and a Ground Protocol Model\<close>
 
 context
 begin
 
 subsubsection \<open>Intermediate Step: Equivalence to a Ground Protocol Model with Renaming\<close>
 
 private definition "consts_of X = {t. t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t X \<and> (\<exists>c. t = Fun c [])}"
 
 private fun mk_symb where
   "mk_symb (\<xi>, \<sigma>, I, T, \<alpha>) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t((transaction_strand T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
 private fun T_symb :: " _ \<Rightarrow> ('fun,'atom,'sets,'lbl) prot_constr" where
   "T_symb w = concat (map mk_symb w)"
 
 
 private definition "narrow \<sigma> S = (\<lambda>x. if x \<in> S then \<sigma> x else Var x)"
 
 private fun mk_inv\<alpha>I where
   "mk_inv\<alpha>I n (\<xi>, \<sigma>, I, T) =
     narrow ((var_rename_inv n) \<circ>\<^sub>s I) (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s var_rename n))"
 
 private fun inv\<alpha>I where
   "inv\<alpha>I ns w = foldl (\<circ>\<^sub>s) Var (map2 mk_inv\<alpha>I ns w)"
 
 private fun mk_I where
   "mk_I (\<xi>, \<sigma>, I, T, \<alpha>) = narrow I (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
 
 private fun comb_I where
   "comb_I w = fold (\<circ>\<^sub>s) (map mk_I w) (\<lambda>x. Fun OccursSec [])"
 
 private abbreviation "ground_term t \<equiv> ground {t}"
 
 private lemma ground_term_def2: "ground_term t \<longleftrightarrow> (fv t = {})"
   by auto
 
 private definition "ground_strand s \<equiv> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t s = {}"
 
 private fun ground_step :: "(_, _) stateful_strand_step \<Rightarrow> bool" where
   "ground_step s \<longleftrightarrow> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p s = {}"
 
 private fun ground_lstep :: "_ strand_label \<times> (_, _) stateful_strand_step \<Rightarrow> bool" where
   "ground_lstep (l,s) \<longleftrightarrow> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p s = {}"
 
 
 private inductive_set ground_protocol_states_aux::
   "('fun,'atom,'sets,'lbl) prot \<Rightarrow>
    (('fun,'atom,'sets,'lbl) prot_terms \<times>
     (('fun,'atom,'sets,'lbl) prot_term \<times> ('fun,'atom,'sets,'lbl) prot_term) set
     \<times> _ set \<times> _ set \<times> _ list) set"
   for P::"('fun,'atom,'sets,'lbl) prot"
 where
   init:
   "({},{},{},{},[]) \<in> ground_protocol_states_aux P"
 | step:
   "\<lbrakk>(IK,DB,trms,vars,w) \<in> ground_protocol_states_aux P;
     T \<in> set P;
     transaction_decl_subst \<xi> T;
     transaction_fresh_subst \<sigma> T trms;
     transaction_renaming_subst \<alpha> P vars;
     A = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>);
     strand_sem_stateful IK DB (unlabel A) I;
     interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I;
     wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)
    \<rbrakk> \<Longrightarrow> (IK \<union> ((ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<cdot>\<^sub>s\<^sub>e\<^sub>t I), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB,
           trms \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, vars \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A,
           w@[(\<xi>, \<sigma>, I, T, \<alpha>)]) \<in> ground_protocol_states_aux P"
 
 private lemma T_symb_append':
   " T_symb (w@w') = T_symb w @ T_symb w'"
 proof (induction w arbitrary: w')
   case Nil
   then show ?case
     by auto
 next
   case (Cons a w)
   then show ?case
     by auto
 qed
 
 private lemma T_symb_append:
   "T_symb (w@[(\<xi>, \<sigma>, I, T, \<alpha>)]) = T_symb w @ dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t((transaction_strand T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 using T_symb_append'[of w "[(\<xi>, \<sigma>, I, T,\<alpha>)]"] by auto
 
 private lemma ground_step_subst:
   assumes "ground_step a"
   shows "a = a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<sigma>"
 using assms 
 proof (induction a)
   case (NegChecks Y F F')
   then have FY: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F - set Y = {}"
     unfolding ground_step.simps
     unfolding fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps by auto
   {  
     have "\<forall>t s. (t,s) \<in> set F \<longrightarrow> t \<cdot> (rm_vars (set Y) \<sigma>) = t"
     proof (rule, rule, rule)
       fix t s 
       assume "(t, s) \<in> set F"
       then show "t \<cdot> rm_vars (set Y) \<sigma> = t"
         using FY by fastforce                      
     qed
     moreover
     have "\<forall>t s. (t,s) \<in> set F \<longrightarrow> s \<cdot> (rm_vars (set Y) \<sigma>) = s"
     proof (rule, rule, rule)
       fix t s 
       assume "(t, s) \<in> set F"
       then show "s \<cdot> rm_vars (set Y) \<sigma> = s"
         using FY by fastforce                      
     qed
     ultimately
     have "\<forall>f \<in> set F. f \<cdot>\<^sub>p (rm_vars (set Y) \<sigma>) = f"
       by auto
     then have "F = F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set Y) \<sigma>"
       by (metis (no_types, lifting) map_idI split_cong subst_apply_pairs_def)
   }
   moreover
   from NegChecks have F'Y: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F' - set Y = {}"
     unfolding ground_step.simps
     unfolding fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps by auto
   {  
     have "\<forall>t s. (t,s) \<in> set F' \<longrightarrow> t \<cdot> (rm_vars (set Y) \<sigma>) = t"
     proof (rule, rule, rule)
       fix t s 
       assume "(t, s) \<in> set F'"
       then show "t \<cdot> rm_vars (set Y) \<sigma> = t"
         using F'Y by fastforce                      
     qed
     moreover
     have "\<forall>t s. (t,s) \<in> set F' \<longrightarrow> s \<cdot> (rm_vars (set Y) \<sigma>) = s"
     proof (rule, rule, rule)
       fix t s 
       assume "(t, s) \<in> set F'"
       then show "s \<cdot> rm_vars (set Y) \<sigma> = s"
         using F'Y by fastforce                      
     qed
     ultimately
     have "\<forall>f \<in> set F'. f \<cdot>\<^sub>p (rm_vars (set Y) \<sigma>) = f"
       by auto
     then have "F' = F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set Y) \<sigma>"
       by (simp add: map_idI subst_apply_pairs_def)
   }
   ultimately
   show ?case 
     by simp
 qed (auto simp add: map_idI subst_ground_ident)
 
 private lemma ground_lstep_subst:
   assumes "ground_lstep a"
   shows "a = a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<sigma>"
 using assms by (cases a) (auto simp add: ground_step_subst)
 
 private lemma subst_apply_term_rm_vars_swap:
   assumes "\<forall>x\<in>fv t - set X. I x = I' x"
   shows "t \<cdot> rm_vars (set X) I = t \<cdot> rm_vars (set X) I'"
 using assms by (induction t) auto
 
 private lemma subst_apply_pairs_rm_vars_swap:
   assumes "\<forall>x\<in>\<Union> (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` set ps) - set X. I x = I' x"
   shows "ps \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) I = ps \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) I'"
 proof -
   have "\<forall>p \<in> set ps. p \<cdot>\<^sub>p rm_vars (set X) I = p  \<cdot>\<^sub>p rm_vars (set X) I'"
   proof
     fix p
     assume "p \<in> set ps"
     obtain t s where "p = (t,s)"
       by (cases p) auto
     have "\<forall>x\<in>fv t - set X. I x = I' x"
       by (metis DiffD1 DiffD2 DiffI \<open>p = (t, s)\<close> \<open>p \<in> set ps\<close> assms fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.elims fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_inI(4))
     then have "t \<cdot> rm_vars (set X) I = t \<cdot> rm_vars (set X) I'"
       using subst_apply_term_rm_vars_swap by blast
     have "\<forall>x\<in>fv s - set X. I x = I' x"
       by (metis DiffD1 DiffD2 DiffI \<open>p = (t, s)\<close> \<open>p \<in> set ps\<close> assms fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s.elims fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_inI(5))
     then have "s \<cdot> rm_vars (set X) I = s \<cdot> rm_vars (set X) I'"
       using subst_apply_term_rm_vars_swap by blast
     show "p \<cdot>\<^sub>p rm_vars (set X) I = p \<cdot>\<^sub>p rm_vars (set X) I'"
       using \<open>p = (t, s)\<close> \<open>s \<cdot> rm_vars (set X) I = s \<cdot> rm_vars (set X) I'\<close>
             \<open>t \<cdot> rm_vars (set X) I = t \<cdot> rm_vars (set X) I'\<close>
       by fastforce
   qed
   then show ?thesis
     unfolding subst_apply_pairs_def by auto
 qed
 
 private lemma subst_apply_stateful_strand_step_swap:
   assumes "\<forall>x\<in>fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p T. I x = I' x"
   shows "T \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p I = T  \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p I'"
   using assms
 proof (induction T)
   case (Send ts)
   then show ?case
     using term_subst_eq by fastforce
 next
   case (NegChecks X F G)
   then have "\<forall>x \<in> \<Union>(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` set F) \<union> \<Union>(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` set G) - set X. I x = I' x"
     by auto
   then show ?case
     using subst_apply_pairs_rm_vars_swap[of F]
           subst_apply_pairs_rm_vars_swap[of G]
     by auto
 qed (simp_all add: term_subst_eq_conv)
 
 private lemma subst_apply_labeled_stateful_strand_step_swap:
   assumes "\<forall>x \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd T). I x = I' x"
   shows "T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p I = T  \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p I'"
 using assms subst_apply_stateful_strand_step_swap
 by (metis prod.exhaust_sel subst_apply_labeled_stateful_strand_step.simps) 
 
 private lemma subst_apply_labeled_stateful_strand_swap:
   assumes "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T. I x = I' x"
   shows "T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I = T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I'"
   using assms
 proof (induction T)
   case Nil
   then show ?case
     by auto
 next
   case (Cons a T)
   then show ?case
     using subst_apply_labeled_stateful_strand_step_swap
     by (metis UnCI fv\<^sub>s\<^sub>s\<^sub>t_Cons subst_lsst_cons unlabel_Cons(2))
 qed
 
 private lemma transaction_renaming_subst_not_in_fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t:
   fixes \<xi> \<sigma> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
     and A::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
   assumes "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
   shows "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 proof -
   have 0: "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<alpha>)"
     when x: "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     for x
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
       and \<xi> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst" 
   proof -
     have "x \<notin> range_vars \<alpha>"
       using x \<alpha> transaction_renaming_subst_vars_disj(6) by blast
     moreover
     have "subst_domain \<alpha> = UNIV"
       using \<alpha> transaction_renaming_subst_is_renaming(4) by blast
     ultimately
     show ?thesis
       using subst_fv_dom_img_subset[of _ \<alpha>] fv\<^sub>s\<^sub>s\<^sub>t_subst_obtain_var subst_compose unlabel_subst
       by (metis (no_types, opaque_lifting) subset_iff top_greatest)
   qed
 
   have 1: "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<alpha>)"
     when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     for x
       and A::"('fun,'atom,'sets,'lbl) prot_constr"
       and \<xi> \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
     using \<alpha> x 0 by (metis Un_iff vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t)
 
   show ?thesis using 1 assms by metis
 qed
 
 private lemma wf_comb_I_Nil: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (comb_I []))"
   by auto
 
 private lemma comb_I_append:
   "comb_I (w @ [(\<xi>, \<sigma>, I, T, \<alpha>)]) = (mk_I (\<xi>, \<sigma>, I, T, \<alpha>) \<circ>\<^sub>s (comb_I w))"
 by auto
 
 private lemma reachable_constraints_if_ground_protocol_states_aux:
   assumes "(IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P"
   shows "T_symb w \<in> reachable_constraints P
          \<and> constr_sem_stateful (comb_I w) (unlabel (T_symb w))
          \<and> IK = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((T_symb w) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t (comb_I w))
          \<and> DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel ((T_symb w))) (comb_I w) {}
          \<and> trms = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)
          \<and> vars = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)
          \<and> interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (comb_I w)
          \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (comb_I w))"
   using assms
 proof (induction rule: ground_protocol_states_aux.induct)
   case init
   show ?case
     using wf_comb_I_Nil by auto
 next
   case (step IK DB trms vars w T \<xi> \<sigma> \<alpha> A I)
   then have step': "T_symb w \<in> reachable_constraints P"
     "strand_sem_stateful {} {} (unlabel (T_symb w)) (comb_I w)"
     "IK = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w)"
     "DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {}"
     "trms = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)"
     "vars = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)"
     "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (comb_I w)"
     "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (comb_I w))"
     by auto
 
   define w' where "w' = w @ [(\<xi>, \<sigma>, I, T, \<alpha>)]"
 
   have interps_w: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w). (comb_I w) x = (comb_I w') x"
   proof 
     fix x
     assume "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)"
     then have "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using step(5) transaction_renaming_subst_not_in_fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t unfolding step'(6) by blast
     then have "mk_I (\<xi>, \<sigma>, I, T, \<alpha>) x = Var x"
       unfolding mk_I.simps narrow_def by metis
     then have "comb_I w x = (mk_I (\<xi>, \<sigma>, I, T, \<alpha>) \<circ>\<^sub>s (comb_I (w))) x"
       by (simp add: subst_compose)
     then show "comb_I w x = comb_I w' x"
       unfolding w'_def by auto
   qed
 
   have interps_T: "\<forall>x \<in> fv\<^sub>s\<^sub>s\<^sub>t (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))). I x = (comb_I w') x"
   proof 
     fix x
     assume "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>)))"
     then have a: "x \<in> (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       by (metis fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq mk_symb.simps)
     have "(comb_I w') x = (mk_I (\<xi>, \<sigma>, I, T, \<alpha>) \<circ>\<^sub>s (comb_I (w))) x"
       unfolding w'_def by auto
     also
     have "... = ((mk_I (\<xi>, \<sigma>, I, T, \<alpha>)) x) \<cdot> comb_I w"
       unfolding subst_compose by auto
     also
     have "... = (narrow I (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) x) \<cdot> comb_I w"
       using a by auto
     also
     have "... = (I x) \<cdot> comb_I w"
       by (metis a narrow_def)
     also
     have "... = I x"
       by (metis UNIV_I ground_subst_range_empty_fv step.hyps(8) subst_compose
                 subst_ground_ident_compose(1))
     finally
     show "I x = (comb_I w') x"
       by auto
   qed
 
   have "T_symb w' \<in> reachable_constraints P"
   proof -
     have "T_symb w \<in> reachable_constraints P"
       using step'(1) .
     moreover
     have "T \<in> set P"
       using step(2) by auto
     moreover
     have "transaction_decl_subst \<xi> T"
       using step(3) by auto
     moreover
     have "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w))"
       using step(4) step'(5) by auto
     moreover
     have "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w))"
       using step(5) step'(6) by auto
     ultimately
     have "(T_symb w) @ mk_symb (\<xi>, \<sigma>, I, T, \<alpha>) \<in> reachable_constraints P"
       using reachable_constraints.step[of "T_symb w" P T \<xi> \<sigma> \<alpha>] by auto
     then show "T_symb w' \<in> reachable_constraints P"
       unfolding w'_def by auto
   qed
   moreover
   have "strand_sem_stateful {} {} (unlabel (T_symb w')) (comb_I w')"
   proof -
     have "strand_sem_stateful {} {} (unlabel (T_symb w)) (comb_I w')"
     proof -
       have "strand_sem_stateful {} {} (unlabel (T_symb w)) (comb_I w)"
         using step'(2) by auto
       then show "strand_sem_stateful {} {} (unlabel (T_symb w)) (comb_I w')"
         using interps_w strand_sem_model_swap by blast
     qed
     moreover
     have "strand_sem_stateful
             (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<cdot>\<^sub>s\<^sub>e\<^sub>t comb_I w')
             (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w') {})
             (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>)))
             (comb_I w')"
     proof -
       have "A = (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))"
         unfolding step(6) by auto
       moreover
       have "strand_sem_stateful
               (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w))
               (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {})
               (unlabel A)
               I"
         using step'(3) step'(4) step.hyps(7) by force
       moreover
       {
         have "\<forall>x\<in>fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)). comb_I w x = comb_I w' x"
           using interps_w by (metis fv_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t)
         then have "\<forall>x\<in>fv t. comb_I w x = comb_I w' x" when t: "t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)" for t
           using t by auto
         then have "t \<cdot> comb_I w' = t \<cdot> comb_I w" when t: "t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)" for t
           using t term_subst_eq[of t "comb_I w'" "comb_I w"] by metis
         then have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<cdot>\<^sub>s\<^sub>e\<^sub>t comb_I w' = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<cdot>\<^sub>s\<^sub>e\<^sub>t comb_I w"
           by auto
         also
         have "... = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w)"
           by (metis ik\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst)
         finally
         have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<cdot>\<^sub>s\<^sub>e\<^sub>t comb_I w' = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w)"
           by auto
       }
       moreover
       {
         have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {} =
               dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w') {}"
           by (metis db\<^sub>s\<^sub>s\<^sub>t_subst_swap[OF interps_w] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t empty_set)
       }
       ultimately
       have "strand_sem_stateful
               (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<cdot>\<^sub>s\<^sub>e\<^sub>t comb_I w')
               (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w') {})
               (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>)))
               I"
         by force
       then show "strand_sem_stateful
                   (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<cdot>\<^sub>s\<^sub>e\<^sub>t comb_I w')
                   (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w') {})
                   (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>)))
                   (comb_I w')"
         using interps_T strand_sem_model_swap[of "unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))" I "comb_I w'"]
         by force 
     qed
     ultimately
     show "strand_sem_stateful {} {} (unlabel (T_symb w')) (comb_I w')"
       using strand_sem_append_stateful[
               of "{}" "{}" "unlabel (T_symb w)" "unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))" "(comb_I w')"]
       unfolding w'_def by auto
   qed
   moreover
   have "IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w')"
   proof -
     have AI: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I) = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       by (metis ik\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst)
 
     have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w') = 
            ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w') \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w')"
       unfolding w'_def by (simp add: subst_lsst_append)
     also 
     have "... = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w') \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
       by (metis T_symb_append T_symb_append' interps_T mk_symb.simps self_append_conv2
                 subst_apply_labeled_stateful_strand_swap)
     also
     have "... = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w) \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
       by (metis interps_w subst_apply_labeled_stateful_strand_swap)
     also 
     have "... = IK \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
       using step'(3) step.hyps(6) by auto
     also
     have "... = IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A  \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
       unfolding AI by auto
     finally
     show "IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w')"
       using step'(3) step(6) T_symb.simps mk_symb.simps by auto
   qed
   moreover
   have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w')) (comb_I w') {}"
   proof -
     have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB =
           dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {})"
       using step'(4) by auto
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))) I
                         (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {})"
       using step(6) by auto
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))) I
                         (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {})"
       by auto
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))) (comb_I w')
                         (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {})"
       by (metis (no_types, lifting) db\<^sub>s\<^sub>s\<^sub>t_subst_swap[OF interps_T] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t empty_set)
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))) (comb_I w')
                         (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w') {})"
       by (metis (no_types, lifting) db\<^sub>s\<^sub>s\<^sub>t_subst_swap[OF interps_w] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t empty_set)
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w) @ unlabel (mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))) (comb_I w') {}"
       using dbupd\<^sub>s\<^sub>s\<^sub>t_append by metis
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel ((T_symb w) @ mk_symb (\<xi>, \<sigma>, I, T, \<alpha>))) (comb_I w') {}"
       by auto
     moreover
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w')) (comb_I w') {}"
       unfolding w'_def by auto
     ultimately
     show "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w')) (comb_I w') {}"
       by auto
   qed
   moreover
   have "trms \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
   proof -
     have "trms \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       using step'(5) by auto
     moreover
     have "... = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       using step(6) by auto
     moreover 
     have "... = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)])"
       by auto
     moreover
     have "... = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w @ T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)])"
       by auto
     moreover
     have "... = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
       unfolding w'_def by auto
     ultimately
     show "trms \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
       by auto
   qed
   moreover
   have "vars \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
   proof -
     have "vars \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       using step'(6) by fastforce
     moreover
     have "... = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
       using step(6) by auto
     moreover 
     have "... = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)])"
       by auto
     moreover
     have "... = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w @ T_symb [(\<xi>, \<sigma>, I, T, \<alpha>)])"
       by auto
     moreover
     have "... = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
       unfolding w'_def by auto
     ultimately
     show "vars \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
       using step(6) by auto
   qed
   moreover
   have interp_comb_I_w': "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (comb_I w')"
     using interpretation_comp(1) step'(7) unfolding w'_def by auto
   moreover
   have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (comb_I w'))"
   proof 
     fix t
     assume "t \<in> subst_range (comb_I w')"
     then have "\<exists>x. x \<in> subst_domain (comb_I w') \<and> t = comb_I w' x"
       by auto
     then obtain x where "x \<in> subst_domain (comb_I w')" "t = comb_I w' x"
       by auto
     then show "wf\<^sub>t\<^sub>r\<^sub>m t"
       by (metis (no_types, lifting) w'_def interp_comb_I_w' comb_I_append ground_subst_dom_iff_img
                   mk_I.simps narrow_def step'(8) step.hyps(8) step.hyps(9) subst_compose_def
                   wf_trm_Var wf_trm_subst)
   qed
   ultimately
   show ?case
     unfolding w'_def by auto
 qed
 
 private lemma ground_protocol_states_aux_if_reachable_constraints:
   assumes "A \<in> reachable_constraints P"
   assumes "constr_sem_stateful I (unlabel A)"
   assumes "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
   assumes "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
   shows "\<exists>w. (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I, dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, w)
               \<in> ground_protocol_states_aux P"
 using assms
 proof (induction rule: reachable_constraints.induct)
   case init
   then show ?case
     using ground_protocol_states_aux.init by auto 
 next
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   have "\<exists>w. (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t I, dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) I {}, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>, vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>, w)
               \<in> ground_protocol_states_aux P"
     by (metis local.step(6,7,8,9) step.IH strand_sem_append_stateful unlabel_append)
   then obtain w where w_p:
       "(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t I, dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) I {}, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>, vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>, w)
         \<in> ground_protocol_states_aux P"
     by auto
 
   define w' where "w' = w@[(\<xi>, \<sigma>, I, T, \<alpha>)]"
   define \<A>' where "\<A>' = \<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   let ?T = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
 
   have "T \<in> set P"
     using step.hyps(2) .
   moreover
   have "transaction_decl_subst \<xi> T"
     using step.hyps(3) .
   moreover
   have "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     using step.hyps(4) .
   moreover
   have "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     using step.hyps(5) .
   moreover
   have "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t I) (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) I {}) ?T I"
     using step(7) strand_sem_append_stateful[of "{}"  "{}" "unlabel \<A>" ?T I]
     by auto
   moreover
   have "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
     using assms(3) .
   moreover
   have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
     using step.prems(3) by fastforce
   ultimately
   have "((ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<union> (ik\<^sub>s\<^sub>s\<^sub>t ?T \<cdot>\<^sub>s\<^sub>e\<^sub>t I),
          dbupd\<^sub>s\<^sub>s\<^sub>t ?T I (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) I {}),
          trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> trms\<^sub>s\<^sub>s\<^sub>t ?T,
          vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> vars\<^sub>s\<^sub>s\<^sub>t ?T,
          w@[(\<xi>, \<sigma>, I, T, \<alpha>)])
       \<in> ground_protocol_states_aux P"
     using ground_protocol_states_aux.step[
             OF w_p,
             of T \<xi> \<sigma> \<alpha> "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" I]
     by metis
   moreover
   have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<cdot>\<^sub>s\<^sub>e\<^sub>t I = (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<union> (ik\<^sub>s\<^sub>s\<^sub>t ?T \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
     unfolding \<A>'_def by auto
   moreover
   have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>') I {} = dbupd\<^sub>s\<^sub>s\<^sub>t ?T I (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) I {})"
     unfolding \<A>'_def by (simp add: dbupd\<^sub>s\<^sub>s\<^sub>t_append) 
   moreover
   have "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> trms\<^sub>s\<^sub>s\<^sub>t ?T"
     unfolding \<A>'_def by auto
   moreover
   have "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> vars\<^sub>s\<^sub>s\<^sub>t ?T"
     unfolding \<A>'_def by auto
   ultimately
   have "(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<cdot>\<^sub>s\<^sub>e\<^sub>t I, dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>') I {}, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>', vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>', w')
           \<in> ground_protocol_states_aux P"
     using w'_def by auto
   then show ?case 
     unfolding \<A>'_def w'_def by auto
 qed
 
 private lemma protocol_model_equivalence_aux1:
   "{(IK, DB) | IK DB. \<exists>w trms vars. (IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P} = 
    {(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}) | A I.
       A \<in> reachable_constraints P \<and> strand_sem_stateful {} {} (unlabel A) I \<and>
       interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)}"
 proof (rule; rule; rule)
   fix IK DB
   assume "(IK, DB) \<in>
             {(IK, DB) | IK DB. \<exists>w trms vars. (IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P}"
   then have "\<exists>w trms vars. (IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P"
     by auto
   then obtain w trms vars where "(IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P"
     by auto
   then have reachable:
       "T_symb w \<in> reachable_constraints P"
       "strand_sem_stateful {} {} (unlabel (T_symb w)) (comb_I w)"
       "IK = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t comb_I w)"
       "DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {}"
       "trms = trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)"
       "vars = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)" 
       "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (comb_I w)"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (comb_I w))"
     using reachable_constraints_if_ground_protocol_states_aux[of IK DB trms vars w P] by auto
   then have
       "IK = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t (comb_I w))"
       "DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (T_symb w)) (comb_I w) {}"
       "T_symb w \<in> reachable_constraints P"
       "strand_sem_stateful {} {} (unlabel (T_symb w)) (comb_I w)"
       "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (comb_I w) \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (comb_I w))"
     by auto
   then show "\<exists>A I. (IK, DB) = (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}) \<and>
                    A \<in> reachable_constraints P \<and> strand_sem_stateful {} {} (unlabel A) I \<and>
                    interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
     by blast
 next
   fix IK DB
   assume "(IK, DB) \<in>
             {(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}) | A I.
               A \<in> reachable_constraints P \<and> strand_sem_stateful {} {} (unlabel A) I \<and>
               interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)}"
   then obtain A I where A_I_p:
      "IK = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
      "DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}"
      "A \<in> reachable_constraints P"
      "strand_sem_stateful {} {} (unlabel A) I"
      "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
      "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" 
     by auto
   then have "\<exists>w. (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I, dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, w)
                   \<in> ground_protocol_states_aux P"
     using ground_protocol_states_aux_if_reachable_constraints[of A P I] by auto
   then have "\<exists>w. (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I, DB, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, w) \<in> ground_protocol_states_aux P"
     using A_I_p by blast
   then have "\<exists>w. (ik\<^sub>s\<^sub>s\<^sub>t (unlabel A \<cdot>\<^sub>s\<^sub>s\<^sub>t I), DB, trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A, w) \<in> ground_protocol_states_aux P"
     by (simp add: ik\<^sub>s\<^sub>s\<^sub>t_subst)
   then have "(\<exists>w trms vars. (IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P)"
     by (metis (no_types) A_I_p(1) unlabel_subst)
   then show "\<exists>IK' DB'. (IK, DB) = (IK', DB') \<and>
                        (\<exists>w trms vars. (IK', DB', trms, vars, w) \<in> ground_protocol_states_aux P)"
     by auto
 qed
 
 subsubsection \<open>The Protocol Model Equivalence Proof\<close>
 
 private lemma subst_ground_term_ident:
   assumes "ground_term t"
   shows "t \<cdot> I = t"
 using assms by (simp add: subst_ground_ident)
 
 private lemma subst_comp_rm_vars_eq:
   fixes \<delta> :: "('fun,'atom,'sets,'lbl) prot_subst"
   fixes \<alpha> :: "('fun,'atom,'sets,'lbl) prot_subst"
   fixes I :: "('fun,'atom,'sets,'lbl) prot_subst"
   assumes "subst_domain \<delta> = set X \<and> ground (subst_range \<delta>)"
   shows "(\<delta> \<circ>\<^sub>s \<alpha>) = (\<delta> \<circ>\<^sub>s (rm_vars (set X) \<alpha>))"
 proof (rule ext)
   fix x
   show "(\<delta> \<circ>\<^sub>s \<alpha>) x = (\<delta> \<circ>\<^sub>s rm_vars (set X) \<alpha>) x"
   proof (cases "x \<in> set X")
     case True
     have gt: "ground_term (\<delta> x)"
       using True assms by auto
 
     have "(\<delta> \<circ>\<^sub>s \<alpha>) x = (\<delta> x) \<cdot> \<alpha>"
       using subst_compose by metis
     also
     have "... = \<delta> x"
       using gt subst_ground_term_ident by blast
     also
     have "... = (\<delta> x) \<cdot> (rm_vars (set X) \<alpha>)"
       using gt subst_ground_term_ident by fastforce 
     also
     have "... = (\<delta> \<circ>\<^sub>s (rm_vars (set X) \<alpha>)) x"
       using subst_compose by metis
     ultimately
     show ?thesis
       by auto
   next
     case False
     have delta_x: "\<delta> x = Var x"
       using False assms by blast
     have "(rm_vars (set X) \<alpha>) x = \<alpha> x"
       using False by auto
 
     have "(\<delta> \<circ>\<^sub>s \<alpha>) x = (\<delta> x) \<cdot> \<alpha>"
       using subst_compose by metis
     also
     have "... = (Var x) \<cdot> \<alpha>"
       using delta_x by presburger
     also
     have "... = (Var x) \<cdot> (rm_vars (set X) \<alpha>)"
       using False by force
     also
     have "... = (\<delta> x) \<cdot> (rm_vars (set X) \<alpha>)"
       using delta_x by presburger
     also
     have "... = (\<delta> \<circ>\<^sub>s (rm_vars (set X) \<alpha>)) x"
       using subst_compose by metis
     finally
     show ?thesis 
       by auto
   qed
 qed
 
 private lemma subst_comp_rm_vars_commute:
   assumes "\<forall>x\<in>set X. \<forall>y. \<alpha> y \<noteq> Var x"
   assumes "subst_range \<alpha> \<subseteq> range Var"
   assumes "subst_domain \<delta> = set X"
   assumes "ground (subst_range \<delta>)"
   shows "(\<delta> \<circ>\<^sub>s (rm_vars (set X) \<alpha>)) = (rm_vars (set X) \<alpha> \<circ>\<^sub>s \<delta>)"
 proof (rule ext)
   fix x
   show "(\<delta> \<circ>\<^sub>s rm_vars (set X) \<alpha>) x = (rm_vars (set X) \<alpha> \<circ>\<^sub>s \<delta>) x"
   proof (cases "x \<in> set X")
     case True
     then have gt: "ground_term (\<delta> x)"
       using True assms(3,4) by auto
 
     have "(\<delta> \<circ>\<^sub>s (rm_vars (set X) \<alpha>)) x = \<delta> x \<cdot> rm_vars (set X) \<alpha>"
       by (simp add: subst_compose)
     also
     have "... = \<delta> x"
       using gt by auto
     also
     have "... = ((rm_vars (set X) \<alpha>) x) \<cdot> \<delta>"
       by (simp add: True)
     also
     have "... = (rm_vars (set X) \<alpha> \<circ>\<^sub>s \<delta>) x"
       by (simp add: subst_compose)
     finally 
     show ?thesis .
   next
     case False
     have \<delta>_x: "\<delta> x = Var x"
       using False assms(3) by blast
     obtain y where y_p: "\<alpha> x = Var y"
       by (meson assms(2) image_iff subsetD subst_imgI)
     then have "y \<notin> set X"
       using assms(1) by blast
     then show ?thesis
       using assms(3,4) subst_domI False \<delta>_x y_p
       by (metis (mono_tags, lifting) subst_comp_notin_dom_eq subst_compose)
   qed
 qed
 
 private lemma negchecks_model_substitution_lemma_1:
   fixes \<alpha> :: "('fun,'atom,'sets,'lbl) prot_subst"
   fixes I :: "('fun,'atom,'sets,'lbl) prot_subst"
   assumes "negchecks_model (\<alpha> \<circ>\<^sub>s I) DB X F F'"
   assumes "subst_range \<alpha> \<subseteq> range Var"
   assumes "\<forall>x\<in>set X. \<forall>y. \<alpha> y \<noteq> Var x"
   shows  "negchecks_model I DB X (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)"
   unfolding negchecks_model_def
 proof (rule, rule)
   fix \<delta> :: "('fun,'atom,'sets,'lbl) prot_subst"
   assume a: "subst_domain \<delta> = set X \<and> ground (subst_range \<delta>)"
 
   have "(\<exists>(t, s)\<in>set F. t \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I)) \<or>
           (\<exists>(t, s)\<in>set F'. (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<notin> DB)"
     using a assms(1) unfolding negchecks_model_def by auto
   then show "(\<exists>(t, s)\<in>set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). t \<cdot> \<delta> \<circ>\<^sub>s I \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s I) \<or> 
                (\<exists>(t, s)\<in>set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s I \<notin> DB)"
   proof
     assume "\<exists>(t, s)\<in>set F. t \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I)"
     then obtain t s where t_s_p: "(t, s)\<in>set F" "t \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I)"
       by auto
     from this(2) have "t \<cdot> \<delta> \<circ>\<^sub>s ((rm_vars (set X) \<alpha>) \<circ>\<^sub>s I) \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s ((rm_vars (set X) \<alpha>) \<circ>\<^sub>s I)"
       using assms(3) a using subst_comp_rm_vars_eq[of \<delta> X \<alpha>] subst_compose_assoc
       by (metis (no_types, lifting)) 
     then have "t \<cdot> (rm_vars (set X) \<alpha>) \<circ>\<^sub>s  ( \<delta> \<circ>\<^sub>s I) \<noteq> s \<cdot> (rm_vars (set X) \<alpha>) \<circ>\<^sub>s (\<delta> \<circ>\<^sub>s I)"
       using subst_comp_rm_vars_commute[of X \<alpha> \<delta>, OF assms(3) assms(2)] a
       by (metis (no_types, lifting) subst_compose_assoc[symmetric])
     then have "t \<cdot> (rm_vars (set X) \<alpha>) \<cdot> ( \<delta> \<circ>\<^sub>s I) \<noteq> s \<cdot> (rm_vars (set X) \<alpha>) \<cdot> (\<delta> \<circ>\<^sub>s I)"
       by auto
     moreover
     have "(t \<cdot> rm_vars (set X) \<alpha>, s \<cdot> rm_vars (set X) \<alpha>) \<in> set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)"
       using subst_apply_pairs_pset_subst t_s_p(1) by fastforce
     ultimately
     have "\<exists>(t, s)\<in>set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). t \<cdot> \<delta> \<circ>\<^sub>s I \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s I"
       by auto
     then show ?thesis
       by auto
   next
     assume "\<exists>(t, s)\<in>set F'. (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<notin> DB"
     then obtain t s where t_s_p: "(t, s) \<in> set F'" "(t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<notin> DB"
       by auto
     from this(2) have "(t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s (rm_vars (set X) \<alpha> \<circ>\<^sub>s I) \<notin> DB"
       using assms(3) a subst_comp_rm_vars_eq[OF a]
       by (metis (no_types, lifting) case_prod_conv subst_subst_compose)
     then have "(t, s) \<cdot>\<^sub>p rm_vars (set X) \<alpha> \<circ>\<^sub>s (\<delta> \<circ>\<^sub>s I) \<notin> DB"
       using a subst_comp_rm_vars_commute[of X \<alpha> \<delta>, OF assms(3) assms(2)]
       by (metis (no_types, lifting) case_prod_conv subst_compose_assoc) 
     then have "(t \<cdot> rm_vars (set X) \<alpha>, s \<cdot> rm_vars (set X) \<alpha>) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s I \<notin> DB"
       by auto
     moreover
     have "(t \<cdot> rm_vars (set X) \<alpha>, s \<cdot> rm_vars (set X) \<alpha>) \<in> set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)"
       using t_s_p(1) subst_apply_pairs_pset_subst by fastforce
     ultimately
     have "(\<exists>(t, s) \<in> set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s I \<notin> DB)"
       by auto
     then show ?thesis
       by auto
   qed
 qed
 
 private lemma negchecks_model_substitution_lemma_2:
   fixes \<alpha> :: "('fun,'atom,'sets,'lbl) prot_subst"
   fixes I :: "('fun,'atom,'sets,'lbl) prot_subst"
   assumes "negchecks_model I DB X (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)"
   assumes "subst_range \<alpha> \<subseteq> range Var"
   assumes "\<forall>x\<in>set X. \<forall>y. \<alpha> y \<noteq> Var x"
   shows "negchecks_model (\<alpha> \<circ>\<^sub>s I) DB X F F'"
   unfolding negchecks_model_def
 proof (rule, rule)
   fix \<delta> :: "('fun,'atom,'sets,'lbl) prot_subst"
   assume a: "subst_domain \<delta> = set X \<and> ground (subst_range \<delta>)"
 
   have "(\<exists>(t, s)\<in>set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). t \<cdot> \<delta> \<circ>\<^sub>s  I \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (I)) \<or>
           (\<exists>(t, s)\<in>set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s I \<notin> DB)"
     using a assms(1)unfolding negchecks_model_def by auto
   then show "(\<exists>(t, s)\<in>set F. t \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I)) \<or>
                (\<exists>(t, s)\<in>set F'. (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<notin> DB)"
   proof
     assume "\<exists>(t, s)\<in>set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). t \<cdot> \<delta> \<circ>\<^sub>s  I \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (I)"
     then obtain t s where t_s_p: "(t, s) \<in> set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)" "t \<cdot> \<delta> \<circ>\<^sub>s I \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s I"
       by auto
     then have "\<exists>t' s'. t = t' \<cdot> rm_vars (set X) \<alpha> \<and> s = s' \<cdot> rm_vars (set X) \<alpha> \<and> (t',s') \<in> set F"
       unfolding subst_apply_pairs_def by auto
     then obtain t' s' where t'_s'_p: 
       "t = t' \<cdot> rm_vars (set X) \<alpha>" 
       "s = s' \<cdot> rm_vars (set X) \<alpha>" 
       "(t',s') \<in> set F"
       by auto
     then have "t' \<cdot> rm_vars (set X) \<alpha> \<cdot> \<delta> \<circ>\<^sub>s I \<noteq> s' \<cdot> rm_vars (set X) \<alpha> \<cdot> \<delta> \<circ>\<^sub>s I"
       using t_s_p by auto
     then have "t' \<cdot>  \<delta> \<cdot> rm_vars (set X) \<alpha> \<circ>\<^sub>s I \<noteq> s' \<cdot> \<delta> \<cdot> rm_vars (set X) \<alpha>  \<circ>\<^sub>s I"
       using a subst_comp_rm_vars_commute[OF assms(3,2)] by (metis (no_types, lifting) subst_subst)
     then have "t' \<cdot>  \<delta> \<cdot> \<alpha> \<circ>\<^sub>s I \<noteq> s' \<cdot> \<delta> \<cdot> \<alpha>  \<circ>\<^sub>s I"
       using subst_comp_rm_vars_eq[OF a] by (metis (no_types, lifting) subst_subst)
     moreover
     from t_s_p(1) have "(t', s') \<in> set F"
       using subst_apply_pairs_pset_subst t'_s'_p by fastforce
     ultimately
     have "\<exists>(t, s)\<in>set F. t \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<noteq> s \<cdot> \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I)"
       by auto
     then show ?thesis
       by auto
   next
     assume "\<exists>(t, s)\<in>set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>). (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s I \<notin> DB"
     then obtain t s where t_s_p: 
       "(t, s) \<in> set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)" 
       "(t \<cdot> \<delta> \<circ>\<^sub>s I, s \<cdot> \<delta> \<circ>\<^sub>s I) \<notin> DB"
       by auto
     then have "\<exists>t' s'. t = t' \<cdot> rm_vars (set X) \<alpha> \<and> s = s' \<cdot> rm_vars (set X) \<alpha> \<and> (t',s') \<in> set F'"
       unfolding subst_apply_pairs_def by auto
     then obtain t' s' where t'_s'_p: 
       "t = t' \<cdot> rm_vars (set X) \<alpha>" 
       "s = s' \<cdot> rm_vars (set X) \<alpha>" 
       "(t',s') \<in> set F'"
       by auto
     then have "(t' \<cdot> rm_vars (set X) \<alpha> \<cdot> \<delta> \<circ>\<^sub>s I, s' \<cdot> rm_vars (set X) \<alpha> \<cdot> \<delta> \<circ>\<^sub>s I) \<notin> DB"
       using t_s_p by auto
     then have "(t' \<cdot>  \<delta> \<cdot> rm_vars (set X) \<alpha> \<circ>\<^sub>s I, s' \<cdot> \<delta> \<cdot> rm_vars (set X) \<alpha>  \<circ>\<^sub>s I) \<notin> DB"
       using a subst_comp_rm_vars_commute[OF assms(3,2)]
       by (metis (no_types, lifting) subst_subst)
     then have "(t' \<cdot>  \<delta> \<cdot> \<alpha> \<circ>\<^sub>s I , s' \<cdot> \<delta> \<cdot> \<alpha>  \<circ>\<^sub>s I) \<notin> DB"
       using subst_comp_rm_vars_eq[OF a] by (metis (no_types, lifting) subst_subst)
     moreover
     from t_s_p(1) have "(t', s') \<in> set F'"
       using subst_apply_pairs_pset_subst t'_s'_p by fastforce
     ultimately
     have "\<exists>(t, s)\<in>set F'. (t, s) \<cdot>\<^sub>p \<delta> \<circ>\<^sub>s (\<alpha> \<circ>\<^sub>s I) \<notin> DB"
       by auto
     then show ?thesis
       by auto
   qed
 qed
 
 private lemma negchecks_model_substitution_lemma:
   fixes \<alpha> :: "('fun,'atom,'sets,'lbl) prot_subst"
   fixes I :: "('fun,'atom,'sets,'lbl) prot_subst"
   assumes "subst_range \<alpha> \<subseteq> range Var"
   assumes "\<forall>x\<in>set X. \<forall>y. \<alpha> y \<noteq> Var x"
   shows "negchecks_model (\<alpha> \<circ>\<^sub>s I) DB X F F' \<longleftrightarrow>
            negchecks_model I DB X (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>)"
 using assms negchecks_model_substitution_lemma_1[of \<alpha> I DB X F F'] 
       negchecks_model_substitution_lemma_2[of I DB X F \<alpha> F'] assms
 by auto
 
 private lemma strand_sem_stateful_substitution_lemma:
   fixes \<alpha> :: "('fun,'atom,'sets,'lbl) prot_subst"
   fixes I :: "('fun,'atom,'sets,'lbl) prot_subst"
   assumes "subst_range \<alpha> \<subseteq> range Var"
   assumes "\<forall>x \<in> bvars\<^sub>s\<^sub>s\<^sub>t T. \<forall>y. \<alpha> y \<noteq> Var x"
   shows "strand_sem_stateful IK DB (T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>) I = strand_sem_stateful IK DB T (\<alpha> \<circ>\<^sub>s I)"
 using assms
 proof (induction T arbitrary: IK DB)
   case Nil
   then show ?case by auto
 next
   case (Cons a T)
   then show ?case
   proof (induction a)
     case (Receive ts)
     have "((\<lambda>x. x \<cdot> \<alpha> \<cdot> I) ` (set ts)) \<union> IK = ((\<lambda>t. t \<cdot> \<alpha>) ` set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<union> IK"
       by blast
     then show ?case
       using Receive by (force simp add: subst_sst_cons)
   next
     case (NegChecks X F F')
 
     have bounds: "\<forall>x\<in>bvars\<^sub>s\<^sub>s\<^sub>t T. \<forall>y. \<alpha> y \<noteq> Var x"
       using NegChecks by auto
 
     have "\<forall>x\<in>bvars\<^sub>s\<^sub>s\<^sub>t ([\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: F'\<rangle>]). \<forall>y. \<alpha> y \<noteq> Var x"
       using NegChecks by auto
     then have bounds2: "\<forall>x\<in>set X. \<forall>y. \<alpha> y \<noteq> Var x"
       by simp
 
     have "negchecks_model I DB X (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) \<longleftrightarrow>
             negchecks_model (\<alpha> \<circ>\<^sub>s I) DB X F F'"
       using NegChecks.prems(2) bounds2 negchecks_model_substitution_lemma by blast
     moreover
     have "strand_sem_stateful IK DB (T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>) I \<longleftrightarrow> strand_sem_stateful IK DB T (\<alpha> \<circ>\<^sub>s I)"
       using Cons NegChecks(2) bounds by blast
     ultimately
     show ?case
       by (simp add: subst_sst_cons)
   qed (force simp add: subst_sst_cons)+
 qed
 
 private lemma ground_subst_rm_vars_subst_compose_dist:
   assumes "ground (subst_range \<xi>\<sigma>)"
   shows "(rm_vars (set X) (\<xi>\<sigma> \<circ>\<^sub>s \<alpha>)) = (rm_vars (set X) \<xi>\<sigma> \<circ>\<^sub>s rm_vars (set X) \<alpha>)"
 proof (rule ext)
   fix x
   show "rm_vars (set X) (\<xi>\<sigma> \<circ>\<^sub>s \<alpha>) x = (rm_vars (set X) \<xi>\<sigma> \<circ>\<^sub>s rm_vars (set X) \<alpha>) x"
   proof (cases "x \<in> set X")
     case True
     then show ?thesis
       by (simp add: subst_compose)
   next
     case False
     note False_outer = False
     show ?thesis
     proof (cases "x \<in> subst_domain \<xi>\<sigma>")
       case True
       then show ?thesis
         by (metis (mono_tags, lifting) False assms ground_subst_range_empty_fv 
               subst_ground_ident_compose(1))
     next
       case False
       have "\<xi>\<sigma> x = Var x"
         using False by blast
       then show ?thesis 
         using False_outer by (simp add: subst_compose)
     qed
   qed
 qed
 
 private lemma stateful_strand_ground_subst_comp:
   assumes "ground (subst_range \<xi>\<sigma>)"
   shows "T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi>\<sigma> \<circ>\<^sub>s \<alpha> = (T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi>\<sigma>) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>"
 using assms by (meson disjoint_iff ground_subst_no_var stateful_strand_subst_comp)
 
 private lemma labelled_stateful_strand_ground_subst_comp:
   assumes "ground (subst_range \<xi>\<sigma>)"
   shows "T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi>\<sigma> \<circ>\<^sub>s \<alpha> = (T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi>\<sigma>) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>"
 using assms by (metis Int_empty_left ground_range_vars labeled_stateful_strand_subst_comp)
 
 private lemma transaction_fresh_subst_ground_subst_range:
   assumes "transaction_fresh_subst \<sigma> T trms"
   shows "ground (subst_range \<sigma>)"
 using assms by (metis range_vars_alt_def transaction_fresh_subst_range_vars_empty)
 
 private lemma transaction_decl_subst_ground_subst_range:
   assumes "transaction_decl_subst \<xi> T"
   shows "ground (subst_range \<xi>)"
 proof -
   have \<xi>_ground: "\<forall>x \<in> subst_domain \<xi>. ground_term (\<xi> x)"
     using assms transaction_decl_subst_domain transaction_decl_subst_grounds_domain by force
   show ?thesis
   proof (rule ccontr)
     assume "fv\<^sub>s\<^sub>e\<^sub>t (subst_range \<xi>) \<noteq> {}"
     then have "\<exists>x \<in> subst_domain \<xi>. fv (\<xi> x) \<noteq> {}"
       by auto
     then obtain x where x_p: "x \<in> subst_domain \<xi> \<and> fv (\<xi> x) \<noteq> {}"
       by meson
     moreover 
     have "ground_term (\<xi> x)"
       using \<xi>_ground x_p by auto
     ultimately
     show "False"
       by auto
   qed
 qed
 
 private lemma fresh_transaction_decl_subst_ground_subst_range:
   assumes "transaction_fresh_subst \<sigma> T trms"
   assumes "transaction_decl_subst \<xi> T"
   shows "ground (subst_range (\<xi> \<circ>\<^sub>s \<sigma>))"
 proof -
   have "ground (subst_range \<xi>)"
     using assms transaction_decl_subst_ground_subst_range by blast
   moreover
   have "ground (subst_range \<sigma>)"
     using assms
     using transaction_fresh_subst_ground_subst_range by blast 
   ultimately
   show "ground (subst_range (\<xi> \<circ>\<^sub>s \<sigma>))"
     by (metis (no_types, opaque_lifting) Diff_iff all_not_in_conv empty_iff empty_subsetI 
           range_vars_alt_def range_vars_subst_compose_subset subset_antisym sup_bot.right_neutral)
 qed
 
 private lemma strand_sem_stateful_substitution_lemma':
   assumes "transaction_renaming_subst \<alpha> P vars"
   assumes "transaction_fresh_subst \<sigma> T trms"
   assumes "transaction_decl_subst \<xi> T"
   assumes "finite vars"
   assumes "T \<in> set P"
   shows "strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))) I
     \<longleftrightarrow> strand_sem_stateful IK DB (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma>))) (\<alpha> \<circ>\<^sub>s I)"
 proof -
   have \<alpha>_Var: "subst_range \<alpha> \<subseteq> range Var"
     using assms(1) transaction_renaming_subst_is_renaming(5) by blast
   have "(\<forall>x\<in>vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T). \<forall>y. \<alpha> y \<noteq> Var x)"
     using assms(4,2) transaction_renaming_subst_vars_transaction_neq assms(1) assms(5) by blast 
   then have "(\<forall>x\<in>bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T). \<forall>y. \<alpha> y \<noteq> Var x)"
     by (metis UnCI vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t)
   then have T_Vars: "(\<forall>x\<in>bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma>)). \<forall>y. \<alpha> y \<noteq> Var x)"
     by (metis bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst bvars\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq)
 
   have ground_\<xi>_\<sigma>: "ground (subst_range (\<xi> \<circ>\<^sub>s \<sigma>))"
     using fresh_transaction_decl_subst_ground_subst_range
     using assms(2) assms(3) by blast
  
   from assms(1) ground_\<xi>_\<sigma> have 
     "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) =
     unlabel ((dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma>) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>)"
     using stateful_strand_ground_subst_comp[of _ "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"]
     by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst) 
   then show ?thesis
     using strand_sem_stateful_substitution_lemma \<alpha>_Var T_Vars
     by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst subst_lsst_unlabel)
 qed
 
 inductive_set ground_protocol_states::
   "('fun,'atom,'sets,'lbl) prot \<Rightarrow>
    (('fun,'atom,'sets,'lbl) prot_terms \<times>
     (('fun,'atom,'sets,'lbl) prot_term \<times> ('fun,'atom,'sets,'lbl) prot_term) set
     \<times>
    _ set
    ) set" (* TODO: write up the type nicer *)
   for P::"('fun,'atom,'sets,'lbl) prot"
 where
   init:
   "({},{},{}) \<in> ground_protocol_states P"
 | step:
   "\<lbrakk>(IK,DB,consts) \<in> ground_protocol_states P;
     T \<in> set P;
     transaction_decl_subst \<xi> T;
     transaction_fresh_subst \<sigma> T consts;
     A = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma>);
     strand_sem_stateful IK DB (unlabel A) I;
     interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I;
     wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)
    \<rbrakk> \<Longrightarrow> (IK \<union> ((ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<cdot>\<^sub>s\<^sub>e\<^sub>t I), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB,
           consts \<union> {t. t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<and> (\<exists>c. t = Fun c [])}) \<in> ground_protocol_states P"
 
 
 private lemma transaction_fresh_subst_consts_of_iff:
   "transaction_fresh_subst \<sigma> T (consts_of trms) \<longleftrightarrow> transaction_fresh_subst \<sigma> T trms"
 proof (cases "transaction_fresh_subst \<sigma> T (consts_of trms) \<or> transaction_fresh_subst \<sigma> T trms")
   case True
   then have "\<forall>t \<in> subst_range \<sigma>. \<exists>c. t = Fun c []"
     unfolding transaction_fresh_subst_def by auto
   have "(\<forall>t \<in> subst_range \<sigma>. t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (consts_of trms) \<longleftrightarrow> t \<in> subterms\<^sub>s\<^sub>e\<^sub>t trms)"
   proof 
     fix t
     assume "t \<in> subst_range \<sigma>"
     then obtain c where c_p: "t = Fun c []"
       using \<open>\<forall>t\<in>subst_range \<sigma>. \<exists>c. t = Fun c []\<close> by blast
     have "Fun c [] \<in> subterms\<^sub>s\<^sub>e\<^sub>t (consts_of trms) \<longleftrightarrow> Fun c [] \<in> subterms\<^sub>s\<^sub>e\<^sub>t trms"
       unfolding consts_of_def by auto
     then show "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (consts_of trms) \<longleftrightarrow> t \<in> subterms\<^sub>s\<^sub>e\<^sub>t trms"
       using c_p by auto
   qed
   then show ?thesis
     using transaction_fresh_subst_def by force
 next
   case False
   then show ?thesis by auto
 qed
 
 private lemma transaction_renaming_subst_inv:
   assumes "transaction_renaming_subst \<alpha> P X "
   shows "\<exists>\<alpha>inv. \<alpha> \<circ>\<^sub>s \<alpha>inv = Var \<and>  wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<alpha>inv)"
 using var_rename_inv_comp transaction_renaming_subst_def assms subst_apply_term_empty subst_term_eqI
 by (metis var_rename_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_range(2))  
 
 private lemma consts_of_union_distr: 
   "consts_of (trms1 \<union> trms2) = consts_of trms1 \<union> consts_of trms2"
 unfolding consts_of_def by auto
 
 private lemma ground_protocol_states_aux_finite_vars:
   assumes "(IK,DB,trms,vars,w) \<in> ground_protocol_states_aux P"
   shows "finite vars"
 using assms by (induction rule: ground_protocol_states_aux.induct) auto
 
 private lemma dbupd\<^sub>s\<^sub>s\<^sub>t_substitution_lemma:
   "dbupd\<^sub>s\<^sub>s\<^sub>t T (\<alpha> \<circ>\<^sub>s I) DB = dbupd\<^sub>s\<^sub>s\<^sub>t (T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>) I DB"
 proof (induction T arbitrary: DB)
   case Nil
   then show ?case
     by auto 
 next
   case (Cons a T)
   then show ?case
     by (induction a) (simp_all add: subst_apply_stateful_strand_def)
 qed
 
 private lemma subst_Var_const_subterm_subst:
   assumes "subst_range \<alpha> \<subseteq> range Var"
   shows "Fun c [] \<sqsubseteq> t \<longleftrightarrow> Fun c [] \<sqsubseteq> t \<cdot> \<alpha>"
   using assms
 proof (induction t)
   case (Var x)
   then show ?case
     by (metis is_Var_def subtermeq_Var_const(1) term.discI(2) var_renaming_is_Fun_iff)
 next
   case (Fun f ts)
   then show ?case
     by auto
 qed
 
 private lemma subst_Var_consts_of:
   assumes "subst_range \<alpha> \<subseteq> range Var"
   shows "consts_of T = consts_of (T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<alpha>)"
 proof (rule antisym; rule subsetI)
   fix x
   assume "x \<in> consts_of T"
   then obtain t c where t_c_p: "t \<in> T \<and> x \<sqsubseteq> t \<and> x = Fun c []"
     unfolding consts_of_def by auto
   moreover
   have "x \<sqsubseteq> t \<cdot> \<alpha>"
     using t_c_p by (meson assms subst_Var_const_subterm_subst)
   ultimately
   show "x \<in> consts_of (T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<alpha>)"
     unfolding consts_of_def by auto 
 next
   fix x
   assume "x \<in> consts_of (T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<alpha>)"
   then obtain t c where t_c_p: "t \<in> T \<and> x \<sqsubseteq> t \<cdot> \<alpha> \<and> x = Fun c []"
     unfolding consts_of_def by auto
   moreover
   have "x \<sqsubseteq> t"
     using t_c_p by (meson assms subst_Var_const_subterm_subst)
   ultimately
   show "x \<in> consts_of T"
     unfolding consts_of_def by auto
 qed
 
 private lemma fst_set_subst_apply_set:
   "fst ` set F \<cdot>\<^sub>s\<^sub>e\<^sub>t \<alpha> = fst ` (set F \<cdot>\<^sub>p\<^sub>s\<^sub>e\<^sub>t \<alpha>)"
 by (induction F) auto
 
 private lemma snd_set_subst_apply_set:
   "snd ` set F \<cdot>\<^sub>s\<^sub>e\<^sub>t \<alpha> = snd ` (set F \<cdot>\<^sub>p\<^sub>s\<^sub>e\<^sub>t \<alpha>)"
 by (induction F) auto
 
 private lemma trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fst_snd: 
   "trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = fst ` set F \<union> snd ` set F"
 by (auto simp add: rev_image_eqI)
 
 private lemma consts_of_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_range_Var:
   assumes "subst_range \<alpha> \<subseteq> range Var"
   shows "consts_of (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) = consts_of (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<alpha>))"
   using assms
 proof (induction a)
   case (NegChecks X F F')
   have \<alpha>_subs_rng_Var: "subst_range (rm_vars (set X) \<alpha>) \<subseteq> range Var"
     using assms by auto
 
   have "consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) = consts_of (fst ` set F \<union> snd ` set F)"
     using trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fst_snd by metis
   also
   have "... = consts_of (fst ` set F) \<union> consts_of (snd ` set F)"
     using consts_of_union_distr by blast
   also
   have "... = consts_of ((fst ` set F) \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>) \<union>
                 consts_of ((snd ` set F) \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>)"
     using \<alpha>_subs_rng_Var subst_Var_consts_of[of "rm_vars (set X) \<alpha>" "fst ` set F"] 
             subst_Var_consts_of[of "rm_vars (set X) \<alpha>" "snd ` set F"] 
     by auto
   also
   have "... = consts_of (((fst ` set F) \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>) \<union>
                 ((snd ` set F) \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>))"
     using consts_of_union_distr by auto
   also
   have "... = consts_of (fst ` set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) \<union>
                 snd ` set (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>))"
     unfolding subst_apply_pairs_def fst_set_subst_apply_set snd_set_subst_apply_set by simp 
   also
   have "... = consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>))"
     using trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fst_snd[of "F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>"] 
     by metis
   finally 
   have 1: "consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F) = consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>))"
     by auto
 
   have "consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F') = consts_of (fst ` set F' \<union> snd ` set F')"
     using trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fst_snd by metis
   also
   have "... = consts_of (fst ` set F') \<union> consts_of (snd ` set F')"
     using consts_of_union_distr by blast
   also
   have "... = consts_of ((fst ` set F') \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>) \<union>
                 consts_of ((snd ` set F') \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>)"
     using subst_Var_consts_of[of "rm_vars (set X) \<alpha>" "fst ` set F'"] \<alpha>_subs_rng_Var
             subst_Var_consts_of[of "rm_vars (set X) \<alpha>" "snd ` set F'"]
     by auto
   also
   have "... = consts_of ((fst ` set F' \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>) \<union>
                 (snd ` set F' \<cdot>\<^sub>s\<^sub>e\<^sub>t rm_vars (set X) \<alpha>))"
     using consts_of_union_distr by auto
   also
   have "... = consts_of (fst ` set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>) \<union> 
                 snd ` set (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>))"
     unfolding subst_apply_pairs_def fst_set_subst_apply_set snd_set_subst_apply_set by simp 
   also
   have "... = consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>))"
     using trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_fst_snd[of "F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>"] 
     by metis
   finally have 2: "consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F') = consts_of (trms\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F' \<cdot>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s rm_vars (set X) \<alpha>))"
     by auto
 
   show ?case 
     using 1 2 by (simp add: consts_of_union_distr)
 qed (use subst_Var_consts_of[of _ "{_, _}", OF assms] subst_Var_consts_of[OF assms] in auto)
 
 private lemma consts_of_trms\<^sub>s\<^sub>s\<^sub>t_range_Var:
   assumes "subst_range \<alpha> \<subseteq> range Var"
   shows "consts_of (trms\<^sub>s\<^sub>s\<^sub>t T) = consts_of (trms\<^sub>s\<^sub>s\<^sub>t (T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>))"
 proof (induction T)
   case Nil
   then show ?case by auto
 next
   case (Cons a T)
   have "consts_of (trms\<^sub>s\<^sub>s\<^sub>t (a # T)) = consts_of (trms\<^sub>s\<^sub>s\<^sub>t [a] \<union> trms\<^sub>s\<^sub>s\<^sub>t T)"
     by simp
   also
   have "... = consts_of (trms\<^sub>s\<^sub>s\<^sub>t [a]) \<union> consts_of (trms\<^sub>s\<^sub>s\<^sub>t T)"
     using consts_of_union_distr by simp
   also 
   have "... = consts_of (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \<union> consts_of (trms\<^sub>s\<^sub>s\<^sub>t T)"
     by simp
   also
   have "... = consts_of (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<alpha>)) \<union> consts_of (trms\<^sub>s\<^sub>s\<^sub>t T)"
     using consts_of_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_range_Var[OF assms] by simp
   also 
   have "... = consts_of (trms\<^sub>s\<^sub>s\<^sub>t ([a] \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>)) \<union> consts_of (trms\<^sub>s\<^sub>s\<^sub>t T)"
     by (simp add: subst_apply_stateful_strand_def)
   also
   have "... = consts_of (trms\<^sub>s\<^sub>s\<^sub>t ([a] \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>)) \<union> consts_of (trms\<^sub>s\<^sub>s\<^sub>t (T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>))"
     using local.Cons by simp
   also
   have "... = consts_of (trms\<^sub>s\<^sub>s\<^sub>t (a # T \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>))"
     by (simp add: consts_of_union_distr subst_sst_cons)
   finally
   show ?case
     by simp
 qed
 
 private lemma consts_of_trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t_range_Var:
   assumes "subst_range \<alpha> \<subseteq> range Var"
   shows "consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T) = consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>))"
 using consts_of_trms\<^sub>s\<^sub>s\<^sub>t_range_Var[of \<alpha> "unlabel T"]
 by (metis assms unlabel_subst)
 
 private lemma transaction_renaming_subst_range:
   assumes "transaction_renaming_subst \<alpha> P vars"
   shows "subst_range \<alpha> \<subseteq> range Var"
 using assms unfolding transaction_renaming_subst_def var_rename_def by auto
 
 private lemma protocol_models_equiv3':
   assumes "(IK,DB,trms,vars,w) \<in> ground_protocol_states_aux P"
   shows "(IK,DB, consts_of trms) \<in> ground_protocol_states P"
   using assms 
 proof (induction rule: ground_protocol_states_aux.induct)
   case init
   then show ?case
     using ground_protocol_states.init unfolding consts_of_def by force
 next
   case (step IK DB trms vars w T \<xi> \<sigma> \<alpha> A I)
 
   have fin_vars: "finite vars"
     using ground_protocol_states_aux_finite_vars step by auto
 
   have ground_\<xi>\<sigma>: "ground (subst_range (\<xi> \<circ>\<^sub>s \<sigma>))"
     using fresh_transaction_decl_subst_ground_subst_range using step.hyps(3) step.hyps(4) by blast
 
   have \<alpha>_Var: "subst_range \<alpha> \<subseteq> range Var"
     using step(5) transaction_renaming_subst_range by metis
 
   define I' where "I' = \<alpha> \<circ>\<^sub>s I"
   define A' where "A' = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma>)"
 
   have "(IK, DB, consts_of trms) \<in> ground_protocol_states P"
     using step by force
   moreover
   have T_in_P: "T \<in> set P"
      using step by force
   moreover
   have "transaction_decl_subst \<xi> T"
      using step by force
   moreover
   have "transaction_fresh_subst \<sigma> T (consts_of trms)"
      using step transaction_fresh_subst_consts_of_iff by force
   moreover
   have "A' = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma>)"
     using A'_def .
   moreover
   have "strand_sem_stateful IK DB (unlabel A') I'"
     using step(7) step(4) step(5) step(3) T_in_P fin_vars unfolding A'_def I'_def step(6)
     using strand_sem_stateful_substitution_lemma'
     by auto
   moreover
   have "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I'"
     using step(8) unfolding I'_def
     by (meson interpretation_comp(1)) 
   moreover
   have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I')"
    using step(9) unfolding I'_def
    using step.hyps(5) transaction_renaming_subst_range_wf_trms wf_trms_subst_compose by blast 
   ultimately
   have "(IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t I'), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') I' DB, 
            consts_of trms \<union> consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A')) \<in> ground_protocol_states P"
     using ground_protocol_states.step[of IK DB "consts_of trms" P T \<xi> \<sigma> A' I']
     unfolding consts_of_def by blast
   moreover
   have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t I' = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
   proof - 
     have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t I' = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t \<alpha> \<circ>\<^sub>s I"
       unfolding A'_def I'_def step(6) by auto
     also
     have "... = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t ((A' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
       unfolding unlabel_subst[symmetric] ik\<^sub>s\<^sub>s\<^sub>t_subst by auto
     also
     have "... = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
       unfolding A'_def step(6)
       using labelled_stateful_strand_ground_subst_comp[of _ "transaction_strand T", OF ground_\<xi>\<sigma>]
       by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst)
     also
     have "... = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       by (metis ik\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst)
     finally 
     show "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t I' = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       by auto
   qed
   moreover
   have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') I' DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB"
   proof -
     have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') I' DB = 
             dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') (\<alpha> \<circ>\<^sub>s I) DB"
       unfolding A'_def I'_def step(6) using step by auto
     also
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A' \<cdot>\<^sub>s\<^sub>s\<^sub>t \<alpha>) I DB"
       using dbupd\<^sub>s\<^sub>s\<^sub>t_substitution_lemma by metis
     also
     have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB"
       unfolding A'_def step(6)
       using stateful_strand_ground_subst_comp[of _ "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"] 
         ground_\<xi>\<sigma> by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_unlabel)
     finally
     show "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') I' DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB"
       by auto
   qed
   moreover
   have "consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A') = consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     by (metis (no_types, lifting) A'_def \<alpha>_Var consts_of_trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t_range_Var ground_\<xi>\<sigma> 
          labelled_stateful_strand_ground_subst_comp step.hyps(6) trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq)
   ultimately
   show ?case
     using consts_of_union_distr by metis
 qed
 
 private lemma protocol_models_equiv4':
   assumes "(IK, DB, csts) \<in> ground_protocol_states P"
   shows "\<exists>trms w vars. (IK,DB,trms,vars,w) \<in> ground_protocol_states_aux P 
                   \<and> csts = consts_of trms
                   \<and> vars = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)"
   using assms 
 proof (induction rule: ground_protocol_states.induct)
   case init
   have "({}, {}, {}, {}, []) \<in> ground_protocol_states_aux P"
     using ground_protocol_states_aux.init by blast
   moreover
   have "{} = consts_of {}"
     unfolding consts_of_def by auto
   moreover
   have "{} = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb [])"
     by auto
   ultimately
   show ?case
     by metis
 next
   case (step IK DB "consts" T \<xi> \<sigma> A I)
   then obtain trms w vars where trms_w_vars_p:
     "(IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P"
     "consts = consts_of trms"
     "vars = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w)"
     by auto
 
   have "\<exists>\<alpha>. transaction_renaming_subst \<alpha> P vars"
     unfolding transaction_renaming_subst_def by blast
 
   then obtain \<alpha> :: "('fun,'atom,'sets,'lbl) prot_subst"
     where \<alpha>_p: "transaction_renaming_subst \<alpha> P vars"
     by blast
   then obtain \<alpha>inv where \<alpha>inv_p: "\<alpha> \<circ>\<^sub>s \<alpha>inv = Var \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<alpha>inv)"
     using transaction_renaming_subst_inv[of \<alpha> P vars] by auto
 
   define A' where "A' = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define I' where "I' = \<alpha>inv \<circ>\<^sub>s I"
   define trms' where "trms' = trms \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A'"
   define vars' where "vars' = vars \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A'"
   define w' where "w' = w @ [(\<xi>, \<sigma>, I', T, \<alpha>)]"
   define IK' where "IK' = IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
   define DB' where "DB' = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB"
 
   have P_state: "(IK', DB' , trms', vars', w') \<in> ground_protocol_states_aux P"
   proof -
     have 1: "(IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P"
       using \<open>(IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P\<close> by blast
     moreover
     have "T \<in> set P"
       using step(2) .
     moreover
     have "transaction_decl_subst \<xi> T"
       using step(3) .
     moreover
     have fresh_\<sigma>: "transaction_fresh_subst \<sigma> T trms"
       using step(4) trms_w_vars_p(2)
       using transaction_fresh_subst_consts_of_iff by auto
     moreover
     have "transaction_renaming_subst \<alpha> P vars"
       using \<alpha>_p .
     moreover
     have "A' = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       unfolding A'_def by auto
     moreover
     have "strand_sem_stateful IK DB (unlabel A') I'"
     proof -
       have fin_vars: "finite vars"
         using 1 ground_protocol_states_aux_finite_vars by blast
       show "strand_sem_stateful IK DB (unlabel A') I'"
         using step(6) strand_sem_stateful_substitution_lemma'[OF \<alpha>_p fresh_\<sigma> step(3) fin_vars]
           step(2) unfolding A'_def step(5)
         by (metis (no_types, lifting) I'_def \<alpha>inv_p subst_compose_assoc var_comp(2))
     qed
     moreover
     have "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I'"
       using step(7) by (simp add: I'_def interpretation_substI subst_compose)
     moreover
     have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I')"
       using I'_def \<alpha>inv_p step.hyps(8) wf_trms_subst_compose by blast
     moreover
     have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') I' DB"
     proof -
       have "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I DB = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) (\<alpha> \<circ>\<^sub>s \<alpha>inv \<circ>\<^sub>s I) DB"
         by (simp add: \<alpha>inv_p)
       also
       have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') (\<alpha>inv \<circ>\<^sub>s I) DB"
         unfolding A'_def step(5)
         by (metis (no_types, lifting) dbupd\<^sub>s\<^sub>s\<^sub>t_substitution_lemma dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_unlabel 
              subst_compose_assoc)
       also
       have "... = dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A') I' DB"
         unfolding A'_def I'_def by auto
       finally
       show ?thesis
         by auto
     qed
     moreover
     have "IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t I')"
     proof -
       have "IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t (\<alpha>  \<circ>\<^sub>s \<alpha>inv) \<circ>\<^sub>s I)"
         using \<alpha>inv_p by auto
       also
       have "... = IK \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A' \<cdot>\<^sub>s\<^sub>e\<^sub>t I')"
         unfolding A'_def step(5) unlabel_subst[symmetric] ik\<^sub>s\<^sub>s\<^sub>t_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst I'_def by auto
       finally
       show ?thesis
         by auto
     qed
     ultimately
     show "(IK', DB' , trms', vars', w') \<in> ground_protocol_states_aux P"
       using ground_protocol_states_aux.step[of IK DB trms vars w P T \<xi> \<sigma> \<alpha> A' I']
       unfolding trms'_def vars'_def w'_def IK'_def DB'_def by auto
   qed
   moreover
   have "consts \<union> consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = consts_of trms'"
   proof -
     have \<alpha>_Var: "subst_range \<alpha> \<subseteq> range Var"
       using \<alpha>_p transaction_renaming_subst_range by blast
 
     have ground_\<xi>\<sigma>: "ground (subst_range (\<xi> \<circ>\<^sub>s \<sigma>))"
       using fresh_transaction_decl_subst_ground_subst_range using step.hyps(3) step.hyps(4) by blast
 
     have "consts \<union> consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = (consts_of trms) \<union> consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       using trms_w_vars_p(2) by blast
     also
     have "... = (consts_of trms) \<union> consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>))"
       using consts_of_trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t_range_Var[of \<alpha>, OF \<alpha>_Var, of A] by auto
     also
     have "... = (consts_of trms) \<union> consts_of (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A')"
       using step(5) A'_def ground_\<xi>\<sigma>
       using labelled_stateful_strand_ground_subst_comp[of _ "(dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"]
       by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst)
     also
     have "... = consts_of (trms \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A')"
       using consts_of_union_distr by blast
     also
     have "... = consts_of trms'"
       unfolding trms'_def by auto
     finally
     show "?thesis"
       by auto
   qed
   moreover
   have "vars' = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (T_symb w')"
     using P_state reachable_constraints_if_ground_protocol_states_aux by auto
   ultimately
   show ?case
     unfolding DB'_def IK'_def consts_of_def[symmetric] by metis
 qed
 
 private lemma protocol_model_equivalence_aux2:
   "{(IK, DB) | IK DB. \<exists>csts. (IK, DB, csts) \<in> ground_protocol_states P} = 
    {(IK, DB) | IK DB. \<exists>w trms vars. (IK, DB, trms, vars, w) \<in> ground_protocol_states_aux P}"
 using protocol_models_equiv4' protocol_models_equiv3' by meson
 
 theorem protocol_model_equivalence:
   "{(IK, DB) | IK DB. \<exists>csts. (IK, DB, csts) \<in> ground_protocol_states P} = 
    {(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I), dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}) | A I.
       A \<in> reachable_constraints P \<and> strand_sem_stateful {} {} (unlabel A) I \<and>
       interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)}"
 using protocol_model_equivalence_aux2 protocol_model_equivalence_aux1 by auto
 
 end
 
 end
 
 end
diff --git a/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Verification.thy b/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Verification.thy
--- a/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Verification.thy
+++ b/thys/Automated_Stateful_Protocol_Verification/Stateful_Protocol_Verification.thy
@@ -1,11391 +1,11391 @@
 (*  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\<open>Stateful Protocol Verification\<close>
 theory Stateful_Protocol_Verification
 imports Stateful_Protocol_Model Term_Implication
 begin
 
 subsection \<open>Fixed-Point Intruder Deduction Lemma\<close>
 context stateful_protocol_model
 begin
 
 abbreviation pubval_terms::"('fun,'atom,'sets,'lbl) prot_terms" where
   "pubval_terms \<equiv> {t. \<exists>f \<in> funs_term t. is_PubConstValue f}"
 
 abbreviation abs_terms::"('fun,'atom,'sets,'lbl) prot_terms" where
   "abs_terms \<equiv> {t. \<exists>f \<in> 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]
     \<Rightarrow> bool" ("\<langle>_;_\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P _" 50)
 where
   "\<langle>M; T\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P t \<equiv> intruder_deduct_restricted M (\<lambda>t. t \<in> GSMP T - (pubval_terms \<union> abs_terms)) t"
 
 lemma intruder_deduct_GSMP_induct[consumes 1, case_names AxiomH ComposeH DecomposeH]:
   assumes "\<langle>M; T\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P t" "\<And>t. t \<in> M \<Longrightarrow> P M t"
           "\<And>S f. \<lbrakk>length S = arity f; public f;
                   \<And>s. s \<in> set S \<Longrightarrow> \<langle>M; T\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P s;
                   \<And>s. s \<in> set S \<Longrightarrow> P M s;
                   Fun f S \<in> GSMP T - (pubval_terms \<union> abs_terms)
                   \<rbrakk> \<Longrightarrow> P M (Fun f S)"
           "\<And>t K T' t\<^sub>i. \<lbrakk>\<langle>M; T\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P t; P M t; Ana t = (K, T'); \<And>k. k \<in> set K \<Longrightarrow> \<langle>M; T\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P k;
                         \<And>k. k \<in> set K \<Longrightarrow> P M k; t\<^sub>i \<in> set T'\<rbrakk> \<Longrightarrow> P M t\<^sub>i"
   shows "P M t"
 proof -
   let ?Q = "\<lambda>t. t \<in> GSMP T - (pubval_terms \<union> abs_terms)"
   show ?thesis
     using intruder_deduct_restricted_induct[of M ?Q t "\<lambda>M Q t. P M t"] assms
     unfolding intruder_deduct_GSMP_def
     by blast
 qed
 
 lemma pubval_terms_subst:
   assumes "t \<cdot> \<theta> \<in> pubval_terms" "\<theta> ` fv t \<inter> pubval_terms = {}"
   shows "t \<in> pubval_terms"
 using assms(1,2)
 proof (induction t)
   case (Fun f T)
   let ?P = "\<lambda>f. is_PubConstValue f"
   from Fun show ?case
   proof (cases "?P f")
     case False
     then obtain t where t: "t \<in> set T" "t \<cdot> \<theta> \<in> pubval_terms"
       using Fun.prems by auto
     hence "\<theta> ` fv t \<inter> 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 \<cdot> \<theta> \<in> abs_terms" "\<theta> ` fv t \<inter> abs_terms = {}"
   shows "t \<in> abs_terms"
 using assms(1,2)
 proof (induction t)
   case (Fun f T)
   let ?P = "\<lambda>f. is_Abs f"
   from Fun show ?case
   proof (cases "?P f")
     case False
     then obtain t where t: "t \<in> set T" "t \<cdot> \<theta> \<in> abs_terms"
       using Fun.prems by auto
     hence "\<theta> ` fv t \<inter> 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 \<cdot> \<theta> \<in> pubval_terms" "\<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` (\<theta> ` fv t))"
   shows "t \<in> pubval_terms"
 proof -
   have False
     when fs: "f \<in> funs_term s" "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (\<theta> ` fv t)" "is_PubConstValue f"
     for f s
   proof -
-    obtain T where T: "Fun f T \<in> subterms s" using funs_term_Fun_subterm[OF fs(1)] by moura
+    obtain T where T: "Fun f T \<in> subterms s" using funs_term_Fun_subterm[OF fs(1)] by force
     hence "Fun f T \<in> subterms\<^sub>s\<^sub>e\<^sub>t (\<theta> ` 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 \<cdot> \<theta> \<in> abs_terms" "\<forall>n. Abs n \<notin> \<Union>(funs_term ` (\<theta> ` fv t))"
   shows "t \<in> abs_terms"
 proof -
   have "\<not>is_Abs f" when fs: "f \<in> funs_term s" "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (\<theta> ` fv t)" for f s
   proof -
-    obtain T where T: "Fun f T \<in> subterms s" using funs_term_Fun_subterm[OF fs(1)] by moura  
+    obtain T where T: "Fun f T \<in> subterms s" using funs_term_Fun_subterm[OF fs(1)] by force  
     hence "Fun f T \<in> subterms\<^sub>s\<^sub>e\<^sub>t (\<theta> ` 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 \<theta> \<inter> pubval_terms = {} \<Longrightarrow> \<theta> ` fv t \<inter> pubval_terms = {}"
 proof (induction t)
   case (Var x) thus ?case by (cases "x \<in> subst_domain \<theta>") auto
 qed auto
 
 lemma abs_terms_subst_range_disj:
   "subst_range \<theta> \<inter> abs_terms = {} \<Longrightarrow> \<theta> ` fv t \<inter> abs_terms = {}"
 proof (induction t)
   case (Var x) thus ?case by (cases "x \<in> subst_domain \<theta>") auto
 qed auto
 
 lemma pubval_terms_subst_range_comp:
   assumes "subst_range \<theta> \<inter> pubval_terms = {}" "subst_range \<delta> \<inter> pubval_terms = {}"
   shows "subst_range (\<theta> \<circ>\<^sub>s \<delta>) \<inter> pubval_terms = {}"
 proof -
   { fix t f assume t:
       "t \<in> subst_range (\<theta> \<circ>\<^sub>s \<delta>)" "f \<in> funs_term t" "is_PubConstValue f"
     then obtain x where x: "(\<theta> \<circ>\<^sub>s \<delta>) x = t" by auto
     have "\<theta> x \<notin> pubval_terms" using assms(1) by (cases "\<theta> x \<in> subst_range \<theta>") force+
     hence "(\<theta> \<circ>\<^sub>s \<delta>) x \<notin> pubval_terms"
       using assms(2) pubval_terms_subst[of "\<theta> x" \<delta>] 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 "(\<theta> ` X) \<inter> pubval_terms = {}" "(\<delta> ` fv\<^sub>s\<^sub>e\<^sub>t (\<theta> ` X)) \<inter> pubval_terms = {}"
   shows "((\<theta> \<circ>\<^sub>s \<delta>) ` X) \<inter> pubval_terms = {}"
 proof -
   { fix t f assume t:
       "t \<in> (\<theta> \<circ>\<^sub>s \<delta>) ` X" "f \<in> funs_term t" "is_PubConstValue f"
     then obtain x where x: "(\<theta> \<circ>\<^sub>s \<delta>) x = t" "x \<in> X" by auto
     have "\<theta> x \<notin> pubval_terms" using assms(1) x(2) by force
     moreover have "fv (\<theta> x) \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t (\<theta> ` X)" using x(2) by (auto simp add: fv_subset)
     hence "\<delta> ` fv (\<theta> x) \<inter> pubval_terms = {}" using assms(2) by auto
     ultimately have "(\<theta> \<circ>\<^sub>s \<delta>) x \<notin> pubval_terms"
       using pubval_terms_subst[of "\<theta> x" \<delta>]
       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 \<theta> \<inter> abs_terms = {}" "subst_range \<delta> \<inter> abs_terms = {}"
   shows "subst_range (\<theta> \<circ>\<^sub>s \<delta>) \<inter> abs_terms = {}"
 proof -
   { fix t f assume t: "t \<in> subst_range (\<theta> \<circ>\<^sub>s \<delta>)" "f \<in> funs_term t" "is_Abs f"
     then obtain x where x: "(\<theta> \<circ>\<^sub>s \<delta>) x = t" by auto
     have "\<theta> x \<notin> abs_terms" using assms(1) by (cases "\<theta> x \<in> subst_range \<theta>") force+
     hence "(\<theta> \<circ>\<^sub>s \<delta>) x \<notin> abs_terms"
       using assms(2) abs_terms_subst[of "\<theta> x" \<delta>] 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 "(\<theta> ` X) \<inter> abs_terms = {}" "(\<delta> ` fv\<^sub>s\<^sub>e\<^sub>t (\<theta> ` X)) \<inter> abs_terms = {}"
   shows "((\<theta> \<circ>\<^sub>s \<delta>) ` X) \<inter> abs_terms = {}"
 proof -
   { fix t f assume t:
       "t \<in> (\<theta> \<circ>\<^sub>s \<delta>) ` X" "f \<in> funs_term t" "is_Abs f"
     then obtain x where x: "(\<theta> \<circ>\<^sub>s \<delta>) x = t" "x \<in> X" by auto
     have "\<theta> x \<notin> abs_terms" using assms(1) x(2) by force
     moreover have "fv (\<theta> x) \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t (\<theta> ` X)" using x(2) by (auto simp add: fv_subset)
     hence "\<delta> ` fv (\<theta> x) \<inter> abs_terms = {}" using assms(2) by auto
     ultimately have "(\<theta> \<circ>\<^sub>s \<delta>) x \<notin> abs_terms"
       using abs_terms_subst[of "\<theta> x" \<delta>]
       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 \<delta>::"(('fun,'atom,'sets,'lbl) prot_fun, nat, ('fun,'atom,'sets,'lbl) prot_var) gsubst"
     and \<alpha>::"nat \<Rightarrow> 'sets set"
   assumes "Ana\<^sub>f f = (K,T)"
   shows "(K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>) \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> = K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (\<lambda>n. \<delta> n \<cdot>\<^sub>\<alpha> \<alpha>)"
 proof -
   { fix k assume "k \<in> set K"
     hence "k \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)" by force
     hence "k \<cdot> \<delta> \<cdot>\<^sub>\<alpha> \<alpha> = k \<cdot> (\<lambda>n. \<delta> n \<cdot>\<^sub>\<alpha> \<alpha>)"
     proof (induction k)
       case (Fun g S)
       have "\<And>s. s \<in> set S \<Longrightarrow> s \<cdot> \<delta> \<cdot>\<^sub>\<alpha> \<alpha> = s \<cdot> (\<lambda>n. \<delta> n \<cdot>\<^sub>\<alpha> \<alpha>)"
         using Fun.IH in_subterms_subset_Union[OF Fun.prems] Fun_param_in_subterms[of _ S g]
         by (meson contra_subsetD)
       thus ?case using Ana\<^sub>f_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 \<alpha>::"nat \<Rightarrow> '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 "\<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K) \<union> set M. i < length T"
     and "(K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T) \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> = K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (\<lambda>n. T ! n \<cdot>\<^sub>\<alpha> \<alpha>)"
   shows "(K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T) \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> = K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T)" (is "?A1 = ?A2")
     and "(map ((!) T) M) \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> = map ((!) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T)) M" (is "?B1 = ?B2")
 proof -
   have "T ! i \<cdot>\<^sub>\<alpha> \<alpha> = (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ! i" when "i \<in> fv\<^sub>s\<^sub>e\<^sub>t (set K)" for i
     using that assms(1) by auto
   hence "k \<cdot> (\<lambda>i. T ! i \<cdot>\<^sub>\<alpha> \<alpha>) = k \<cdot> (\<lambda>i. (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ! i)" when "k \<in> set K" for k
     using that term_subst_eq_conv[of k "\<lambda>i. T ! i \<cdot>\<^sub>\<alpha> \<alpha>" "\<lambda>i. (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ! i"]
     by auto
   thus "?A1 = ?A2" using assms(2) by (force simp add: abs_apply_terms_def)
 
   have "T ! i \<cdot>\<^sub>\<alpha> \<alpha> = map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T ! i" when "i \<in> 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 \<delta>::"(('fun,'atom,'sets,'lbl) prot_fun, nat, ('fun,'atom,'sets,'lbl) prot_var) gsubst"
     and \<alpha>::"nat \<Rightarrow> 'sets set"
   assumes "Ana\<^sub>f f = (K,T)"
   shows "(set K \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha> = set K \<cdot>\<^sub>s\<^sub>e\<^sub>t (\<lambda>n. \<delta> n \<cdot>\<^sub>\<alpha> \<alpha>)"
 proof -
   { fix k assume "k \<in> set K"
     hence "k \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set K)" by force
     hence "k \<cdot> \<delta> \<cdot>\<^sub>\<alpha> \<alpha> = k \<cdot> (\<lambda>n. \<delta> n \<cdot>\<^sub>\<alpha> \<alpha>)"
     proof (induction k)
       case (Fun g S)
       have "\<And>s. s \<in> set S \<Longrightarrow> s \<cdot> \<delta> \<cdot>\<^sub>\<alpha> \<alpha> = s \<cdot> (\<lambda>n. \<delta> n \<cdot>\<^sub>\<alpha> \<alpha>)"
         using Fun.IH in_subterms_subset_Union[OF Fun.prems] Fun_param_in_subterms[of _ S g]
         by (meson contra_subsetD)
       thus ?case using Ana\<^sub>f_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 \<alpha>::"nat \<Rightarrow> '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 "\<forall>i \<in> fv\<^sub>s\<^sub>e\<^sub>t K \<union> M. i < length T"
     and "(K \<cdot>\<^sub>s\<^sub>e\<^sub>t (!) T) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha> = K \<cdot>\<^sub>s\<^sub>e\<^sub>t (\<lambda>n. T ! n \<cdot>\<^sub>\<alpha> \<alpha>)"
   shows "(K \<cdot>\<^sub>s\<^sub>e\<^sub>t (!) T) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha> = K \<cdot>\<^sub>s\<^sub>e\<^sub>t (!) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T)" (is "?A1 = ?A2")
     and "((!) T ` M) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha> = (!) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ` M" (is "?B1 = ?B2")
 proof -
   have "T ! i \<cdot>\<^sub>\<alpha> \<alpha> = (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ! i" when "i \<in> fv\<^sub>s\<^sub>e\<^sub>t K" for i
     using that assms(1) by auto
   hence "k \<cdot> (\<lambda>i. T ! i \<cdot>\<^sub>\<alpha> \<alpha>) = k \<cdot> (\<lambda>i. (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ! i)" when "k \<in> K" for k
     using that term_subst_eq_conv[of k "\<lambda>i. T ! i \<cdot>\<^sub>\<alpha> \<alpha>" "\<lambda>i. (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T) ! i"]
     by auto
   thus "?A1 = ?A2" using assms(2) by (force simp add: abs_apply_terms_def)
 
   have "T ! i \<cdot>\<^sub>\<alpha> \<alpha> = map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) T ! i" when "i \<in> 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 \<cdot>\<^sub>\<alpha> \<alpha>) = (K \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha>, T \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha>)"
   using assms
 proof (induction t rule: Ana.induct)
   case (1 f S)
-  obtain K' T' where *: "Ana\<^sub>f f = (K',T')" by moura
+  obtain K' T' where *: "Ana\<^sub>f f = (K',T')" by force
   show ?case using 1
   proof (cases "arity\<^sub>f f = length S \<and> arity\<^sub>f f > 0")
     case True
     hence "K = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) S" "T = map ((!) S) T'"
         and **: "arity\<^sub>f f = length (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) S)" "arity\<^sub>f f > 0"
       using 1 * by auto
     hence "K \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> = K' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) S)"
           "T \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> = map ((!) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) S)) T'"
       using Ana\<^sub>f_assm2_alt[OF *] Ana_abs_aux2[OF _ Ana_abs_aux1[OF *], of T' S \<alpha>]
       unfolding abs_apply_list_def
       by auto
     moreover have "Fun (Fu f) S \<cdot>\<^sub>\<alpha> \<alpha> = Fun (Fu f) (map (\<lambda>s. s \<cdot>\<^sub>\<alpha> \<alpha>) 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 \<subseteq> GSMP M - (pubval_terms \<union> abs_terms)" "\<forall>t \<in> IK \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>. FP \<turnstile>\<^sub>c t"
     and t: "IK \<turnstile> t" "t \<in> GSMP M - (pubval_terms \<union> abs_terms)"
   shows "FP \<turnstile> t \<cdot>\<^sub>\<alpha> \<alpha>"
 proof -
   let ?P = "\<lambda>f. \<not>is_PubConstValue f"
   let ?GSMP = "GSMP M - (pubval_terms \<union> abs_terms)"
 
   have 1: "\<forall>m \<in> IK. m \<in> ?GSMP"
     using IK(1) by blast
 
   have 2: "\<forall>t t'. t \<in> ?GSMP \<longrightarrow> t' \<sqsubseteq> t \<longrightarrow> t' \<in> ?GSMP"
   proof (intro allI impI)
     fix t t' assume t: "t \<in> ?GSMP" "t' \<sqsubseteq> t"
     hence "t' \<in> GSMP M" using ground_subterm unfolding GSMP_def by auto
     moreover have "\<not>is_PubConstValue f"
       when "f \<in> funs_term t" for f
       using t(1) that by auto
     hence "\<not>is_PubConstValue f"
       when "f \<in> funs_term t'" for f
       using that subtermeq_imp_funs_term_subset[OF t(2)] by auto
     moreover have "\<not>is_Abs f" when "f \<in> funs_term t" for f using t(1) that by auto
     hence "\<not>is_Abs f" when "f \<in> funs_term t'" for f
       using that subtermeq_imp_funs_term_subset[OF t(2)] by auto
     ultimately show "t' \<in> ?GSMP" by simp
   qed
 
   have 3: "\<forall>t K T k. t \<in> ?GSMP \<longrightarrow> Ana t = (K, T) \<longrightarrow> k \<in> set K \<longrightarrow> k \<in> ?GSMP"
   proof (intro allI impI)
     fix t K T k assume t: "t \<in> ?GSMP" "Ana t = (K, T)" "k \<in> set K"
     hence "k \<in> GSMP M" using GSMP_Ana_key by blast
     moreover have "\<forall>f \<in> funs_term t. ?P f" using t(1) by auto
     with t(2,3) have "\<forall>f \<in> 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 "\<forall>f \<in> funs_term t. \<not>is_Abs f" using t(1) by auto
     with t(2,3) have "\<forall>f \<in> funs_term k. \<not>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 \<in> ?GSMP" by simp
   qed
 
   have "\<langle>IK; M\<rangle> \<turnstile>\<^sub>G\<^sub>S\<^sub>M\<^sub>P 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 \<cdot>\<^sub>\<alpha> \<alpha> = Fun f (map (\<lambda>t. t \<cdot>\<^sub>\<alpha> \<alpha>) T)"
       using ComposeH.hyps(2,4)
       by (cases f) auto
 
     have **: "length (map (\<lambda>t. t \<cdot>\<^sub>\<alpha> \<alpha>) 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' t\<^sub>i)
     have *: "Ana (t \<cdot>\<^sub>\<alpha> \<alpha>) = (K \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha>, T' \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha>)"
       using Ana_abs[OF DecomposeH.hyps(2)]
       by metis
 
     have **: "t\<^sub>i \<cdot>\<^sub>\<alpha> \<alpha> \<in> set (T' \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha>)"
       using DecomposeH.hyps(4) abs_in abs_list_set_is_set_abs_set[of T']
       by auto
 
     have ***: "FP \<turnstile> k"
       when k: "k \<in> set (K \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha>)" for k
     proof -
       obtain k' where k': "k' \<in> set K" "k = k' \<cdot>\<^sub>\<alpha> \<alpha>"
         by (metis (no_types) k abs_apply_terms_def imageE abs_list_set_is_set_abs_set)
 
       show "FP \<turnstile> 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 \<open>Computing and Checking Term Implications and Messages\<close>
 context stateful_protocol_model
 begin
 
 abbreviation (input) "absc s \<equiv> (Fun (Abs s) []::('fun,'atom,'sets,'lbl) prot_term)"
 
 fun absdbupd where
   "absdbupd [] _ a = a"
 | "absdbupd (insert\<langle>Var y, Fun (Set s) T\<rangle>#D) x a = (
     if x = y then absdbupd D x (insert s a) else absdbupd D x a)"
 | "absdbupd (delete\<langle>Var y, Fun (Set s) T\<rangle>#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\<langle>Var x, Fun (Set s) T\<rangle>#D) x d = absdbupd D x (insert s d)"
   "absdbupd (delete\<langle>Var x, Fun (Set s) T\<rangle>#D) x d = absdbupd D x (d - {s})"
   "t \<noteq> Var x \<or> (\<nexists>s T. u = Fun (Set s) T) \<Longrightarrow> absdbupd (insert\<langle>t,u\<rangle>#D) x d = absdbupd D x d"
   "t \<noteq> Var x \<or> (\<nexists>s T. u = Fun (Set s) T) \<Longrightarrow> absdbupd (delete\<langle>t,u\<rangle>#D) x d = absdbupd D x d"
 proof -
   assume *: "t \<noteq> Var x \<or> (\<nexists>s T. u = Fun (Set s) T)"
   let ?P = "absdbupd (insert\<langle>t,u\<rangle>#D) x d = absdbupd D x d"
   let ?Q = "absdbupd (delete\<langle>t,u\<rangle>#D) x d = absdbupd D x d"
   { fix y f T assume "t = Fun f T \<or> 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 \<noteq> Var x \<or> (\<nexists>s T. u = Fun (Set s) T)")
       case False
-      then obtain s T where "t = Var x" "u = Fun (Set s) T" by moura
+      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 \<noteq> Var x \<or> (\<nexists>s T. u = Fun (Set s) T)")
       case False
-      then obtain s T where "t = Var x" "u = Fun (Set s) T" by moura
+      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 \<equiv> unlabel (transaction_strand T)"
   define S1 where "S1 \<equiv> unlabel (transaction_receive T)"
   define S2 where "S2 \<equiv> unlabel (transaction_checks T)"
   define S3 where "S3 \<equiv> unlabel (transaction_updates T)"
   define S4 where "S4 \<equiv> 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 \<Rightarrow> 'sets set,
     ('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set,
     ('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set \<Rightarrow> bool]
   \<Rightarrow> ((('fun,'atom,'sets,'lbl) prot_var \<times> 'sets set) list) list"
 where
   "abs_substs_set [] _ _ _ _ = [[]]"
 | "abs_substs_set (x#xs) as posconstrs negconstrs msgconstrs = (
     let bs = filter (\<lambda>a. posconstrs x \<subseteq> a \<and> a \<inter> negconstrs x = {} \<and> msgconstrs x a) as;
         \<Delta> = abs_substs_set xs as posconstrs negconstrs msgconstrs
     in concat (map (\<lambda>b. map (\<lambda>\<delta>. (x, b)#\<delta>) \<Delta>) bs))"
 
 definition abs_substs_fun::
   "[(('fun,'atom,'sets,'lbl) prot_var \<times> 'sets set) list,
     ('fun,'atom,'sets,'lbl) prot_var]
   \<Rightarrow> 'sets set"
 where
   "abs_substs_fun \<delta> x = (case find (\<lambda>b. fst b = x) \<delta> of Some (_,a) \<Rightarrow> a | None \<Rightarrow> {})"
 
 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
   \<Rightarrow> (('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set)"
 where
   "transaction_poschecks_comp [] = (\<lambda>_. {})"
 | "transaction_poschecks_comp (\<langle>_: Var x \<in> Fun (Set s) []\<rangle>#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
   \<Rightarrow> (('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set)"
 where
   "transaction_negchecks_comp [] = (\<lambda>_. {})"
 | "transaction_negchecks_comp (\<langle>Var x not in Fun (Set s) []\<rangle>#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 \<delta> \<equiv>
     let (FP, _, TI) = FPT;
         C = set (unlabel (transaction_checks T));
         xs = fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T));
         \<theta> = \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x
     in (\<forall>x \<in> set (transaction_fresh T). \<delta> x = {}) \<and>
        (\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)) \<and>
        (\<forall>u \<in> C.
           (is_InSet u \<longrightarrow> (
             let x = the_elem_term u; s = the_set_term u
             in (is_Var x \<and> is_Fun_Set s) \<longrightarrow> the_Set (the_Fun s) \<in> \<delta> (the_Var x))) \<and>
           ((is_NegChecks u \<and> bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p u = [] \<and> the_eqs u = [] \<and> length (the_ins u) = 1) \<longrightarrow> (
             let x = fst (hd (the_ins u)); s = snd (hd (the_ins u))
             in (is_Var x \<and> is_Fun_Set s) \<longrightarrow> the_Set (the_Fun s) \<notin> \<delta> (the_Var x))))"
 
 definition transaction_check_post where
   "transaction_check_post FPT T \<delta> \<equiv>
     let (FP, _, TI) = FPT;
         xs = fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T));
         \<theta> = \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x;
         u = \<lambda>\<delta> x. absdbupd (unlabel (transaction_updates T)) x (\<delta> x)
     in (\<forall>x \<in> set xs - set (transaction_fresh T). \<delta> x \<noteq> u \<delta> x \<longrightarrow> List.member TI (\<delta> x, u \<delta> x)) \<and>
        (\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> (u \<delta>)))"
 
 definition fun_point_inter where "fun_point_inter f g \<equiv> \<lambda>x. f x \<inter> g x"
 definition fun_point_union where "fun_point_union f g \<equiv> \<lambda>x. f x \<union> g x"
 definition fun_point_Inter where "fun_point_Inter fs \<equiv> \<lambda>x. \<Inter>f \<in> fs. f x"
 definition fun_point_Union where "fun_point_Union fs \<equiv> \<lambda>x. \<Union>f \<in> fs. f x"
 definition fun_point_Inter_list where "fun_point_Inter_list fs \<equiv> \<lambda>x. \<Inter>(set (map (\<lambda>f. f x) fs))"
 definition fun_point_Union_list where "fun_point_Union_list fs \<equiv> \<lambda>x. \<Union>(set (map (\<lambda>f. f x) fs))"
 definition ticl_abs where "ticl_abs TI a \<equiv> set (a#map snd (filter (\<lambda>p. fst p = a) TI))"
 definition ticl_abss where "ticl_abss TI as \<equiv> \<Union>a \<in> 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 \<in> ticl_abs TI x"
 unfolding ticl_abs_def by simp
 
 lemma ticl_abs_iff:
   assumes TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "ticl_abs TI a = {b. (a,b) \<in> (set TI)\<^sup>*}"  
 proof (intro order_antisym subsetI)
   fix x assume x: "x \<in> {b. (a, b) \<in> (set TI)\<^sup>*}"
   hence "x = a \<or> (x \<noteq> a \<and> (a,x) \<in> (set TI)\<^sup>+)" by (metis mem_Collect_eq rtranclD)
   moreover have "ticl_abs TI a = {a} \<union> {b. (a,b) \<in> set TI}" unfolding ticl_abs_def by force
   ultimately show "x \<in> ticl_abs TI a" using TI by blast
 qed (fastforce simp add: ticl_abs_def)
 
 lemma ticl_abs_Inter:
   assumes xs: "\<Inter>(ticl_abs TI ` xs) \<noteq> {}"
     and TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "\<Inter>(ticl_abs TI ` \<Inter>(ticl_abs TI ` xs)) \<subseteq> \<Inter>(ticl_abs TI ` xs)"
 proof
   fix x assume x: "x \<in> \<Inter>(ticl_abs TI ` \<Inter>(ticl_abs TI ` xs))"
   have *: "\<Inter>(ticl_abs TI ` xs) = {b. \<forall>a \<in> xs. (a,b) \<in> (set TI)\<^sup>*}"
     unfolding ticl_abs_iff[OF TI] by blast
 
   have "(b,x) \<in> (set TI)\<^sup>*" when b: "\<forall>a \<in> xs. (a,b) \<in> (set TI)\<^sup>*" for b
     using x b unfolding ticl_abs_iff[OF TI] by blast
   hence "(a,x) \<in> (set TI)\<^sup>*" when "a \<in> xs" for a
     using that xs rtrancl.rtrancl_into_rtrancl[of a _ "(set TI)\<^sup>*" x]
     unfolding * rtrancl_idemp[of "set TI"] by blast
   thus "x \<in> \<Inter>(ticl_abs TI ` xs)" unfolding * by blast
 qed
 
 function (sequential) match_abss'
 ::"(('a,'b,'c,'d) prot_fun, 'e) term \<Rightarrow>
    (('a,'b,'c,'d) prot_fun, 'e) term \<Rightarrow>
    ('e \<Rightarrow> 'c set set) option"
 where
   "match_abss' (Var x) (Fun (Abs a) _) = Some ((\<lambda>_. {})(x := {a}))"
 | "match_abss' (Fun f ts) (Fun g ss) = (
     if f = g \<and> 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 \<circ> 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 \<equiv> (
     let xs = fv t;
         OCC' = set OCC;
         f = \<lambda>\<delta> x. if x \<in> xs then \<delta> x else OCC';
         g = \<lambda>\<delta> x. \<Inter>(ticl_abs TI ` \<delta> x)
     in case match_abss' t s of
       Some \<delta> \<Rightarrow>
         let \<delta>' = g \<delta>
         in if \<forall>x \<in> xs. \<delta>' x \<noteq> {} then Some (f \<delta>') else None
     | None \<Rightarrow> None)"
 
 lemma match_abss'_Var_inv:
   assumes \<delta>: "match_abss' (Var x) t = Some \<delta>"
   shows "\<exists>a ts. t = Fun (Abs a) ts \<and> \<delta> = (\<lambda>_. {})(x := {a})"
 proof -
   obtain f ts where t: "t = Fun f ts" using \<delta> by (cases t) auto
   then obtain a where a: "f = Abs a" using \<delta> by (cases f) auto
   show ?thesis using \<delta> unfolding t a by simp 
 qed
 
 lemma match_abss'_Fun_inv:
   assumes "match_abss' (Fun f ts) (Fun g ss) = Some \<delta>"
   shows "f = g" (is ?A)
     and "length ts = length ss" (is ?B)
     and "\<exists>\<theta>. Some \<theta> = those (map2 match_abss' ts ss) \<and> \<delta> = fun_point_Union_list \<theta>" (is ?C)
     and "\<forall>(t,s) \<in> set (zip ts ss). \<exists>\<sigma>. match_abss' t s = Some \<sigma>" (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 \<Delta>: "\<And>i. i < length T \<Longrightarrow> match_abss' (U ! i) (T ! i) = Some (\<Delta> i)"
     and T: "length T = length U"
   shows "match_abss' (Fun f U) (Fun f T) = Some (fun_point_Union_list (map \<Delta> [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 \<Delta> [0..<length T])"
     using \<Delta> 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 \<delta>"
     and "(t,s) \<in> set (zip ts ss)"
     and "match_abss' t s = Some \<sigma>"
   shows "\<sigma> x \<subseteq> \<delta> x"
 proof -
   obtain \<theta> where \<theta>:
       "those (map2 match_abss' ts ss) = Some \<theta>"
       "\<delta> = fun_point_Union_list \<theta>"
     using match_abss'_Fun_inv[OF assms(1)] by metis
 
   have "\<sigma> \<in> set \<theta>" using \<theta>(1) assms(2-) those_Some_iff[of "map2 match_abss' ts ss" \<theta>] by force
   thus ?thesis using \<theta>(2) unfolding fun_point_Union_list_def by auto
 qed
 
 lemma match_abss'_fv_is_nonempty:
   assumes "match_abss' t s = Some \<delta>"
     and "x \<in> fv t"
   shows "\<delta> x \<noteq> {}" (is "?P \<delta>")
 using assms
 proof (induction t s arbitrary: \<delta> rule: match_abss'.induct)
   case (2 f ts g ss)
   note prems = "2.prems"
   note IH = "2.IH"
 
   have 0: "\<forall>(t,s) \<in> set (zip ts ss). \<exists>\<sigma>. match_abss' t s = Some \<sigma>" "f = g" "length ts = length ss"
     using match_abss'_Fun_inv[OF prems(1)] by simp_all
 
   obtain t where t: "t \<in> set ts" "x \<in> fv t" using prems(2) by auto
   then obtain s where s: "s \<in> set ss" "(t,s) \<in> set (zip ts ss)"
     by (meson 0(3) in_set_impl_in_set_zip1 in_set_zipE)
   then obtain \<sigma> where \<sigma>: "match_abss' t s = Some \<sigma>" using 0(1) by fast
 
   show ?case
     using IH[OF conjI[OF 0(2,3)] s(2) _ \<sigma>] t(2) match_abss'_Fun_param_subset[OF prems(1) s(2) \<sigma>]
     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 \<delta>"
     and "\<delta> x \<noteq> {}"
   shows "x \<in> fv s"
 using assms
 proof (induction s t arbitrary: \<delta> rule: match_abss'.induct)
   case (2 f ts g ss)
   note prems = "2.prems"
   note IH = "2.IH"
 
   obtain \<theta> where \<theta>: "Some \<theta> = those (map2 match_abss' ts ss)" "\<delta> = fun_point_Union_list \<theta>"
       and fg: "f = g" "length ts = length ss"
     using match_abss'_Fun_inv[OF prems(1)] by fast
 
   have "\<exists>\<sigma> \<in> set \<theta>. \<sigma> x \<noteq> {}"
     using fg(2) prems \<theta> unfolding fun_point_Union_list_def by auto
   then obtain t' s' \<sigma> where ts':
       "(t',s') \<in> set (zip ts ss)" "match_abss' t' s' = Some \<sigma>" "\<sigma> x \<noteq> {}"
     using those_map2_SomeD[OF \<theta>(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 \<delta>"
     and "a \<in> \<delta> x"
   shows "Abs a \<in> funs_term t"
 using assms
 proof (induction s t arbitrary: a \<delta> 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 \<theta> where \<theta>: "Some \<theta> = those (map2 match_abss' ts ss)" "\<delta> = fun_point_Union_list \<theta>"
       and fg: "f = g" "length ts = length ss"
     using match_abss'_Fun_inv[OF prems(1)] by fast
 
   obtain t' s' \<sigma> where ts': "(t',s') \<in> set (zip ts ss)" "match_abss' t' s' = Some \<sigma>" "a \<in> \<sigma> x"
     using fg(2) prems \<theta> those_map2_SomeD[OF \<theta>(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 \<cdot> \<delta>) = Some \<sigma>"
     and TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "\<forall>x \<in> fv s. \<exists>a ts. \<delta> x = Fun (Abs a) ts \<and> \<sigma> x = {a}" (is "?P s \<sigma>")
 using assms(1)
 proof (induction s "s \<cdot> \<delta>" arbitrary: \<sigma> rule: match_abss'.induct)
   case (2 f ts g ss)
   note prems = "2.prems"
   note hyps = "2.hyps"
 
   obtain \<theta> where \<theta>: "Some \<theta> = those (map2 match_abss' ts ss)" "\<sigma> = fun_point_Union_list \<theta>"
       and fg: "f = g" "length ts = length ss" "ss = ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>"
       and ts: "\<forall>(t,s) \<in> set (zip ts ss). \<exists>\<sigma>. match_abss' t s = Some \<sigma>"
     using match_abss'_Fun_inv[OF prems(1)[unfolded hyps(2)[symmetric]]] hyps(2) by fastforce
 
   have 0: "those (map (\<lambda>t. match_abss' t (t \<cdot> \<delta>)) ts) = Some \<theta>"
     using \<theta>(1) map2_map_subst unfolding fg(3) by metis
 
   have 1: "\<forall>t \<in> set ts. \<exists>\<sigma>. match_abss' t (t \<cdot> \<delta>) = Some \<sigma>"
     using ts zip_map_subst[of ts \<delta>] unfolding fg(3) by simp
 
   have 2: "\<sigma>' \<in> set \<theta>"
     when t: "t \<in> set ts" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'" for t \<sigma>'
     using t 0 those_Some_iff[of "map (\<lambda>t. match_abss' t (t \<cdot> \<delta>)) ts" \<theta>] by force
 
   have 3: "?P t \<sigma>'" "\<sigma>' x \<noteq> {}"
     when t: "t \<in> set ts" "x \<in> fv t" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'" for t \<sigma>' x
     using t hyps(1)[OF conjI[OF fg(1,2)], of "(t, t \<cdot> \<delta>)" t \<sigma>'] zip_map_subst[of ts \<delta>]
           match_abss'_fv_is_nonempty[of t "t \<cdot> \<delta>" \<sigma>' x]
     unfolding fg(3) by auto
 
   have 4: "\<sigma>' x = {}"
     when t: "x \<notin> fv t" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'" for t \<sigma>' x
     by (meson t match_abss'_nonempty_is_fv)
 
   show ?case
   proof
     fix x assume "x \<in> fv (Fun f ts)"
     then obtain t \<sigma>' where t: "t \<in> set ts" "x \<in> fv t" and \<sigma>': "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'"
       using 1 by auto
     then obtain a tsa where a: "\<delta> x = Fun (Abs a) tsa"
       using 3[OF t \<sigma>'] by fast
 
     have "\<sigma>'' x = {a} \<or> \<sigma>'' x = {}"
       when "\<sigma>'' \<in> set \<theta>" for \<sigma>''
       using that a 0 3[of _ x] 4[of x]
       unfolding those_Some_iff by fastforce
     thus "\<exists>a ts. \<delta> x = Fun (Abs a) ts \<and> \<sigma> x = {a}"
       using a 2[OF t(1) \<sigma>'] 3[OF t \<sigma>'] unfolding \<theta>(2) fun_point_Union_list_def by auto
   qed
 qed auto
 
 lemma match_abss'_subst_disj_nonempty:
   assumes TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and "match_abss' s (s \<cdot> \<delta>) = Some \<sigma>"
     and "x \<in> fv s"
   shows "\<Inter>(ticl_abs TI ` \<sigma> x) \<noteq> {} \<and> (\<exists>a tsa. \<delta> x = Fun (Abs a) tsa \<and> \<sigma> x = {a})" (is "?P \<sigma>")
 using assms(2,3)
 proof (induction s "s \<cdot> \<delta>" arbitrary: \<sigma> 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 \<theta> where \<theta>: "Some \<theta> = those (map2 match_abss' ts ss)" "\<sigma> = fun_point_Union_list \<theta>"
       and fg: "f = g" "length ts = length ss" "ss = ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>"
       and ts: "\<forall>(t,s) \<in> set (zip ts ss). \<exists>\<sigma>. match_abss' t s = Some \<sigma>"
     using match_abss'_Fun_inv[OF prems(1)[unfolded hyps(2)[symmetric]]] hyps(2) by fastforce
 
   define ts' where "ts' \<equiv> filter (\<lambda>t. x \<in> fv t) ts"
   define \<theta>' where "\<theta>' \<equiv> map (\<lambda>t. (t, the (match_abss' t (t \<cdot> \<delta>)))) ts"
   define \<theta>'' where "\<theta>'' \<equiv> map (\<lambda>t. the (match_abss' t (t \<cdot> \<delta>))) ts'"
 
   have 0: "those (map (\<lambda>t. match_abss' t (t \<cdot> \<delta>)) ts) = Some \<theta>"
     using \<theta>(1) map2_map_subst unfolding fg(3) by metis
 
   have 1: "\<forall>t \<in> set ts. \<exists>\<sigma>. match_abss' t (t \<cdot> \<delta>) = Some \<sigma>"
     using ts zip_map_subst[of ts \<delta>] unfolding fg(3) by simp
 
   have ts_not_nil: "ts \<noteq> []"
     using prems(2) by fastforce
   hence "\<exists>t \<in> set ts. x \<in> fv t" using prems(2) by simp
   then obtain a tsa where a: "\<delta> x = Fun (Abs a) tsa" 
     using 1 match_abss'_subst_fv_ex_abs[OF _ TI, of _ \<delta>]
     by metis
   hence a': "\<sigma>' x = {a}"
     when "t \<in> set ts" "x \<in> fv t" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'"
     for t \<sigma>'
     using that match_abss'_subst_fv_ex_abs[OF _ TI, of _ \<delta>]
     by fastforce
 
   have "ts' \<noteq> []" using prems(2) unfolding ts'_def by (simp add: filter_empty_conv) 
   hence \<theta>''_not_nil: "\<theta>'' \<noteq> []" unfolding \<theta>''_def by simp
 
   have 2: "\<sigma>' \<in> set \<theta>"
     when t: "t \<in> set ts" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'" for t \<sigma>'
     using t 0 those_Some_iff[of "map (\<lambda>t. match_abss' t (t \<cdot> \<delta>)) ts" \<theta>] by force
 
   have 3: "?P \<sigma>'" "\<sigma>' x \<noteq> {}"
     when t: "t \<in> set ts'" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'" for t \<sigma>'
     using t hyps(1)[OF conjI[OF fg(1,2)], of "(t, t \<cdot> \<delta>)" t \<sigma>'] zip_map_subst[of ts \<delta>]
           match_abss'_fv_is_nonempty[of t "t \<cdot> \<delta>" \<sigma>' x]
     unfolding fg(3) ts'_def by (force, force)
 
   have 4: "\<sigma>' x = {}"
     when t: "x \<notin> fv t" "match_abss' t (t \<cdot> \<delta>) = Some \<sigma>'" for t \<sigma>'
     by (meson t match_abss'_nonempty_is_fv)
 
   have 5: "\<theta> = map snd \<theta>'"
     using 0 1 unfolding \<theta>'_def by (induct ts arbitrary: \<theta>) auto
 
   have "fun_point_Union_list (map snd \<theta>') x =
         fun_point_Union_list (map snd (filter (\<lambda>(t,_). x \<in> fv t) \<theta>')) x"
     using 1 4 unfolding \<theta>'_def fun_point_Union_list_def by fastforce
   hence 6: "fun_point_Union_list \<theta> x = fun_point_Union_list \<theta>'' x"
     using 0 1 4 unfolding 5 \<theta>'_def \<theta>''_def fun_point_Union_list_def ts'_def by auto
 
   have 7: "?P \<sigma>'" "\<sigma>' x \<noteq> {}"
     when \<sigma>': "\<sigma>' \<in> set \<theta>''" for \<sigma>'
     using that 1 3 unfolding \<theta>''_def ts'_def by auto
 
   have "\<sigma>' x = {a}"
     when \<sigma>': "\<sigma>' \<in> set \<theta>''" for \<sigma>'
     using \<sigma>' a' 1 unfolding \<theta>''_def ts'_def by fastforce
   hence "fun_point_Union_list \<theta>'' x = {b | b \<sigma>'. \<sigma>' \<in> set \<theta>'' \<and> b \<in> {a}}"
     using \<theta>''_not_nil unfolding fun_point_Union_list_def by auto
   hence 8: "fun_point_Union_list \<theta>'' x = {a}"
     using \<theta>''_not_nil by auto
 
   show ?case
     using 8 a
     unfolding \<theta>(2) 6 ticl_abs_iff[OF TI] by auto
 qed simp_all
 
 lemma match_abssD:
   fixes OCC TI s
   defines "f \<equiv> (\<lambda>\<delta> x. if x \<in> fv s then \<delta> x else set OCC)"
     and "g \<equiv> (\<lambda>\<delta> x. \<Inter>(ticl_abs TI ` \<delta> x))"
   assumes \<delta>': "match_abss OCC TI s t = Some \<delta>'" 
   shows "\<exists>\<delta>. match_abss' s t = Some \<delta> \<and> \<delta>' = f (g \<delta>) \<and> (\<forall>x \<in> fv s. \<delta> x \<noteq> {} \<and> f (g \<delta>) x \<noteq> {}) \<and>
              (set OCC \<noteq> {} \<longrightarrow> (\<forall>x. f (g \<delta>) x \<noteq> {}))"
 proof -
   obtain \<delta> where \<delta>: "match_abss' s t = Some \<delta>"
     using \<delta>' unfolding match_abss_def by force
   hence "Some \<delta>' = (if \<forall>x \<in> fv s. g \<delta> x \<noteq> {} then Some (f (g \<delta>)) else None)"
     using \<delta>' unfolding match_abss_def f_def g_def Let_def by simp
   hence "\<delta>' = f (g \<delta>)" "\<forall>x \<in> fv s. \<delta> x \<noteq> {} \<and> f (g \<delta>) x \<noteq> {}"
     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 \<delta>])
   thus ?thesis using \<delta> unfolding f_def by force
 qed
 
 lemma match_abss_ticl_abs_Inter_subset:
   assumes TI: "set TI = {(a,b). (a,b) \<in> (set TI)\<^sup>+ \<and> a \<noteq> b}"
     and \<delta>: "match_abss OCC TI s t = Some \<delta>"
     and x: "x \<in> fv s"
   shows "\<Inter>(ticl_abs TI ` \<delta> x) \<subseteq> \<delta> x"
 proof -
   let ?h1 = "\<lambda>\<delta> x. if x \<in> fv s then \<delta> x else set OCC"
   let ?h2 = "\<lambda>\<delta> x. \<Inter>(ticl_abs TI ` \<delta> x)"
 
   obtain \<delta>' where \<delta>':
       "match_abss' s t = Some \<delta>'" "\<delta> = ?h1 (?h2 \<delta>')"
       "\<forall>x \<in> fv s. \<delta>' x \<noteq> {} \<and> \<delta> x \<noteq> {}"
     using match_abssD[OF \<delta>] by blast
 
   have "\<delta> x = \<Inter>(ticl_abs TI ` \<delta>' x)" "\<delta>' x \<noteq> {}" "\<delta> x \<noteq> {}"
     using x \<delta>'(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 \<delta>"
     and "x \<in> fv s"
   shows "\<delta> x \<noteq> {}"
 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 \<delta>': "match_abss OCC TI s t = Some \<delta>'"
     and x: "x \<notin> fv s"
   shows "\<delta>' x = set OCC"
 proof -
   define f where "f \<equiv> \<lambda>s::(('a,'b,'c,'d) prot_fun, 'v) term. \<lambda>\<delta> x. if x \<in> fv s then \<delta> x else set OCC"
   define g where "g \<equiv> \<lambda>\<delta>. \<lambda>x::'v. \<Inter>(ticl_abs TI ` \<delta> x)"
 
   obtain \<delta> where \<delta>: "match_abss' s t = Some \<delta>" "\<delta>' = f s (g \<delta>)"
     using match_abssD[OF \<delta>'] unfolding f_def g_def by blast
 
   show ?thesis
     using x \<delta>(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 [] (\<lambda>_. set OCC)"
 | SolveCons:
     "ts \<noteq> [] \<Longrightarrow> \<forall>t \<in> set ts. synth_abs_substs_constrs_rel FP OCC TI [t] (\<theta> t)
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI ts (fun_point_Inter (\<theta> ` set ts))"
 | SolvePubConst:
     "arity c = 0 \<Longrightarrow> public c
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI [Fun c []] (\<lambda>_. set OCC)"
 | SolvePrivConstIn:
     "arity c = 0 \<Longrightarrow> \<not>public c \<Longrightarrow> Fun c [] \<in> set FP
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI [Fun c []] (\<lambda>_. set OCC)"
 | SolvePrivConstNotin:
     "arity c = 0 \<Longrightarrow> \<not>public c \<Longrightarrow> Fun c [] \<notin> set FP
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI [Fun c []] (\<lambda>_. {})"
 | SolveValueVar:
     "\<theta> = ((\<lambda>_. set OCC)(x := ticl_abss TI {a \<in> set OCC. \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s \<in> set FP}))
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI [Var x] \<theta>"
 | SolveComposed:
     "arity f > 0 \<Longrightarrow> length ts = arity f
       \<Longrightarrow> \<forall>\<delta>. \<delta> \<in> \<Delta> \<longleftrightarrow> (\<exists>s \<in> set FP. match_abss OCC TI (Fun f ts) s = Some \<delta>)
       \<Longrightarrow> \<theta>1 = fun_point_Union \<Delta>
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI ts \<theta>2
       \<Longrightarrow> synth_abs_substs_constrs_rel FP OCC TI [Fun f ts] (fun_point_union \<theta>1 \<theta>2)"
 
 fun synth_abs_substs_constrs_aux where
   "synth_abs_substs_constrs_aux FP OCC TI (Var x) = (
     (\<lambda>_. set OCC)(x := ticl_abss TI (set (filter (\<lambda>a. \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s \<in> set FP) OCC))))"
 | "synth_abs_substs_constrs_aux FP OCC TI (Fun f ts) = (
     if ts = []
     then if \<not>public f \<and> Fun f ts \<notin> set FP then (\<lambda>_. {}) else (\<lambda>_. set OCC)
     else let \<Delta> = map the (filter (\<lambda>\<delta>. \<delta> \<noteq> None) (map (match_abss OCC TI (Fun f ts)) FP));
              \<theta>1 = fun_point_Union_list \<Delta>;
              \<theta>2 = fun_point_Inter_list (map (synth_abs_substs_constrs_aux FP OCC TI) ts)
          in fun_point_union \<theta>1 \<theta>2)"
 
 definition synth_abs_substs_constrs where
   "synth_abs_substs_constrs FPT T \<equiv>
     let (FP,OCC,TI) = FPT;
         ts = trms_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_receive T));
         f = fun_point_Inter_list \<circ> map (synth_abs_substs_constrs_aux FP OCC TI)
     in if ts = [] then (\<lambda>_. set OCC) else f ts"
 
 (* definition synth_abs_substs_constrs where
   "synth_abs_substs_constrs FPT T \<equiv>
     let (FP,OCC,TI) = FPT;
         negsy = Not \<circ> intruder_synth_mod_timpls FP TI;
         \<Theta> = \<lambda>\<delta> x. let as = \<delta> x in if as \<noteq> {} then as else set OCC;
         C = unlabel (transaction_checks T);
         poss = transaction_poschecks_comp C;
         negs = transaction_negchecks_comp C;
         ts = trms_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_receive T));
         f = \<lambda>t. let \<Delta> = map the (filter (\<lambda>\<delta>. \<delta> \<noteq> None) (map (match_abss OCC TI t) FP))
                 in fun_point_Union_list (map \<Theta> \<Delta>);
         g = \<lambda>t. if is_Fun t \<and> args t \<noteq> []
                 then let s = hd (args t)
                 in case fv_list s of
                    [] \<Rightarrow> if negsy s then Some (f t) else None
                  | [x] \<Rightarrow> let bs = filter (\<lambda>a. poss x \<subseteq> a \<and> a \<inter> negs x = {}) OCC
                           in if list_all (\<lambda>b. negsy (s \<cdot> Var(x := \<langle>b\<rangle>\<^sub>a\<^sub>b\<^sub>s))) bs
                              then Some (f t) else None
                  | _ \<Rightarrow> None
                 else None;
         h = \<lambda>t. case g t of Some d \<Rightarrow> d | None \<Rightarrow> synth_abs_substs_constrs_aux FP OCC TI t
     in if ts = [] then (\<lambda>_. set OCC) else fun_point_Inter_list (map h ts)" *)
 (*
 poss = transaction_poschecks_comp (C A);
       negs = transaction_negchecks_comp (C A);
       bs = filter (\<lambda>a. poss PK \<subseteq> a \<and> a \<inter> negs PK = {}) OCC
     in if list_all (Not \<circ> sy \<circ> s A) bs
        then Some (map the (filter (\<lambda>\<delta>. \<delta> \<noteq> None) (map (match_abss OCC TI (t' A)) FP)))
        else None
 *)
 definition transaction_check_comp::
   "[('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set \<Rightarrow> bool,
     ('fun,'atom,'sets,'lbl) prot_term list \<times>
     'sets set list \<times>
     ('sets set \<times> 'sets set) list,
     ('fun,'atom,'sets,'lbl) prot_transaction]
   \<Rightarrow> ((('fun,'atom,'sets,'lbl) prot_var \<times> 'sets set) list) list"
 where
   "transaction_check_comp msgcs FPT T \<equiv>
     let (_, OCC, _) = FPT;
         S = unlabel (transaction_strand T);
         C = unlabel (transaction_checks T);
         xs = filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S);
         posconstrs = transaction_poschecks_comp C;
         negconstrs = transaction_negchecks_comp C;
         pre_check = transaction_check_pre FPT T;
         \<Delta> = abs_substs_set xs OCC posconstrs negconstrs msgcs
     in filter (\<lambda>\<delta>. pre_check (abs_substs_fun \<delta>)) \<Delta>"
 
 definition transaction_check'::
   "[('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set \<Rightarrow> bool,
     ('fun,'atom,'sets,'lbl) prot_term list \<times>
     'sets set list \<times>
     ('sets set \<times> 'sets set) list,
     ('fun,'atom,'sets,'lbl) prot_transaction]
   \<Rightarrow> bool"
 where
   "transaction_check' msgcs FPT T \<equiv>
     list_all (\<lambda>\<delta>. transaction_check_post FPT T (abs_substs_fun \<delta>))
              (transaction_check_comp msgcs FPT T)"
 
 definition transaction_check::
   "[('fun,'atom,'sets,'lbl) prot_term list \<times>
     'sets set list \<times>
     ('sets set \<times> 'sets set) list,
     ('fun,'atom,'sets,'lbl) prot_transaction]
   \<Rightarrow> bool"
 where
   "transaction_check \<equiv> transaction_check' (\<lambda>_ _. True)"
 
 definition transaction_check_coverage_rcv::
   "[('fun,'atom,'sets,'lbl) prot_term list \<times>
     'sets set list \<times>
     ('sets set \<times> 'sets set) list,
     ('fun,'atom,'sets,'lbl) prot_transaction]
   \<Rightarrow> bool"
 where
   "transaction_check_coverage_rcv FPT T \<equiv>
     let msgcs = synth_abs_substs_constrs FPT T
     in transaction_check' (\<lambda>x a. a \<in> msgcs x) FPT T"
 
 lemma abs_subst_fun_cons:
   "abs_substs_fun ((x,b)#\<delta>) = (abs_substs_fun \<delta>)(x := b)"
 unfolding abs_substs_fun_def by fastforce
 
 lemma abs_substs_cons:
   assumes "\<delta> \<in> set (abs_substs_set xs as poss negs msgcs)"
           "b \<in> set as" "poss x \<subseteq> b" "b \<inter> negs x = {}" "msgcs x b"
   shows "(x,b)#\<delta> \<in> set (abs_substs_set (x#xs) as poss negs msgcs)"
 using assms by auto
 
 lemma abs_substs_cons':
   assumes \<delta>: "\<delta> \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
     and b: "b \<in> set as" "poss x \<subseteq> b" "b \<inter> negs x = {}" "msgcs x b"
   shows "\<delta>(x := b) \<in> abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs msgcs)"
 proof -
   obtain \<theta> where \<theta>: "\<delta> = abs_substs_fun \<theta>" "\<theta> \<in> set (abs_substs_set xs as poss negs msgcs)"
-    using \<delta> by moura
+    using \<delta> by force
   have "abs_substs_fun ((x, b)#\<theta>) \<in> abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs msgcs)"
     using abs_substs_cons[OF \<theta>(2) b] by blast
   thus ?thesis
     using \<theta>(1) abs_subst_fun_cons[of x b \<theta>] by argo
 qed
 
 lemma abs_substs_has_abs:
   assumes "\<forall>x. x \<in> set xs \<longrightarrow> \<delta> x \<in> set as"
     and "\<forall>x. x \<in> set xs \<longrightarrow> poss x \<subseteq> \<delta> x"
     and "\<forall>x. x \<in> set xs \<longrightarrow> \<delta> x \<inter> negs x = {}"
     and "\<forall>x. x \<in> set xs \<longrightarrow> msgcs x (\<delta> x)"
     and "\<forall>x. x \<notin> set xs \<longrightarrow> \<delta> x = {}"
   shows "\<delta> \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
 using assms
 proof (induction xs arbitrary: \<delta>)
   case (Cons x xs)
   define \<theta> where "\<theta> \<equiv> \<lambda>y. if y \<in> set xs then \<delta> y else {}"
 
   have "\<theta> \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
     using Cons.prems Cons.IH by (simp add: \<theta>_def)
   moreover have "\<delta> x \<in> set as" "poss x \<subseteq> \<delta> x" "\<delta> x \<inter> negs x = {}" "msgcs x (\<delta> x)"
     by (simp_all add: Cons.prems(1,2,3,4))
   ultimately have 0: "\<theta>(x := \<delta> x) \<in> abs_substs_fun ` set (abs_substs_set (x#xs) as poss negs msgcs)"
     by (metis abs_substs_cons')
 
   have "\<delta> = \<theta>(x := \<delta> x)"
   proof
     fix y show "\<delta> y = (\<theta>(x := \<delta> x)) y"
     proof (cases "y \<in> set (x#xs)")
       case False thus ?thesis using Cons.prems(5) by (fastforce simp add: \<theta>_def)
     qed (auto simp add: \<theta>_def)
   qed
   thus ?case by (metis 0)
 qed (auto simp add: abs_substs_fun_def)
 
 lemma abs_substs_abss_bounded:
   assumes "\<delta> \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
     and "x \<in> set xs"
   shows "\<delta> x \<in> set as"
     and "poss x \<subseteq> \<delta> x"
     and "\<delta> x \<inter> negs x = {}"
     and "msgcs x (\<delta> x)"
 using assms
 proof (induct xs as poss negs msgcs arbitrary: \<delta> 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 \<delta>' where \<delta>':
           "\<delta>' \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)" "\<delta>' x = \<delta> x"
         using 2 unfolding abs_substs_fun_def by force
       moreover have "x \<in> set xs" using 2(2) False by simp
       moreover have "\<exists>b. b \<in> set as \<and> poss y \<subseteq> b \<and> b \<inter> 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 \<delta>' where \<delta>':
           "\<delta>' \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)" "\<delta>' x = \<delta> x"
         using 3 unfolding abs_substs_fun_def by force
       moreover have "x \<in> set xs" using 3(2) False by simp
       moreover have "\<exists>b. b \<in> set as \<and> poss y \<subseteq> b \<and> b \<inter> 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 \<delta>' where \<delta>':
           "\<delta>' \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)" "\<delta>' x = \<delta> x"
         using 4 unfolding abs_substs_fun_def by force
       moreover have "x \<in> set xs" using 4(2) False by simp
       moreover have "\<exists>b. b \<in> set as \<and> poss y \<subseteq> b \<and> b \<inter> 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 "\<delta> \<in> abs_substs_fun ` set (abs_substs_set xs as poss negs msgcs)"
     and "x \<notin> set xs"
   shows "\<delta> x = {}"
 using assms unfolding abs_substs_fun_def
 by (induct xs as poss negs msgcs arbitrary: \<delta> rule: abs_substs_set_induct) (force, fastforce)
 
 lemma transaction_poschecks_comp_unfold:
   "transaction_poschecks_comp C x = {s. \<exists>a. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> set C}"
 proof (induction C)
   case (Cons c C) thus ?case
   proof (cases "\<exists>a y s. c = \<langle>a: Var y \<in> Fun (Set s) []\<rangle>")
     case True
-    then obtain a y s where c: "c = \<langle>a: Var y \<in> Fun (Set s) []\<rangle>" by moura
+    then obtain a y s where c: "c = \<langle>a: Var y \<in> Fun (Set s) []\<rangle>" by force
 
     define f where "f \<equiv> 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. \<exists>a. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> 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 \<notin> fv\<^sub>s\<^sub>s\<^sub>t 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. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> set C}"
 proof (induction C)
   case (Cons c C) thus ?case
   proof (cases "\<exists>y s. c = \<langle>Var y not in Fun (Set s) []\<rangle>")
     case True
-    then obtain y s where c: "c = \<langle>Var y not in Fun (Set s) []\<rangle>" by moura
+    then obtain y s where c: "c = \<langle>Var y not in Fun (Set s) []\<rangle>" by force
 
     define f where "f \<equiv> 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. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> 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 \<notin> fv\<^sub>s\<^sub>s\<^sub>t 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 "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
     and "C \<equiv> set (unlabel (transaction_checks T))"
   assumes a0: "\<forall>x \<in> set (transaction_fresh T). \<delta> x = {}"
     and a1: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> \<delta> x \<in> set OCC"
     and a2: "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)"
     and a3: "\<forall>a x s. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<delta> x"
     and a4: "\<forall>x s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<notin> \<delta> x"
   shows "transaction_check_pre (FP, OCC, TI) T \<delta>"
 proof -
   let ?P = "\<lambda>u. is_InSet u \<longrightarrow> (
     let x = the_elem_term u; s = the_set_term u
     in (is_Var x \<and> is_Fun_Set s) \<longrightarrow> the_Set (the_Fun s) \<in> \<delta> (the_Var x))"
 
   let ?Q = "\<lambda>u. (is_NegChecks u \<and> bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p u = [] \<and> the_eqs u = [] \<and> length (the_ins u) = 1) \<longrightarrow> (
     let x = fst (hd (the_ins u)); s = snd (hd (the_ins u))
     in (is_Var x \<and> is_Fun_Set s) \<longrightarrow> the_Set (the_Fun s) \<notin> \<delta> (the_Var x))"
 
   have 1: "?P u" when u: "u \<in> 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 \<in> 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_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
     unfolding transaction_check_pre_def \<theta>_def C_def Let_def
     by blast
 qed
 
 lemma transaction_check_pre_InSetE:
   assumes T: "transaction_check_pre FPT T \<delta>"
     and u: "u = \<langle>a: Var x \<in> Fun (Set s) []\<rangle>"
            "u \<in> set (unlabel (transaction_checks T))"
   shows "s \<in> \<delta> x"
 proof -
   have "is_InSet u \<longrightarrow> is_Var (the_elem_term u) \<and> is_Fun_Set (the_set_term u) \<longrightarrow>
         the_Set (the_Fun (the_set_term u)) \<in> \<delta> (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 \<delta>"
     and u: "u = \<langle>Var x not in Fun (Set s) []\<rangle>"
            "u \<in> set (unlabel (transaction_checks T))"
   shows "s \<notin> \<delta> x"
 proof -
   have "is_NegChecks u \<and> bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p u = [] \<and> the_eqs u = [] \<and> length (the_ins u) = 1 \<longrightarrow>
          is_Var (fst (hd (the_ins u))) \<and> is_Fun_Set (snd (hd (the_ins u))) \<longrightarrow>
          the_Set (the_Fun (snd (hd (the_ins u)))) \<notin> \<delta> (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 "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
   assumes T: "transaction_check_pre (FP, OCC, TI) T \<delta>"
     and t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
   shows "intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)"
 using T t unfolding transaction_check_pre_def Let_def \<theta>_def by blast
 
 lemma transaction_check_compI[intro]:
   assumes T: "transaction_check_pre (FP, OCC, TI) T \<delta>"
     and T_adm: "admissible_transaction' T"
     and x1: "\<forall>x. (x \<in> fv_transaction T - set (transaction_fresh T) \<and> fst x = TAtom Value)
                   \<longrightarrow> \<delta> x \<in> set OCC \<and> msgcs x (\<delta> x)"
     and x2: "\<forall>x. (x \<notin> fv_transaction T - set (transaction_fresh T) \<or> fst x \<noteq> TAtom Value)
                   \<longrightarrow> \<delta> x = {}"
   shows "\<delta> \<in> abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T)"
 proof -
   define S where "S \<equiv> unlabel (transaction_strand T)"
   define C where "C \<equiv> unlabel (transaction_checks T)"
 
   let ?xs = "fv_list\<^sub>s\<^sub>s\<^sub>t S"
 
   define poss where "poss \<equiv> transaction_poschecks_comp C"
   define negs where "negs \<equiv> transaction_negchecks_comp C"
   define ys where "ys \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) ?xs"
 
   have ys: "{x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value} = set ys"
     using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of S]
     unfolding ys_def S_def by force
   
   have "\<delta> x \<in> set OCC" "msgcs x (\<delta> x)"
     when x: "x \<in> set ys" for x
     using x1 x ys by (blast, blast)
   moreover have "\<delta> x = {}"
     when x: "x \<notin> set ys" for x
     using x2 x ys by blast
   moreover have "poss x \<subseteq> \<delta> x" when x: "x \<in> set ys" for x
   proof -
     have "s \<in> \<delta> x" when u: "u = \<langle>a: Var x \<in> Fun (Set s) []\<rangle>" "u \<in> set C" for u a s
       using T u transaction_check_pre_InSetE[of "(FP, OCC, TI)" T \<delta>]
       unfolding C_def by blast
     thus ?thesis
       using transaction_poschecks_comp_unfold[of C x]
       unfolding poss_def by blast
   qed
   moreover have "\<delta> x \<inter> negs x = {}" when x: "x \<in> set ys" for x
   proof (cases "x \<in> fv\<^sub>s\<^sub>s\<^sub>t C")
     case True
     hence "s \<notin> \<delta> x" when u: "u = \<langle>Var x not in Fun (Set s) []\<rangle>" "u \<in> set C" for u s
       using T u transaction_check_pre_NotInSetE[of "(FP, OCC, TI)" T \<delta>]
       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 "\<delta> \<in> abs_substs_fun ` set (abs_substs_set ys OCC poss negs msgcs)"
     using abs_substs_has_abs[of ys \<delta> 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 \<equiv> set (unlabel (transaction_checks T))"
   assumes T_adm: "admissible_transaction' T"
     and a1: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> (\<forall>s.
           select\<langle>Var x, Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha> x)"
     and a2: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> (\<forall>s.
           \<langle>Var x in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha> x)"
     and a3: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> (\<forall>s.
           \<langle>Var x not in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<notin> \<alpha> x)"
   shows "\<forall>a x s. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha> x" (is ?A)
     and "\<forall>x s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<notin> \<alpha> x" (is ?B)
 proof -
   note * = admissible_transaction_strand_step_cases(2,3)[OF T_adm]
 
   have 1: "fst x = TAtom Value" "x \<in> fv_transaction T - set (transaction_fresh T)"
     when x: "\<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> C" for a x s
     using * x unfolding C_def by fast+
 
   have 2: "fst x = TAtom Value" "x \<in> fv_transaction T - set (transaction_fresh T)"
     when x: "\<langle>Var x not in Fun (Set s) []\<rangle> \<in> C" for x s
     using * x unfolding C_def by fast+
 
   show ?A
   proof (intro allI impI)
     fix a x s assume u: "\<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> C"
     thus "s \<in> \<alpha> x" using 1 a1 a2 by (cases a) metis+
   qed
 
   show ?B
   proof (intro allI impI)
     fix x s assume u: "\<langle>Var x not in Fun (Set s) []\<rangle> \<in> C"
     thus "s \<notin> \<alpha> x" using 2 a3 by meson
   qed
 qed
 
 lemma transaction_check_comp_in:
   fixes T
   defines "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
     and "C \<equiv> set (unlabel (transaction_checks T))"
   assumes T_adm: "admissible_transaction' T"
     and a1: "\<forall>x \<in> set (transaction_fresh T). \<alpha> x = {}"
     and a2: "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<alpha>)"
     and a3: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). \<forall>s.
           select\<langle>Var x, Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha> x"
     and a4: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). \<forall>s.
           \<langle>Var x in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha> x"
     and a5: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). \<forall>s.
           \<langle>Var x not in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<notin> \<alpha> x"
     and a6: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
           fst x = TAtom Value \<longrightarrow> \<alpha> x \<in> set OCC"
     and a7: "\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
           fst x = TAtom Value \<longrightarrow> msgcs x (\<alpha> x)"
   shows "\<exists>\<delta> \<in> abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T).
           \<forall>x \<in> fv_transaction T. fst x = TAtom Value \<longrightarrow> \<alpha> x = \<delta> x"
 proof -
   let ?xs = "fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
   let ?ys = "filter (\<lambda>x. x \<notin> set (transaction_fresh T)) ?xs"
 
   define \<alpha>' where "\<alpha>' \<equiv> \<lambda>x.
     if x \<in> fv_transaction T - set (transaction_fresh T) \<and> fst x = TAtom Value
     then \<alpha> x
     else {}"
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have \<theta>\<alpha>_Fun: "is_Fun (t \<cdot> \<theta> \<alpha>) \<longleftrightarrow> is_Fun (t \<cdot> \<theta> \<alpha>')" for t
     unfolding \<alpha>'_def \<theta>_def
     by (induct t) auto
 
   have "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<alpha>')"
   proof (intro ballI impI)
     fix t assume t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
 
     have 1: "intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<alpha>)"
       using t a2
       by auto
 
     obtain r where r:
         "r \<in> set (unlabel (transaction_receive T))"
         "t \<in> trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r"
       using t by auto
     hence "\<exists>ts. r = receive\<langle>ts\<rangle> \<and> t \<in> set ts"
       using wellformed_transaction_unlabel_cases(1)[OF T_wf]
       by fastforce
     hence 2: "fv t \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)" using r by force
 
     have "fv t \<subseteq> 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 \<inter> set (transaction_fresh T) = {}"
       using 2 T_wf vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_receive T)"]
       unfolding wellformed_transaction_def
       by fast
     ultimately have "\<theta> \<alpha> x = \<theta> \<alpha>' x" when "x \<in> fv t" for x
       using that unfolding \<alpha>'_def \<theta>_def by fastforce
     hence 3: "t \<cdot> \<theta> \<alpha> = t \<cdot> \<theta> \<alpha>'"
       using term_subst_eq by blast
 
     show "intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<alpha>')" using 1 3 by simp
   qed
   moreover have
       "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> (\<forall>s.
           select\<langle>Var x, Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha>' x)"
       "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> (\<forall>s.
           \<langle>Var x in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha>' x)"
       "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value \<longrightarrow> (\<forall>s.
           \<langle>Var x not in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<notin> \<alpha>' x)"
     using a3 a4 a5
     unfolding \<alpha>'_def \<theta>_def C_def
     by meson+
   hence "\<forall>a x s. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<in> \<alpha>' x"
         "\<forall>x s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> C \<longrightarrow> s \<notin> \<alpha>' x"
     using transaction_check_comp_in_aux[OF T_adm, of \<alpha>']
     unfolding C_def
     by (fast, fast)
   ultimately have 4: "transaction_check_pre (FP, OCC, TI) T \<alpha>'"
     using a6 transaction_check_preI[of T \<alpha>' OCC FP TI]
     unfolding \<alpha>'_def \<theta>_def C_def
     by simp
 
   have 5: "\<forall>x \<in> fv_transaction T. fst x = TAtom Value \<longrightarrow> \<alpha> x = \<alpha>' x"
     using a1 by (auto simp add: \<alpha>'_def)
 
   have 6: "\<alpha>' \<in> 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 \<alpha>'_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 \<open>Soundness of the Occurs-Message Transformation\<close>
 context stateful_protocol_model
 begin
 
 context
 begin
 
 text \<open>The occurs-message transformation, \<open>add_occurs_msgs\<close>, extends a transaction \<open>T\<close> with
 additional message-transmission steps such that the following holds:
 1. for each fresh variable \<open>x\<close> of \<open>T\<close> the message \<open>occurs (Var x)\<close> now occurs in a send-step,
 2. for each of the remaining free variables \<open>x\<close> of \<open>T\<close> the message \<open>occurs (Var x)\<close> now occurs in a
 receive-step.\<close>
 definition add_occurs_msgs where
   "add_occurs_msgs T \<equiv>
     let frsh = transaction_fresh T;
         xs = filter (\<lambda>x. x \<notin> set frsh) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)));
         f = map (\<lambda>x. occurs (Var x));
         g = \<lambda>C. if xs = [] then C else \<langle>\<star>, receive\<langle>f xs\<rangle>\<rangle>#C;
         h = \<lambda>F. if frsh = [] then F
                 else if F \<noteq> [] \<and> fst (hd F) = \<star> \<and> is_Send (snd (hd F))
                 then \<langle>\<star>,send\<langle>f frsh@the_msgs (snd (hd F))\<rangle>\<rangle>#tl F
                 else \<langle>\<star>,send\<langle>f frsh\<rangle>\<rangle>#F
     in case T of Transaction A B C D E F \<Rightarrow> 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\<langle>ts\<rangle>)#A) = (
     if \<exists>t. occurs t \<in> set ts
     then if \<exists>t \<in> set ts. \<forall>s. t \<noteq> occurs s
          then (l,receive\<langle>filter (\<lambda>t. \<forall>s. t \<noteq> occurs s) ts\<rangle>)#rm_occurs_msgs_constr A
          else rm_occurs_msgs_constr A
     else (l,receive\<langle>ts\<rangle>)#rm_occurs_msgs_constr A)"
 | "rm_occurs_msgs_constr ((l,send\<langle>ts\<rangle>)#A) = (
     if \<exists>t. occurs t \<in> set ts
     then if \<exists>t \<in> set ts. \<forall>s. t \<noteq> occurs s
          then (l,send\<langle>filter (\<lambda>t. \<forall>s. t \<noteq> occurs s) ts\<rangle>)#rm_occurs_msgs_constr A
          else rm_occurs_msgs_constr A
     else (l,send\<langle>ts\<rangle>)#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' \<equiv> add_occurs_msgs T"
     and "frsh \<equiv> transaction_fresh T"
     and "xs \<equiv> filter (\<lambda>x. x \<notin> set frsh) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
     and "xs' \<equiv> fv_transaction T - set frsh"
     and "f \<equiv> map (\<lambda>x. occurs (Var x))"
     and "C' \<equiv> if xs = [] then C else \<langle>\<star>, receive\<langle>f xs\<rangle>\<rangle>#C"
     and "ts' \<equiv> f frsh"
   assumes T: "T = Transaction A B C D E F"
   shows "F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow> T' = Transaction A B C' D E (\<langle>\<star>,send\<langle>ts'@ts\<rangle>\<rangle>#F')"
     (is "?A ts F' \<Longrightarrow> ?A' ts F'")
   and "\<nexists>ts' F'. F = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F' \<Longrightarrow> frsh \<noteq> [] \<Longrightarrow> T' = Transaction A B C' D E (\<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F)"
     (is "?B \<Longrightarrow> ?B' \<Longrightarrow> ?B''")
   and "frsh = [] \<Longrightarrow> T' = Transaction A B C' D E F" (is "?C \<Longrightarrow> ?C'")
   and "transaction_decl T' = transaction_decl T"
   and "transaction_fresh T' = transaction_fresh T"
   and "xs = [] \<Longrightarrow> transaction_receive T' = transaction_receive T"
   and "xs \<noteq> [] \<Longrightarrow> transaction_receive T' = \<langle>\<star>,receive\<langle>f xs\<rangle>\<rangle>#transaction_receive T"
   and "transaction_checks T' = transaction_checks T"
   and "transaction_updates T' = transaction_updates T"
   and "transaction_send T = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
         transaction_send T' = \<langle>\<star>,send\<langle>ts'@ts\<rangle>\<rangle>#F'" (is "?D ts F' \<Longrightarrow> ?D' ts F'")
   and "\<nexists>ts' F'. transaction_send T = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F' \<Longrightarrow> frsh \<noteq> [] \<Longrightarrow>
         transaction_send T' = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#transaction_send T" (is "?E \<Longrightarrow> ?E' \<Longrightarrow> ?E''")
   and "frsh = [] \<Longrightarrow> transaction_send T' = transaction_send T" (is "?F \<Longrightarrow> ?F'")
   and "(xs' \<noteq> {} \<and> transaction_receive T' = \<langle>\<star>, receive\<langle>f xs\<rangle>\<rangle>#transaction_receive T) \<or>
        (xs' = {} \<and> transaction_receive T' = transaction_receive T)" (is ?G)
   and "(frsh \<noteq> [] \<and> (\<exists>ts F'.
           transaction_send T = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<and> transaction_send T' = \<langle>\<star>,send\<langle>ts'@ts\<rangle>\<rangle>#F')) \<or>
        (frsh \<noteq> [] \<and> transaction_send T' = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#transaction_send T) \<or>
        (frsh = [] \<and> 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' \<Longrightarrow> ?A' ts F'" for ts F' unfolding defs by simp
 
   have "F = [] \<or> fst (hd F) \<noteq> \<star> \<or> \<not>is_Send (snd (hd F))" when ?B
     using that unfolding is_Send_def by (cases F) auto
   thus 1: "?B \<Longrightarrow> ?B' \<Longrightarrow> ?B''" unfolding defs by force
 
   show "?C \<Longrightarrow> ?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 = [] \<Longrightarrow> transaction_receive T' = transaction_receive T"
        "xs \<noteq> [] \<Longrightarrow> transaction_receive T' = \<langle>\<star>, receive\<langle>f xs\<rangle>\<rangle>#transaction_receive T"
     unfolding defs by simp_all
   moreover have "xs = [] \<longleftrightarrow> xs' = {}"
     using filter_empty_conv[of "\<lambda>x. x \<notin> set frsh"]
           fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
     unfolding xs_def xs'_def by blast
   ultimately show ?G by blast
 
   show 2: "?D ts F' \<Longrightarrow> ?D' ts F'" for ts F' using 0 unfolding T by simp
   show 3: "?E \<Longrightarrow> ?E' \<Longrightarrow> ?E''" using 1 unfolding T by force
   show 4: "?F \<Longrightarrow> ?F'" unfolding defs by simp
 
   show ?H
   proof (cases "frsh = []")
     case False thus ?thesis
       using 2 3[OF _ False] by (cases "\<exists>ts F'. transaction_send T = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F'") (blast,blast)
   qed (simp add: 4)
 qed
 
 private lemma add_occurs_msgs_transaction_strand_set:
   fixes T C frsh xs f
   defines "frsh \<equiv> transaction_fresh T"
     and "xs \<equiv> filter (\<lambda>x. x \<notin> set frsh) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
     and "f \<equiv> map (\<lambda>x. occurs (Var x))"
   assumes T: "T = Transaction A B C D E F"
   shows "F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           set (transaction_strand (add_occurs_msgs T)) \<subseteq>
           set (transaction_strand T) \<union> {\<langle>\<star>,receive\<langle>f xs\<rangle>\<rangle>,\<langle>\<star>,send\<langle>f frsh@ts\<rangle>\<rangle>}"
     (is "?A \<Longrightarrow> ?A'")
   and "F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           set (unlabel (transaction_strand (add_occurs_msgs T))) \<subseteq>
           set (unlabel (transaction_strand T)) \<union> {receive\<langle>f xs\<rangle>,send\<langle>f frsh@ts\<rangle>}"
     (is "?B \<Longrightarrow> ?B'")
   and "\<nexists>ts' F'. F = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F' \<Longrightarrow>
           set (transaction_strand (add_occurs_msgs T)) \<subseteq>
           set (transaction_strand T) \<union> {\<langle>\<star>,receive\<langle>f xs\<rangle>\<rangle>,\<langle>\<star>,send\<langle>f frsh\<rangle>\<rangle>}"
     (is "?C \<Longrightarrow> ?C'")
   and "\<nexists>ts' F'. F = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F' \<Longrightarrow>
           set (unlabel (transaction_strand (add_occurs_msgs T))) \<subseteq>
           set (unlabel (transaction_strand T)) \<union> {receive\<langle>f xs\<rangle>,send\<langle>f frsh\<rangle>}"
     (is "?D \<Longrightarrow> ?D'")
 proof -
   note 0 = add_occurs_msgs_cases[
             OF T, unfolded frsh_def[symmetric] xs_def[symmetric] f_def[symmetric]]
 
   show "?A \<Longrightarrow> ?A'" using 0(1,3) unfolding T transaction_strand_def by (cases "frsh = []") auto
   thus "?B \<Longrightarrow> ?B'" unfolding unlabel_def by force
 
   show "?C \<Longrightarrow> ?C'" using 0(2,3) unfolding T transaction_strand_def by (cases "frsh = []") auto
   thus "?D \<Longrightarrow> ?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 \<theta>
   defines "T' \<equiv> add_occurs_msgs T"
     and "S \<equiv> transaction_strand T"
     and "S' \<equiv> transaction_strand T'"
     and "frsh \<equiv> transaction_fresh T"
     and "xs \<equiv> filter (\<lambda>x. x \<notin> set frsh) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
     and "f \<equiv> map (\<lambda>x. occurs (Var x))"
     and "C \<equiv> transaction_receive T"
     and "D \<equiv> transaction_checks T"
     and "E \<equiv> transaction_updates T"
     and "F \<equiv> transaction_send T"
     and "C' \<equiv> if xs = [] then C else \<langle>\<star>,receive\<langle>f xs\<rangle>\<rangle>#C"
     and "C'' \<equiv> if xs = [] then dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t C else \<langle>\<star>,send\<langle>f xs\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t C"
     and "C''' \<equiv> if xs = [] then dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (C \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) else \<langle>\<star>,send\<langle>f xs \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (C \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
   shows "frsh = [] \<Longrightarrow> S' = C'@D@E@F"
       (is "?A \<Longrightarrow> ?A'")
     and "frsh \<noteq> [] \<Longrightarrow> \<nexists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow> S' = C'@D@E@(\<langle>\<star>,send\<langle>f frsh\<rangle>\<rangle>#F)"
       (is "?B \<Longrightarrow> ?B' \<Longrightarrow> ?B''")
     and "frsh \<noteq> [] \<Longrightarrow> \<exists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           \<exists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<and> S' = C'@D@E@(\<langle>\<star>,send\<langle>f frsh@ts\<rangle>\<rangle>#F')"
       (is "?C \<Longrightarrow> ?C' \<Longrightarrow> ?C''")
     and "frsh = [] \<Longrightarrow> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S' = C''@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t D@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t E@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t F"
       (is "?D \<Longrightarrow> ?D'")
     and "frsh \<noteq> [] \<Longrightarrow> \<nexists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S' = C''@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t D@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t E@(\<langle>\<star>,receive\<langle>f frsh\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t F)"
       (is "?E \<Longrightarrow> ?E' \<Longrightarrow> ?E''")
     and "frsh \<noteq> [] \<Longrightarrow> \<exists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           \<exists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<and>
                   dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S' = C''@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t D@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t E@(\<langle>\<star>,receive\<langle>f frsh@ts\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t F')"
       (is "?F \<Longrightarrow> ?F' \<Longrightarrow> ?F''")
     and "frsh = [] \<Longrightarrow>
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = C'''@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (D \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (E \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (F \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
       (is "?G \<Longrightarrow> ?G'")
     and "frsh \<noteq> [] \<Longrightarrow> \<nexists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = C'''@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (D \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (E \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@
                                (\<langle>\<star>,receive\<langle>f frsh \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (F \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       (is "?H \<Longrightarrow> ?H' \<Longrightarrow> ?H''")
     and "frsh \<noteq> [] \<Longrightarrow> \<exists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<Longrightarrow>
           \<exists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#F' \<and>
                   dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = C'''@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (D \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (E \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@
                                        (\<langle>\<star>,receive\<langle>f frsh@ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (F' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       (is "?I \<Longrightarrow> ?I' \<Longrightarrow> ?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 \<Longrightarrow> ?A'" using 0(3) unfolding defs by simp
   show B: "?B \<Longrightarrow> ?B' \<Longrightarrow> ?B''" using 0(2) unfolding defs by simp
   show C: "?C \<Longrightarrow> ?C' \<Longrightarrow> ?C''" using 0(1) unfolding defs by force
 
   have 1: "C''' = C'' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"
     using subst_lsst_cons[of "\<langle>\<star>, send\<langle>f xs\<rangle>\<rangle>" "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t C" \<theta>] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of C \<theta>]
     unfolding C'''_def C''_def by (cases "xs = []") auto
 
   have 2: "(\<langle>\<star>, receive\<langle>ts\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t G) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta> = \<langle>\<star>, receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (G \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" 
     for ts and G::"('a,'b,'c,'d) prot_strand"
     using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of G \<theta>] subst_lsst_cons[of "\<langle>\<star>, receive\<langle>ts\<rangle>\<rangle>" "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t G" \<theta>]
     by simp
 
   note 3 = subst_lsst_append[of _ _ \<theta>] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of _ \<theta>]
 
   show "?D \<Longrightarrow> ?D'" using A unfolding defs by fastforce
   thus "?G \<Longrightarrow> ?G'" unfolding 1 by (metis 3)
 
   show "?E \<Longrightarrow> ?E' \<Longrightarrow> ?E''" using B unfolding defs by fastforce
   thus "?H \<Longrightarrow> ?H' \<Longrightarrow> ?H''" unfolding 1 by (metis 2 3)
 
   show "?F \<Longrightarrow> ?F' \<Longrightarrow> ?F''" using C unfolding defs by fastforce
   thus "?I \<Longrightarrow> ?I' \<Longrightarrow> ?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 \<union> (\<lambda>x. occurs (Var x))`(fv_transaction T \<union> set (transaction_fresh T))"
     (is "?A = ?B")
 proof
   let ?occs = "(\<lambda>x. occurs (Var x)) ` (fv_transaction T \<union> set (transaction_fresh T))"
 
   define frsh where "frsh \<equiv> transaction_fresh T"
   define xs where "xs \<equiv> filter (\<lambda>x. x \<notin> set frsh) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
   define f where "f \<equiv> map (\<lambda>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) \<union> set (f frsh) = ?occs"
   proof -
     define ys where "ys \<equiv> fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
     let ?ys' = "fv_transaction T - set frsh"
     define g where "g \<equiv> filter (\<lambda>x. x \<notin> set frsh)"
 
     have "set (g ys) = ?ys'"
       using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"] unfolding ys_def g_def by auto  
     hence "set (f (g ys)) = (\<lambda>x. occurs (Var x)) ` ?ys'" unfolding f_def by force
     moreover have "set (f frsh) = (\<lambda>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) \<subseteq> trms_transaction T \<union> set (f xs) \<union> set (f frsh)"
   proof (cases "\<exists>ts F'. F = \<langle>\<star>, send\<langle>ts\<rangle>\<rangle>#F'")
     case True
     then obtain ts F' where F: "F = \<langle>\<star>, send\<langle>ts\<rangle>\<rangle>#F'" by blast
     have "set ts \<subseteq> 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 \<subseteq> ?B" using 2 by blast
 
   have "trms_transaction T \<union> set (f xs) \<union> set (f frsh) \<subseteq> 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 "\<exists>ts F'. transaction_send T = \<langle>\<star>, send\<langle>ts\<rangle>\<rangle>#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 \<subseteq> ?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 "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)) =
          fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)" (is ?A)
     and "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send (add_occurs_msgs T)) =
          fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<union> 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 "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
          fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" (is ?F)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
          bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" (is ?G)
     and "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
          vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" (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) \<subseteq> 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 \<equiv>
     filter (\<lambda>x. x \<notin> set (transaction_fresh T)) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
 
   show D: ?D
   proof -
     have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)) = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
       using 0(6,7) by (cases "xs = []") (auto simp add: xs_def)
     moreover have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send (add_occurs_msgs T)) = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
     proof (cases "\<exists>ts' F'. F = \<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>#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 = {}"
       "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {}"
       "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = {}"
       "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (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:
       "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) = fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` fv_transaction T)" (is ?Q1)
       "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) = fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T))" (is ?Q2)
       "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) = fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T))" (is ?Q3)
       "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) = fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))" (is ?Q4)
       "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
        fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T)))" (is ?Q5)
       "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
        fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)))" (is ?Q6)
     for \<delta>
   proof -
     note * = fv\<^sub>s\<^sub>s\<^sub>t_subst_if_no_bvars
 
     have **: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (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: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
            fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)"
     for \<delta>
   proof -
     define rcv_trms where 
       "rcv_trms \<equiv> map (\<lambda>x. occurs (Var x)::('fun,'var,'sets,'lbl) prot_term) xs"
 
     have "fv\<^sub>s\<^sub>e\<^sub>t (set rcv_trms) = fv_transaction T - set (transaction_fresh T)"
          "rcv_trms = [] \<longleftrightarrow> xs = []"
       using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
       unfolding rcv_trms_def xs_def by auto
     hence 1: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)) =
               (fv_transaction T - set (transaction_fresh T)) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
       using 0(6,7)[unfolded rcv_trms_def[symmetric] xs_def[symmetric]] by (cases "xs = []") auto
   
     have 2: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<subseteq> 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) =
              fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (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 \<delta>] 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': "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
             fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) \<union> fv\<^sub>s\<^sub>e\<^sub>t (\<delta> ` set (transaction_fresh T))"
     for \<delta>
   proof -
     note * = fv\<^sub>s\<^sub>s\<^sub>t_subst_if_no_bvars[of _ \<delta>]
 
     have **: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (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 vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t by metis
 
   have "fv\<^sub>s\<^sub>e\<^sub>t (\<theta> ` set (transaction_fresh T)) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     using T_fresh
     unfolding fv\<^sub>s\<^sub>s\<^sub>t_subst_if_no_bvars[OF T_no_bvars(1), of \<theta>, unfolded unlabel_subst]
     by auto
   thus F: ?F
     using A[of \<theta>] B'[of \<theta>] fv\<^sub>s\<^sub>s\<^sub>t_append
           fv\<^sub>s\<^sub>s\<^sub>t_subst_if_no_bvars[OF T_no_bvars(1), of \<theta>, unfolded unlabel_subst]
           fv\<^sub>s\<^sub>s\<^sub>t_subst_if_no_bvars[OF T_no_bvars(5), of \<theta>, unfolded unlabel_subst C]
     unfolding transaction_strand_def by argo
 
   show G: ?G using D bvars\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst by metis
 
   show ?H using F G vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t 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 \<union> (\<lambda>x. occurs (Var x)) ` (set (transaction_fresh T) \<union> fv_transaction T)"
 proof -
   let ?f = "\<lambda>x. occurs (Var x)"
   let ?xs = "filter (\<lambda>x. x \<notin> set (transaction_fresh T))
                     (fv_list\<^sub>s\<^sub>s\<^sub>t (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_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"] by auto
   hence 1: "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)) =
            trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> ?f ` (fv_transaction T - set (transaction_fresh T))"
     using 0(6,7) by (cases "?xs = []") auto
 
   have 2: "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send (add_occurs_msgs T)) =
            trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<union> ?f ` set (transaction_fresh T)"
     using 0(10,11,12) by (cases "transaction_fresh T = []") (simp,fastforce)
 
   have 3: "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)) \<union>
            trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send (add_occurs_msgs T)) =
            trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<union>
            ?f ` (set (transaction_fresh T) \<union> 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 wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_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: "wf\<^sub>t\<^sub>r\<^sub>m (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: "\<not>(\<exists>f \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r). is_Attack f)"
     when "r = receive\<langle>map (\<lambda>x. occurs (Var x)) xs\<rangle> \<or> r = send\<langle>map (\<lambda>x. occurs (Var x)) ys\<rangle>"
     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': "\<not>(\<exists>f \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r). is_Attack f)"
     when "r = send\<langle>map (\<lambda>x. occurs (Var x)) xs@ts\<rangle>"
     and "\<not>(\<exists>f \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (send\<langle>ts\<rangle>)). 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 = "\<lambda>T. wellformed_transaction T"
   let ?P2 = "\<lambda>T. transaction_decl T () = []"
   let ?P3 = "\<lambda>T. list_all (\<lambda>x. fst x = TAtom Value) (transaction_fresh T)"
   let ?P4 = "\<lambda>T. \<forall>x \<in> vars_transaction T. is_Var (fst x) \<and> (the_Var (fst x) = Value)"
   let ?P5 = "\<lambda>T. bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) = {}"
   let ?P6 = "\<lambda>T. set (transaction_fresh T) \<subseteq>
                   fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (filter (is_Insert \<circ> snd) (transaction_updates T)) \<union>
                   fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
   let ?P7 = "\<lambda>T. \<forall>x \<in> fv_transaction T - set (transaction_fresh T).
                  \<forall>y \<in> fv_transaction T - set (transaction_fresh T).
                    x \<noteq> y \<longrightarrow> \<langle>Var x != Var y\<rangle> \<in> set (unlabel (transaction_checks T)) \<or>
                              \<langle>Var y != Var x\<rangle> \<in> set (unlabel (transaction_checks T))"
   let ?P8 = "\<lambda>T. fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)
                   - set (transaction_fresh T)
                   \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
   let ?P9 = "\<lambda>T. \<forall>r \<in> set (unlabel (transaction_checks T)).
                   is_Equality r \<longrightarrow> fv (the_rhs r) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
   let ?P10 = "\<lambda>T. fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<subseteq>
                     fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union>
                     fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (filter (\<lambda>s. is_InSet (snd s) \<and> the_check (snd s) = Assign)
                                   (transaction_checks T))"
   let ?P11 = "\<lambda>T. admissible_transaction_checks T"
   let ?P12 = "\<lambda>T. admissible_transaction_updates T"
   let ?P13 = "\<lambda>T. admissible_transaction_terms T"
   let ?P14 = "\<lambda>T. admissible_transaction_send_occurs_form T"
   let ?P15 = "\<lambda>T. list_all (\<lambda>a. is_Receive (snd a) \<longrightarrow> the_msgs (snd a) \<noteq> [])
                            (transaction_receive T)"
   let ?P16 = "\<lambda>T. list_all (\<lambda>a. is_Send (snd a) \<longrightarrow> the_msgs (snd a) \<noteq> []) (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'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y) (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (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'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y) (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
     for X Y
   proof -
     define frsh where "frsh \<equiv> transaction_fresh T"
     define xs where "xs \<equiv> fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
     define ys where "ys \<equiv> filter (\<lambda>x. x \<notin> set frsh) xs"
 
     let ?snds = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T))"
     let ?snds' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive (add_occurs_msgs T)))"
     let ?chks = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T))"
     let ?chks' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks (add_occurs_msgs T)))"
     let ?upds = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T))"
     let ?upds' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates (add_occurs_msgs T)))"
     let ?rcvs = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))"
     let ?rcvs' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send (add_occurs_msgs T)))"
 
     have p0: "set ?snds \<subseteq> set ?snds'" using 1(13) by auto
 
     have p1: "?chks = ?chks'" "?upds = ?upds'" using 1(8,9) by (argo,argo)
 
     have p2: "wfvarsoccs\<^sub>s\<^sub>s\<^sub>t ?snds \<subseteq> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t ?snds'"
              "wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds@?chks@?upds) \<subseteq> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds'@?chks'@?upds')"
              "X \<union> Y \<union> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds@?chks@?upds) \<subseteq>
               X \<union> Y \<union>  wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds'@?chks'@?upds')"
       using p0 p1 unfolding wfvarsoccs\<^sub>s\<^sub>s\<^sub>t_def by auto
 
     have "wf'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y \<union> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds@?chks@?upds)) ?rcvs"
       using T_wf wf\<^sub>s\<^sub>s\<^sub>t_append_exec[of "X \<union> Y" "?snds@?chks@?upds" ?rcvs]
       unfolding transaction_strand_unlabel_dual_unfold by simp
     hence r0: "wf'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y \<union> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds'@?chks'@?upds')) ?rcvs"
       using wf\<^sub>s\<^sub>s\<^sub>t_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 dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(2))
     hence r1: "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t ?rcvs \<subseteq> X \<union> Y \<union> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds'@?chks'@?upds')"
       using wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_receives_only_eq wf\<^sub>s\<^sub>s\<^sub>t_receives_only_fv_subset[OF r0] by blast
 
     have "fv\<^sub>s\<^sub>e\<^sub>t ((\<lambda>x. occurs (Var x)) ` set (transaction_fresh T)) \<subseteq> Y"
       unfolding Y by auto
     hence r2: "wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t ?rcvs' \<subseteq> X \<union> Y \<union> wfvarsoccs\<^sub>s\<^sub>s\<^sub>t (?snds'@?chks'@?upds')"
       using 1(14) r1 unfolding wfrestrictedvars\<^sub>s\<^sub>s\<^sub>t_def by fastforce (* TODO: find faster proof *)
 
     have r3: "wf'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y) (?snds'@?chks'@?upds')"
     proof -
       have *: "wf'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y) (?snds@?chks'@?upds')"
         using T_wf wf\<^sub>s\<^sub>s\<^sub>t_prefix[of "X \<union> Y" "?snds@?chks@?upds" ?rcvs] p1
         unfolding transaction_strand_unlabel_dual_unfold by simp
 
       have "?snds' = ?snds \<or> (\<exists>ts. ?snds' = send\<langle>ts\<rangle>#?snds)" using 1(13) by auto
       thus ?thesis
       proof
         assume "?snds' = ?snds" thus ?thesis using * by simp
       next
         assume "\<exists>ts. ?snds' = send\<langle>ts\<rangle>#?snds"
         then obtain ts where "?snds' = send\<langle>ts\<rangle>#?snds" by blast
         thus ?thesis using wf\<^sub>s\<^sub>s\<^sub>t_sends_only_prepend[OF *, of "[send\<langle>ts\<rangle>]"] by simp
       qed
     qed
 
     have "wf'\<^sub>s\<^sub>s\<^sub>t (X \<union> Y) (?snds'@?chks'@?upds'@?rcvs')"
       using wf\<^sub>s\<^sub>s\<^sub>t_append_suffix''[OF r3] r2 by auto
     thus ?thesis
       using unlabel_append dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_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 \<in> set (unlabel (transaction_strand (add_occurs_msgs T)))"
             "\<exists>f \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r). is_Attack f" (is "?Q' (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r)")
     for r
   proof -
     note q0 = conjunct2[OF conjunct2[OF T_props(13)[unfolded defs']]]
 
     let ?Q'' = "\<lambda>ts' F'. F = \<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>#F'"
     let ?f = "map (\<lambda>x. occurs (Var x))"
     let ?frsh = "transaction_fresh T"
     let ?xs = "fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
 
     have q1: "r \<noteq> send\<langle>?f ?frsh\<rangle>" "r \<noteq> receive\<langle>?f (filter (\<lambda>x. x \<notin> set ?frsh) ?xs)\<rangle>"
              "\<forall>f \<in> \<Union>(funs_term ` set (?f ?frsh)). \<not>is_Attack f"
       using r(2) by (fastforce,fastforce,simp)
 
     have q2: "send\<langle>ts'\<rangle> \<in> set (unlabel (transaction_strand T))"
              "r = send\<langle>?f ?frsh@ts'\<rangle> \<or> r \<in> 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 \<notin> set (unlabel (transaction_strand T))" for ts' F'
     proof -
       have "r = send\<langle>?f ?frsh@ts'\<rangle>" using q2(2)[OF r'(1)] r'(2) by argo
       thus ?thesis using r(2) by fastforce
     qed
     
     have q4: "r \<in> set (unlabel (transaction_strand T))" when "\<nexists>ts' F'. ?Q'' ts' F'"
       using 4(4)[OF that] r(1) q1(1,2) by blast
 
     have "\<exists>r' \<in> set (unlabel (transaction_strand T)). ?Q' (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p r')"
       when "?Q'' ts' F'" for ts' F'
       apply (cases "r \<in> set (unlabel (transaction_strand T))")
       subgoal using q2(2)[OF that] r(2) by metis
       subgoal using q2(1)[OF that] q3[OF that] trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p.simps(1)[of ts'] by metis
       done
     hence "?frsh = []" when "?Q'' ts' F'" for ts' F' using q0 that by blast
     hence "r = send\<langle>ts'\<rangle> \<or> r \<in> set (unlabel (transaction_strand T))" when "?Q'' ts' F'" for ts' F'
       using q2(2)[OF that] that by blast
     hence "r \<in> 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 "\<exists>ts' F'. transaction_send T = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F'")
     case True
     then obtain ts' F' where F': "transaction_send T = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#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_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
 
   have T'_props_15: "?P15 ?T'"
     using T_props(15) 1(6,7) unfolding Let_def
     by (cases "filter (\<lambda>x. x \<notin> set (transaction_fresh T)) ?xs = []") (simp,fastforce)
 
   have T'_props_16: "?P16 ?T'"
   proof (cases "\<exists>ts' F'. transaction_send T = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#F'")
     case True
     then obtain ts' F' where F': "transaction_send T = \<langle>\<star>,send\<langle>ts'\<rangle>\<rangle>#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 (\<lambda>x. x \<notin> set (transaction_fresh T))
                        (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))) =
            fv_transaction T - set (transaction_fresh T)"
     using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t by fastforce
 
   have "transaction_receive ?T' \<noteq> []"
     and "is_Receive (hd (unlabel (transaction_receive ?T')))"
     and "\<forall>x \<in> fv_transaction ?T' - set (transaction_fresh ?T'). fst x = TAtom Value \<longrightarrow>
             occurs (Var x) \<in> set (the_msgs (hd (unlabel (transaction_receive ?T'))))"
     when x: "x \<in> 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' \<noteq> []" (is ?C)
     and "is_Send (hd (unlabel (transaction_send ?T')))" (is ?D)
     and "\<forall>x \<in> set (transaction_fresh ?T').
            occurs (Var x) \<in> set (the_msgs (hd (unlabel (transaction_send ?T'))))" (is ?E)
     when T'_frsh: "transaction_fresh ?T' \<noteq> []"
     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 \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"  
   shows "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<or>
          (\<exists>x \<in> fv_transaction T. t = occurs (\<theta> x))"
 proof -
   define frsh where "frsh \<equiv> transaction_fresh T"
   define xs where "xs \<equiv> filter (\<lambda>x. x \<notin> set frsh) (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
   define f where "f \<equiv> map (\<lambda>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) \<subseteq> fv_transaction T"
     using admissible_transactionE(7)[OF T_adm]
     unfolding fv_transaction_unfold by blast
   hence 00: "set (f xs) \<union> set (f frsh) = (\<lambda>x. occurs (Var x)) ` fv_transaction T"
     using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[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)) \<subseteq>
            set (transaction_strand T) \<union> {\<langle>\<star>,receive\<langle>f xs\<rangle>\<rangle>,\<langle>\<star>,send\<langle>f frsh\<rangle>\<rangle>}"
     when "\<nexists>ts F'. F = \<langle>\<star>,send\<langle>ts\<rangle>\<rangle>#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 \<union> (\<lambda>x. occurs (Var x)) ` fv_transaction T"
     using 0 add_occurs_msgs_trms_transaction[of T] by blast
 
   have 4: "bvars_transaction T \<inter> subst_domain \<theta> = {}"
           "bvars_transaction (add_occurs_msgs T) \<inter> subst_domain \<theta> = {}"
     using admissible_transactionE(4)[OF T_adm] admissible_transactionE(4)[OF T'_adm]
     by (blast,blast)
 
   note 5 = trms\<^sub>s\<^sub>s\<^sub>t_subst[OF 4(1), unfolded unlabel_subst]
            trms\<^sub>s\<^sub>s\<^sub>t_subst[OF 4(2), unfolded unlabel_subst]
 
   note 6 = fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t_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 \<equiv> \<lambda>T. list_ex (\<lambda>a. is_Send (snd a) \<or> is_Update (snd a)) (transaction_strand T)"
     and "g \<equiv> \<lambda>T. transaction_fresh T = [] \<longrightarrow> f T"
   shows "map add_occurs_msgs (filter g P) = filter g (map add_occurs_msgs P)"
 proof -
   have "g T \<longleftrightarrow> 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 \<equiv> \<lambda>T. list_ex (\<lambda>a. is_Send (snd a) \<or> is_Update (snd a)) (transaction_strand T)"
     and "g \<equiv> \<lambda>T. transaction_fresh T = [] \<longrightarrow> transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> []"
   shows "map add_occurs_msgs (filter g P) = filter g (map add_occurs_msgs P)"
 proof -
   have "g T \<longleftrightarrow> 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 \<equiv> rm_occurs_msgs_constr"
   shows
     "\<not>is_Receive a \<Longrightarrow> \<not>is_Send a \<Longrightarrow> f ((l,a)#A) = (l,a)#f A"
     "is_Receive a \<Longrightarrow> \<nexists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow> f ((l,a)#A) = (l,a)#f A"
     "is_Receive a \<Longrightarrow> \<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<exists>t \<in> set (the_msgs a). \<forall>s. t \<noteq> occurs s \<Longrightarrow>
       f ((l,a)#A) = (l,receive\<langle>filter (\<lambda>t. \<forall>s. t \<noteq> occurs s) (the_msgs a)\<rangle>)#f A"
     "is_Receive a \<Longrightarrow> \<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<forall>t \<in> set (the_msgs a). \<exists>s. t = occurs s \<Longrightarrow> f ((l,a)#A) = f A"
     "is_Send a \<Longrightarrow> \<nexists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow> f ((l,a)#A) = (l,a)#f A"
     "is_Send a \<Longrightarrow> \<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<exists>t \<in> set (the_msgs a). \<forall>s. t \<noteq> occurs s \<Longrightarrow>
       f ((l,a)#A) = (l,send\<langle>filter (\<lambda>t. \<forall>s. t \<noteq> occurs s) (the_msgs a)\<rangle>)#f A"
     "is_Send a \<Longrightarrow> \<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<forall>t \<in> set (the_msgs a). \<exists>s. t = occurs s \<Longrightarrow> f ((l,a)#A) = f A"
 unfolding f_def by (cases a; auto)+
 
 private lemma rm_occurs_msgs_constr_Cons':
   defines "f \<equiv> rm_occurs_msgs_constr"
     and "g \<equiv> filter (\<lambda>t. \<forall>s. t \<noteq> occurs s)"
   assumes a: "is_Receive a \<or> is_Send a"
   shows
     "\<nexists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow> f ((l,a)#A) = (l,a)#f A"
     "\<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<exists>t \<in> set (the_msgs a). \<forall>s. t \<noteq> occurs s \<Longrightarrow>
       is_Send a \<Longrightarrow> f ((l,a)#A) = (l,send\<langle>g (the_msgs a)\<rangle>)#f A"
     "\<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<exists>t \<in> set (the_msgs a). \<forall>s. t \<noteq> occurs s \<Longrightarrow>
       is_Receive a \<Longrightarrow> f ((l,a)#A) = (l,receive\<langle>g (the_msgs a)\<rangle>)#f A"
     "\<exists>t. occurs t \<in> set (the_msgs a) \<Longrightarrow>
       \<forall>t \<in> set (the_msgs a). \<exists>s. t = occurs s \<Longrightarrow> 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 \<equiv> rm_occurs_msgs_constr"
     and "g \<equiv> filter (\<lambda>t. \<forall>s. t \<noteq> occurs s)"
   assumes a: "a = receive\<langle>ts\<rangle> \<or> a = send\<langle>ts\<rangle>"
   shows "f ((l,a)#A) = (l,a)#f A \<or> f ((l,a)#A) = (l,receive\<langle>g ts\<rangle>)#f A \<or>
          f ((l,a)#A) = (l,send\<langle>g ts\<rangle>)#f A \<or> 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:
   "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A) \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 proof (induction A)
   case (Cons a A)
   let ?f = "filter (\<lambda>t. \<forall>s. t \<noteq> occurs s)"
 
   note IH = Cons.IH
 
   obtain l b where a: "a = (l,b)" by (metis surj_pair)
 
   have 0: "set (unlabel A) \<subseteq> set (unlabel (a#A))" by auto
 
   note 1 = rm_occurs_msgs_constr_Cons[of b l A]
   note 2 = in_ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t_iff
   note 3 = ik\<^sub>s\<^sub>s\<^sub>t_set_subset[OF 0]
   note 4 = ik\<^sub>s\<^sub>s\<^sub>t_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 \<or> is_Receive b")
     case True
     note b_cases = this
 
     define ts where "ts \<equiv> the_msgs b"
 
     have ts_cases: "is_Send b \<Longrightarrow> b = send\<langle>ts\<rangle>" "is_Receive b \<Longrightarrow> b = receive\<langle>ts\<rangle>"
       unfolding ts_def by simp_all
 
     have 6:
         "is_Send b \<Longrightarrow> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [(l,b)] = {}"
         "is_Send b \<Longrightarrow> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [(l,send\<langle>the_msgs b\<rangle>)] = {}"
         "is_Send b \<Longrightarrow> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [(l,send\<langle>?f (the_msgs b)\<rangle>)] = {}"
         "is_Receive b \<Longrightarrow> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [(l,b)] = set ts"
         "is_Receive b \<Longrightarrow> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [(l,receive\<langle>the_msgs b\<rangle>)] = set ts"
         "is_Receive b \<Longrightarrow> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [(l,receive\<langle>?f (the_msgs b)\<rangle>)] = set (?f ts)"
       using 2[of _ "[(l, send\<langle>the_msgs b\<rangle>)]"]
             2[of _ "[(l, send\<langle>?f (the_msgs b)\<rangle>)]"]
             2[of _ "[(l, receive\<langle>the_msgs b\<rangle>)]"]
             2[of _ "[(l, receive\<langle>?f (the_msgs b)\<rangle>)]"]
             b_cases ts_cases
       by auto
 
     have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr (a#A)) = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A)"
       when b: "is_Send b"
     proof (cases "\<exists>t. occurs t \<in> set (the_msgs b)")
       case True
       note 7 = 1(6,7)[OF b True]
 
       show ?thesis
       proof (cases "\<exists>t \<in> set (the_msgs b). \<forall>s. t \<noteq> occurs s")
         case True show ?thesis
           using 4[of "unlabel [(l,send\<langle>?f (the_msgs b)\<rangle>)]"
                      "unlabel (rm_occurs_msgs_constr A)"]
           unfolding a 7(1)[OF True] 6(3)[OF b] by simp
       next
         case False
         hence F: "\<forall>t \<in> set (the_msgs b). \<exists>s. t = occurs s" by simp
         show ?thesis
           using 4[of "unlabel [(l,send\<langle>the_msgs b\<rangle>)]" "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 "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr (a#A)) \<subseteq> set ts \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A)"
       when b: "is_Receive b"
     proof (cases "\<exists>t. occurs t \<in> set (the_msgs b)")
       case True
       note 8 = 1(3,4)[OF b True]
 
       show ?thesis
       proof (cases "\<exists>t \<in> set (the_msgs b). \<forall>s. t \<noteq> occurs s")
         case True show ?thesis
           using 4[of "unlabel [(l,receive\<langle>?f (the_msgs b)\<rangle>)]"
                      "unlabel (rm_occurs_msgs_constr A)"]
           unfolding a 8(1)[OF True] 6(6)[OF b] by auto
       next
         case False
         hence F: "\<forall>t \<in> set (the_msgs b). \<exists>s. t = occurs s" by simp
         show ?thesis
           using 4[of "unlabel [(l,receive\<langle>the_msgs b\<rangle>)]" "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 "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) = set ts \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" when b: "is_Receive b"
       using ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t_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_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t:
   "rm_occurs_msgs_constr (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (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_dbupd\<^sub>s\<^sub>s\<^sub>t_eq:
   "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (rm_occurs_msgs_constr A)) I D = dbupd\<^sub>s\<^sub>s\<^sub>t (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 \<or> is_Send b")
     case True
     then obtain ts where b: "b = receive\<langle>ts\<rangle> \<or> b = send\<langle>ts\<rangle>" 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 \<theta>::"('a,'b,'c,'d) prot_subst"
   assumes "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \<nexists>t. \<theta> x = occurs t" "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \<theta> x \<noteq> Fun OccursSec []"
   shows "rm_occurs_msgs_constr (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = (rm_occurs_msgs_constr A) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"
     (is "?f (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = (?f A) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>")
 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 \<equiv> ?f"
   define not_occ where "not_occ \<equiv> \<lambda>t::('a,'b,'c,'d) prot_term. \<forall>s. t \<noteq> occurs s"
   define flt where "flt \<equiv> filter not_occ"
 
   obtain l b where a: "a = (l,b)" by (metis surj_pair)
 
   have 2: "\<nexists>t. \<theta> x = occurs t" "\<theta> x \<noteq> Fun OccursSec []"
     when b: "is_Receive b \<or> is_Send b" and t: "t \<in> set (the_msgs b)" and x: "x \<in> fv t" for x t
     using Cons.prems x t b unfolding a by (cases b; auto)+
 
   have IH: "f (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = (f A) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"
     using Cons.prems Cons.IH unfolding f_def by simp
 
   show ?case
   proof (cases "is_Receive b \<or> is_Send b")
     case True
     note T = this
     then obtain ts where ts: "b = receive\<langle>ts\<rangle> \<or> b = send\<langle>ts\<rangle>" by (cases b) simp_all
     hence ts': "b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta> = receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle> \<or> b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta> = send\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>" by auto
 
     have the_msgs_b: "the_msgs b = ts" "the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>) = ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"
       using ts ts' by auto
 
     have 4: "is_Receive (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>) \<or> is_Send (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
       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 \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>", unfolded f_def[symmetric]]
     note 8 = ts IH subst_lsst_cons[of _ _ \<theta>]
 
     have 9: "t \<cdot> \<theta> \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))" "not_occ (t \<cdot> \<theta>)"
       when t: "t \<in> set (the_msgs b)" "not_occ t" for t
     proof -
       show "t \<cdot> \<theta> \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))" using t ts ts' by auto
       moreover have "not_occ (t \<cdot> \<theta>)" 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 \<cdot> \<theta>)" when "t = Fun g ss" "g \<noteq> 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 \<cdot> \<theta>)"
         when "t = Fun OccursFact ss" "\<nexists>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 \<cdot> \<theta>)"
         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 \<cdot> \<theta>)" by (cases t) (metis, metis)
     qed
 
     have 10: "not_occ t"
       when t: "t \<in> set (the_msgs b)" "not_occ (t \<cdot> \<theta>)" for t
     proof -
       have "t \<cdot> \<theta> \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))" 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 \<noteq> 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" "\<nexists>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 \<cdot> \<theta>) \<longleftrightarrow> not_occ t" when "t \<in> set ts" for t
       using that 9 10 unfolding the_msgs_b by blast
 
     have 5: "(\<exists>t. occurs t \<in> set ts) \<longleftrightarrow> (\<exists>t. occurs t \<in> set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>)"
       using 11 image_iff unfolding not_occ_def by fastforce
 
     have 12: "flt (ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>) = (flt ts) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" using 11 
     proof (induction ts)
       case (Cons t ts)
       hence "not_occ (t \<cdot> \<theta>) = not_occ t" "flt (ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>) = (flt ts) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" by auto
       thus ?case unfolding flt_def by auto
     qed (metis flt_def filter.simps(1) map_is_Nil_conv)
 
     show ?thesis
     proof (cases "\<exists>t. occurs t \<in> set (the_msgs b)")
       case True
       note T1 = this
       hence T2: "\<exists>t. occurs t \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))" using 5 unfolding the_msgs_b by simp
 
       show ?thesis
       proof (cases "\<exists>t \<in> set (the_msgs b). \<forall>s. t \<noteq> occurs s")
         case True
         note T1' = this
         have T2': "\<exists>t \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)). \<forall>s. t \<noteq> 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\<theta>: "is_Receive (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)" using ts by fastforce
 
           show ?thesis
             using 6(3)[OF T1 T1' b] 7(3)[OF T2 T2' b\<theta>] 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\<theta>: "is_Send (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)" using ts by fastforce
 
           show ?thesis
             using 6(2)[OF T1 T1' b] 7(2)[OF T2 T2' b\<theta>] 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: "\<forall>t \<in> set (the_msgs b). \<exists>s. t = occurs s" by blast
         hence F': "\<forall>t \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)). \<exists>s. t = occurs s" unfolding the_msgs_b by auto
 
         have *: "\<exists>t. occurs t \<in> set (the_msgs b)" when "the_msgs b \<noteq> []"
           using that F by (cases "the_msgs b") auto
         hence **: "\<exists>t. occurs t \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))" when "the_msgs b \<noteq> []"
           using that 5 unfolding the_msgs_b by simp
 
         show ?thesis
         proof (cases "ts = []")
           case True
           hence ***: "\<nexists>t. occurs t \<in> set (the_msgs b)" "\<nexists>t. occurs t \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))"
             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': "\<nexists>t. occurs t \<in> set (the_msgs (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>))"
         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 *: "\<not>is_Receive b" "\<not>is_Send b" "\<not>is_Receive (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)" "\<not>is_Send (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
       by (cases b; auto)+
 
     show ?thesis
       using IH 0(1)[OF *(1,2), of l A] 0(1)[OF *(3,4), of l "A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"] subst_lsst_cons[of a _ \<theta>]
       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 \<Longrightarrow>
           rm_occurs_msgs_constr (transaction_receive T) = transaction_receive T" (is "?C \<Longrightarrow> ?C'")
     and "admissible_transaction_no_occurs_msgs T \<Longrightarrow>
           rm_occurs_msgs_constr (transaction_send T) = transaction_send T" (is "?D \<Longrightarrow> ?D'")
 proof -
   note 0 = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
   note 1 = wellformed_transaction_cases[OF 0]
 
   have 2: "\<exists>ts. b = receive\<langle>ts\<rangle> \<and> (\<nexists>t. occurs t \<in> set ts)"
     when "admissible_transaction_no_occurs_msgs T" "(l,b) \<in> 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: "\<exists>ts. b = send\<langle>ts\<rangle> \<and> (\<nexists>t. occurs t \<in> set ts)"
     when "admissible_transaction_no_occurs_msgs T" "(l,b) \<in> 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 \<equiv> transaction_receive T"
   define B where "B \<equiv> transaction_checks T"
   define C where "C \<equiv> transaction_updates T"
   define D where "D \<equiv> 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\<langle>ts\<rangle>" 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\<langle>ts\<rangle>" 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 \<equiv> filter (\<lambda>x. x \<notin> set B) (fv_list\<^sub>s\<^sub>s\<^sub>t (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\<langle>map (\<lambda>x. occurs (Var x)) xs\<rangle>" \<star> "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 "\<exists>ts' F'. F = \<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>#F'")
     case True
     then obtain ts' F' where F': "F = \<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>#F'" by blast
 
     have *: "transaction_send (?h T) = \<langle>\<star>, send\<langle>map (\<lambda>x. occurs (Var x)) B@ts'\<rangle>\<rangle>#F'"
       using 3(1)[OF F'] unfolding T by fastforce
 
     have **: "ts' \<noteq> []" using admissible_transactionE(17)[OF T_adm] unfolding T F' by auto
 
     have ***: "\<forall>s. t \<noteq> occurs s" when t: "t \<in> 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 (\<lambda>x. occurs (Var x)) B@ts'"
 
     have "\<exists>t \<in> set ?ts. \<forall>s. t \<noteq> occurs s" using ** *** by (cases ts') auto
     moreover have "filter (\<lambda>t. \<forall>s. t \<noteq> occurs s) ?ts = ts'" using *** by simp
     moreover have "\<exists>t. occurs t \<in> set ?ts" when "B \<noteq> []" using that by (cases B) auto
     moreover have "?f [\<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>] = [\<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>]"
       using 2(2) ** *** unfolding F[symmetric] F' by force
     hence "?f F' = F'"
       using 2(2) rm_occurs_msgs_constr_append[of "[\<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>]" F']
       unfolding F[symmetric] F' by fastforce
     ultimately have "?f (\<langle>\<star>, send\<langle>?ts\<rangle>\<rangle>#F') = \<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>#F'"
       using 2(2) 3(10)[OF F'[unfolded F]] 3(12)
             rm_occurs_msgs_constr.simps(3)[of \<star> ts' F']
             rm_occurs_msgs_constr_append[of "[\<langle>\<star>, send\<langle>ts'\<rangle>\<rangle>]" 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 \<theta>: "\<forall>x \<in> fv_transaction (add_occurs_msgs T). \<nexists>t. \<theta> x = occurs t"
            "\<forall>x \<in> fv_transaction (add_occurs_msgs T). \<theta> x \<noteq> Fun OccursSec []"
   shows "rm_occurs_msgs_constr (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) =
          dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 using rm_occurs_msgs_constr_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t[of "transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
       rm_occurs_msgs_constr_subst[OF \<theta>] rm_occurs_msgs_constr_transaction_strand'[OF T_adm T_no_occ]
 by argo
 
 private lemma rm_occurs_msgs_constr_bvars_subst_eq:
   "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 proof -
   have "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A) = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t 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 bvars\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst)
 qed
 
 private lemma rm_occurs_msgs_constr_reachable_constraints_fv_eq:
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
              "\<forall>T \<in> set P. admissible_transaction_no_occurs_msgs T"
     and A: "A \<in> reachable_constraints (map add_occurs_msgs P)"
   shows "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A) = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 using A
 proof (induction A rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   let ?f = rm_occurs_msgs_constr
   let ?B = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   obtain T' where T': "T' \<in> 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 (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     using rm_occurs_msgs_constr_transaction_strand''[OF T'_adm T'_no_occ, of \<theta>]
           admissible_transaction_decl_fresh_renaming_subst_not_occurs[OF T_adm step.hyps(3,4,5)]
     unfolding T'(2) \<theta>_def[symmetric] by blast
   moreover have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     using add_occurs_msgs_vars_eq(6)[OF T'_adm, of \<theta>] unfolding T'(2) by blast
   ultimately have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?f ?B) = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?B"
     using fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unfolding T'(2) \<theta>_def[symmetric] by metis
   thus ?case
     using step.IH fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel ?B"]
           rm_occurs_msgs_constr_append[of \<A> ?B]
     by force
 qed simp
 
 private lemma rm_occurs_msgs_constr_reachable_constraints_vars_eq:
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
              "\<forall>T \<in> set P. admissible_transaction_no_occurs_msgs T"
     and A: "A \<in> reachable_constraints (map add_occurs_msgs P)"
   shows "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (rm_occurs_msgs_constr A) = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
 using rm_occurs_msgs_constr_bvars_subst_eq[of _ Var]
       rm_occurs_msgs_constr_reachable_constraints_fv_eq[OF P A]
 by (metis vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t subst_lsst_id_subst)
 
 private lemma rm_occurs_msgs_constr_reachable_constraints_trms_cases_aux:
   assumes A: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t A" "bvars\<^sub>s\<^sub>s\<^sub>t A = {}"
     and t: "t = occurs (\<theta> x)"
     and \<theta>: "(\<exists>y. \<theta> x = Var y) \<or> (\<exists>c. \<theta> x = Fun c [])"
   shows "(\<exists>x \<in> fv\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>s\<^sub>s\<^sub>t \<theta>). t = occurs (Var x)) \<or>
          (\<exists>c. Fun c [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>s\<^sub>s\<^sub>t \<theta>) \<and> t = occurs (Fun c []))"
 using A
 proof (induction A)
   case (Cons a A)
   have 0: "bvars\<^sub>s\<^sub>s\<^sub>t A = {}" "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) = {}" "set (bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p a) \<inter> subst_domain \<theta> = {}"
     using Cons.prems(2) by auto
 
   note 1 = fv\<^sub>s\<^sub>s\<^sub>t_Cons[of a A] trms\<^sub>s\<^sub>s\<^sub>t_cons[of a A] subst_sst_cons[of a A \<theta>]
 
   show ?case
   proof (cases "x \<in> fv\<^sub>s\<^sub>s\<^sub>t A")
     case False
     hence x: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p a" using Cons.prems(1) by simp
 
     note 2 = x t \<theta>
 
     have 3: "\<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)"
       using subst_subterms[OF fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p[OF x]] trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst[OF 0(3)] by auto
 
     have "Fun c [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)" when "\<theta> x = Fun c []" for c
       using that 3 t by argo
     moreover have "y \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)" when "\<theta> x = Var y" for y
       using that 3 var_subterm_trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p[of y "a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>"] 0(2) 
       unfolding vars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p_bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p_subst by simp
     ultimately have
         "(\<exists>x \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>). t = occurs (Var x)) \<or>
          (\<exists>c. Fun c [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (a \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>) \<and> t = occurs (Fun c []))"
       using t \<theta> 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: "\<forall>T \<in> set P. admissible_transaction' T"
              "\<forall>T \<in> set P. admissible_transaction_no_occurs_msgs T"
     and A: "A = rm_occurs_msgs_constr B"
     and B: "B \<in> reachable_constraints (map add_occurs_msgs P)"
     and t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B"
   shows "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<or> (\<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. t = occurs (Var x)) \<or>
          (\<exists>c. Fun c [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<and> t = occurs (Fun c []))"
     (is "?A A \<or> ?B A \<or> ?C A")
 proof -
   define rm_occs where
     "rm_occs \<equiv> \<lambda>A::('fun,'atom,'sets,'lbl) prot_strand. rm_occurs_msgs_constr A"
   define Q where "Q \<equiv> \<lambda>A. ?A A \<or> ?B A \<or> ?C A"
 
   have 0: "Q B" when "Q A" "set A \<subseteq> set B" for A B
     using that unfolding Q_def fv\<^sub>s\<^sub>s\<^sub>t_def trms\<^sub>s\<^sub>s\<^sub>t_def unlabel_def by auto
 
   have "Q A" using B t unfolding A
   proof (induction rule: reachable_constraints.induct)
     case (step \<A> T \<xi> \<sigma> \<alpha>)
     define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     define \<B> where "\<B> \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
     obtain T' where T': "T' \<in> 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 = \<theta>_def[symmetric] \<B>_def[symmetric] rm_occs_def[symmetric]
     note 2 = rm_occurs_msgs_constr_append[of \<A> \<B>, 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 (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) =
              dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
       using 3 rm_occurs_msgs_constr_transaction_strand''[OF T'_adm]
       unfolding T'(2) 1 by blast 
 
     have 5: "(\<exists>y. \<theta> x = Var y) \<or> (\<exists>c. \<theta> x = Fun c [])" for x
       using transaction_decl_fresh_renaming_substs_range'(1)[OF step.hyps(3,4,5)]
       unfolding \<theta>_def[symmetric] by blast
 
     show ?case
     proof (cases "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>")
       case True show ?thesis using 0[OF step.IH[OF True]] unfolding 1 2 by simp
     next
       case False
       hence "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" using step.prems unfolding \<B>_def \<theta>_def by simp
       hence "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<or>
              (\<exists>x \<in> fv_transaction T'. t = occurs (\<theta> x))"
         using add_occurs_msgs_in_trms_subst_cases[OF T'_adm(1), of t \<theta>]
         unfolding \<B>_def trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq T'(2) by blast
       moreover have "(\<exists>y. \<theta> x = Var y) \<or> (\<exists>c. \<theta> x = Fun c [])" for x
         using transaction_decl_fresh_renaming_substs_range'(1)[OF step.hyps(3,4,5)]
         unfolding \<theta>_def[symmetric] by blast
       ultimately have "Q (rm_occs \<B>)"
         using rm_occurs_msgs_constr_reachable_constraints_trms_cases_aux[
                 of _ "unlabel (transaction_strand T')" t \<theta>]
               admissible_transactionE(4)[OF T'_adm(1)]
         unfolding Q_def \<B>_def 4 trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unlabel_subst
         by fast
       thus ?thesis using 0[of "rm_occs \<B>"] 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 "(\<exists>ts. attack\<langle>n\<rangle> \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel A)) \<longleftrightarrow>
          (\<exists>ts. attack\<langle>n\<rangle> \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel (rm_occurs_msgs_constr A)))"
   (is "(\<exists>ts. attack\<langle>n\<rangle> \<in> set ts \<and> ?A A ts) \<longleftrightarrow> (\<exists>ts. attack\<langle>n\<rangle> \<in> set ts \<and> ?B A ts)")
 proof
   let ?att = "\<lambda>ts. attack\<langle>n\<rangle> \<in> set ts"
 
   define f where "f \<equiv> \<lambda>ts::('a,'b,'c,'d) prot_term list. filter (\<lambda>t. \<forall>s. t \<noteq> occurs s) ts"
 
   have 0: "?att ts \<longleftrightarrow> ?att (f ts)"
           "?att ts \<Longrightarrow> \<exists>t. occurs t \<in> set ts \<Longrightarrow> \<exists>t \<in> set ts. \<forall>s. t \<noteq> occurs s"
           "\<nexists>t. occurs t \<in> set ts \<Longrightarrow> 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\<langle>ts\<rangle>" 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 "(\<exists>ts. ?att ts \<and> ?A A ts) \<Longrightarrow> (\<exists>ts. ?att ts \<and> ?B A ts)" using 0(1) by fast
 
   have "\<exists>ts'. ts = f ts' \<and> ?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\<langle>ts\<rangle> \<in> set (unlabel (rm_occurs_msgs_constr A))"
       when rcv_ts: "receive\<langle>ts\<rangle> \<in> set (unlabel (rm_occurs_msgs_constr ((l,send\<langle>ts'\<rangle>)#A)))"
       for l ts ts' and A::"('a,'b,'c,'d) prot_strand"
     proof -
       have *: "is_Send (send\<langle>ts'\<rangle>)" by simp
 
       have "set (unlabel (rm_occurs_msgs_constr [(l, send\<langle>ts'\<rangle>)])) \<subseteq> {send\<langle>ts'\<rangle>, send\<langle>f ts'\<rangle>}"
         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\<langle>ts'\<rangle>)]" 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\<langle>ts\<rangle> \<in> 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\<langle>ts'\<rangle>" 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\<langle>ts'\<rangle>) = ts'" by simp
 
       have "\<exists>t \<in> set (the_msgs b). \<forall>s. t \<noteq> occurs s" when "\<exists>t. occurs t \<in> 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 "(\<exists>ts. ?att ts \<and> ?B A ts) \<Longrightarrow> (\<exists>ts. ?att ts \<and> ?A A ts)" using 0 by fast
 qed
 
 private lemma add_occurs_msgs_soundness_aux1:
   fixes P::"('fun,'atom,'sets,'lbl) prot"
   defines "wt_attack \<equiv> \<lambda>\<I> \<A> l n. welltyped_constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_val: "has_initial_value_producing_transaction P"
     and A: "\<A> \<in> reachable_constraints P" "wt_attack \<I> \<A> l n"
   shows "\<exists>\<B> \<in> reachable_constraints P. \<exists>\<J>.
           wt_attack \<J> \<B> l n \<and> (\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>. \<exists>n. \<J> x = Fun (Val n) [])"
 proof -
   let ?f = "\<lambda>(T,\<xi>,\<sigma>,\<alpha>). dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   let ?g = "concat \<circ> map ?f"
   let ?rcv_att = "\<lambda>A n. receive\<langle>[attack\<langle>n\<rangle>]\<rangle> \<in> set (unlabel A)"
   let ?wt_model = welltyped_constraint_model
 
   define valconst_cases where "valconst_cases \<equiv>
     \<lambda>I::('fun,'atom,'sets,'lbl) prot_subst. \<lambda>x.
       (\<exists>n. I x = Fun (Val n) []) \<or> (\<exists>n. I x = Fun (PubConst Value n) [])"
 
   define valconsts_only where "valconsts_only \<equiv>
     \<lambda>X. \<lambda>I::('fun,'atom,'sets,'lbl) prot_subst. \<forall>x \<in> X. \<exists>n. I x = Fun (Val n) []"
 
   define db_eq where "db_eq \<equiv>
     \<lambda>A B::('fun,'atom,'sets,'lbl) prot_constr. \<lambda>s. \<lambda>upds::('fun,'atom,'sets,'lbl) prot_constr.
       let f = filter is_Update \<circ> unlabel;
           g = filter (\<lambda>a. \<nexists>l t ts. a = (l,insert\<langle>t,Fun (Set s) ts\<rangle>))
       in (upds = [] \<and> f A = f B) \<or> (upds \<noteq> [] \<and> f (g A) = f (g B))"
 
   define db_upds_consts_fresh where "db_upds_consts_fresh \<equiv>
     \<lambda>A::('fun,'atom,'sets,'lbl) prot_constr. \<lambda>X. \<lambda>J::('fun,'atom,'sets,'lbl) prot_subst. 
       \<forall>x \<in> X. (\<exists>n. \<I> x = Fun (PubConst Value n) []) \<longrightarrow> (\<forall>n s.
         insert\<langle>Fun (Val n) [],s\<rangle> \<in> set (unlabel A) \<or>
         delete\<langle>Fun (Val n) [],s\<rangle> \<in> set (unlabel A) \<longrightarrow>
           J x \<noteq> Fun (Val n) [])"
 
   define subst_eq_on_privvals where "subst_eq_on_privvals \<equiv> \<lambda>X \<J>.
     \<forall>x \<in> X. (\<exists>n. \<I> x = Fun (Val n) []) \<longrightarrow> \<I> x = \<J> x"
 
   define subst_in_ik_if_subst_pubval where "subst_in_ik_if_subst_pubval \<equiv>
     \<lambda>X \<J>. \<lambda>\<B>::('fun,'atom,'sets,'lbl) prot_constr.
       \<forall>x \<in> X. (\<exists>n. \<I> x = Fun (PubConst Value n) []) \<longrightarrow> \<J> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
 
   define subst_eq_iff where "subst_eq_iff \<equiv> \<lambda>X. \<lambda>\<J>::('fun,'atom,'sets,'lbl) prot_subst.
     \<forall>x \<in> X. \<forall>y \<in> X. \<I> x = \<I> y \<longleftrightarrow> \<J> x = \<J> y"
 
   obtain x_val T_val T_upds s_val ts_val l1_val l2_val where x_val:
       "T_val \<in> set P" "Var x_val \<in> set ts_val" "\<Gamma>\<^sub>v x_val = TAtom Value"
       "fv\<^sub>s\<^sub>e\<^sub>t (set ts_val) = {x_val}" "\<forall>n. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts_val)"
       "T_val = Transaction (\<lambda>(). []) [x_val] [] [] T_upds [(l1_val,send\<langle>ts_val\<rangle>)]"
       "T_upds = [] \<or>
        (T_upds = [(l2_val,insert\<langle>Var x_val,\<langle>s_val\<rangle>\<^sub>s\<rangle>)] \<and>
         (\<forall>T \<in> set P. \<forall>(l,a) \<in> set (transaction_strand T). \<forall>t.
           a \<noteq> select\<langle>t,\<langle>s_val\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t in \<langle>s_val\<rangle>\<^sub>s\<rangle> \<and> a \<noteq> \<langle>t not in \<langle>s_val\<rangle>\<^sub>s\<rangle> \<and>
           a \<noteq> delete\<langle>t,\<langle>s_val\<rangle>\<^sub>s\<rangle>))"
     using has_initial_value_producing_transactionE[OF P_val P, of thesis]
     by (auto simp add: disj_commute)
 
   have 0: "\<nexists>n. Fun (PubConst Value n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" when "\<B> \<in> reachable_constraints P" for \<B>
     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 \<I> \<A>" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     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: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. valconst_cases \<I> 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 \<A> n"
     using A(2) strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "[send\<langle>[attack\<langle>n\<rangle>]\<rangle>]" \<I>]
           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 \<xi>_empty = admissible_transaction_decl_subst_empty[OF bspec[OF P(1)]]
 
   have lmm:
       "\<exists>\<B> \<in> reachable_constraints P. \<exists>\<J>.
           ?wt_model \<J> \<B> \<and> valconsts_only (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X) \<J> \<and> (?rcv_att \<A> n \<longrightarrow> ?rcv_att \<B> n) \<and>
           subst_eq_on_privvals (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X) \<J> \<and>
           subst_in_ik_if_subst_pubval (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X) \<J> \<B> \<and>
           subst_eq_iff (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X) \<J> \<and>
           vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<and> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<and>
           (\<forall>n \<in> N. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)) \<and>
           ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<and> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<and>
           db_eq \<A> \<B> s_val T_upds \<and>
           db_upds_consts_fresh \<A> (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X) \<J>"
     when "finite N" "\<forall>n \<in> N. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" "X \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
          "finite X" "\<forall>x \<in> X. valconst_cases \<I> x" "\<forall>x \<in> X. \<Gamma>\<^sub>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 \<equiv> {n | n x. x \<in> X \<and> \<I> x = Fun (PubConst Value n) []}"
     define X_vals where "X_vals \<equiv> {n | n x. x \<in> X \<and> \<I> x = Fun (Val n) []}"
 
     have X_vals_finite: "finite X_vals"
       using finite_surj[OF init.prems(6),
                         of X_vals "\<lambda>x. THE n. \<I> x = Fun (Val n) []"]
       unfolding X_vals_def by force
 
     have pubvals_finite: "finite pubvals"
       using finite_surj[OF init.prems(6),
                         of pubvals "\<lambda>x. THE n. \<I> x = Fun (PubConst Value n) []"]
       unfolding pubvals_def by force
 
     obtain T_val_fresh_vals and \<delta>::"nat \<Rightarrow> nat"
       where T_val_fresh_vals: "T_val_fresh_vals \<inter> (N \<union> X_vals) = {}"
         and \<delta>: "inj \<delta>" "\<delta> ` 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 \<delta>(2) by blast
 
     obtain \<B>::"('fun,'atom,'sets,'lbl) prot_constr"
       where B:
           "\<B> \<in> reachable_constraints P"
           "T_upds = [] \<Longrightarrow> list_all is_Receive (unlabel \<B>)"
           "T_upds \<noteq> [] \<Longrightarrow> list_all (\<lambda>a. is_Insert a \<or> is_Receive a) (unlabel \<B>)"
           "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> = {}"
           "\<forall>n. Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<longrightarrow> Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
           "T_val_fresh_vals = {n. Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>}"
           "\<forall>l a. (l,a) \<in> set \<B> \<and> is_Insert a \<longrightarrow>
                   (l = l2_val \<and> (\<exists>n. a = insert\<langle>Fun (Val n) [],\<langle>s_val\<rangle>\<^sub>s\<rangle>))"
       using reachable_constraints_initial_value_transaction[
               OF P reachable_constraints.init T_val_fresh_vals_finite _ x_val]
       by auto
 
     define \<J> where "\<J> \<equiv> \<lambda>x.
       if x \<in> X \<and> (\<exists>n. \<I> x = Fun (PubConst Value n) [])
       then Fun (Val (\<delta> (THE n. \<I> x = Fun (PubConst Value n) []))) []
       else \<I> x"
 
     have 0: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" "?rcv_att [] n \<longrightarrow> ?rcv_att \<B> n"
             "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
       using B(4) vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<B>"] by auto
 
     have 1: "db_eq [] \<B> s_val T_upds" using B(2,3,7)
     proof (induction \<B>)
       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 \<or> is_Receive b" using a Cons.prems(2) by simp
         hence "\<exists>t. a = (l2_val,insert\<langle>t,\<langle>s_val\<rangle>\<^sub>s\<rangle>)" when b: "\<not>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 \<J> \<B>"
       unfolding welltyped_constraint_model_def constraint_model_def
     proof (intro conjI)
       show "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<J>" using I(4) init.prems(8) unfolding \<J>_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by fastforce
 
       show "strand_sem_stateful {} {} (unlabel \<B>) \<J>"
         using B(2,3) strand_sem_stateful_if_no_send_or_check[of "unlabel \<B>" "{}" "{}" \<J>]
         unfolding list_all_iff by blast
 
       show "subst_domain \<J> = UNIV" "ground (subst_range \<J>)"
         using I(2) unfolding \<J>_def subst_domain_def by auto
 
       show "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<J>)"
         using I(3) unfolding \<J>_def by fastforce
     qed
 
     have 3: "valconsts_only (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X) \<J>"
       using init.prems(7) unfolding \<J>_def valconsts_only_def valconst_cases_def by fastforce
 
     have 4: "subst_eq_on_privvals (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X) \<J>"
       unfolding subst_eq_on_privvals_def \<J>_def by force
 
     have 5: "subst_in_ik_if_subst_pubval (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X) \<J> \<B>"
     proof (unfold subst_in_ik_if_subst_pubval_def; intro ballI impI)
       fix x assume x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X" and "\<exists>n. \<I> x = Fun (PubConst Value n) []"
       then obtain n where n: "\<I> x = Fun (PubConst Value n) []" by blast 
 
       have "n \<in> pubvals" using x n unfolding pubvals_def by fastforce
       hence "\<delta> n \<in> T_val_fresh_vals" using \<delta>(2) by fast
       hence "Fun (Val (\<delta> n)) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" using B(6) by fast
       thus "\<J> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" using x n unfolding \<J>_def by simp
     qed
 
     have 6: "subst_eq_iff (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X) \<J>"
     proof (unfold subst_eq_iff_def; intro ballI)
       fix x y assume "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X" "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X"
       hence x: "x \<in> X" and y: "y \<in> X" by auto
 
       show "\<I> x = \<I> y \<longleftrightarrow> \<J> x = \<J> y"
       proof
         show "\<I> x = \<I> y \<Longrightarrow> \<J> x = \<J> y" using x y unfolding \<J>_def by presburger
       next
         assume J_eq: "\<J> x = \<J> y" show "\<I> x = \<I> y"
         proof (cases "\<exists>n. \<I> x = Fun (PubConst Value n) []")
           case True
           then obtain n where n: "\<I> x = Fun (PubConst Value n) []" by blast
           hence J_x: "\<J> x = Fun (Val (\<delta> n)) []" using x unfolding \<J>_def by simp
 
           show ?thesis
           proof (cases "\<exists>m. \<I> y = Fun (PubConst Value m) []")
             case True
             then obtain m where m: "\<I> y = Fun (PubConst Value m) []" by blast
             have J_y: "\<J> y = Fun (Val (\<delta> m)) []" using y m unfolding \<J>_def by simp
             show ?thesis using J_eq J_x J_y injD[OF \<delta>(1), of n m] n m by auto
           next
             case False
             then obtain m where m: "\<I> y = Fun (Val m) []"
               using init.prems(7) y unfolding valconst_cases_def by blast
             moreover have "\<delta> n \<in> T_val_fresh_vals" using \<delta>(2) x n unfolding pubvals_def by blast
             moreover have "m \<in> X_vals" using y m unfolding X_vals_def by blast
             ultimately have "\<J> x \<noteq> \<I> y" using m J_x T_val_fresh_vals by auto
             moreover have "\<J> y = \<I> y" using m unfolding \<J>_def by simp
             ultimately show ?thesis using J_eq by argo
           qed
         next
           case False
           then obtain n where n: "\<I> x = Fun (Val n) []"
             using init.prems(7) x unfolding valconst_cases_def by blast
           hence J_x: "\<J> x = \<I> x" unfolding \<J>_def by auto
 
           show ?thesis
           proof (cases "\<exists>m. \<I> y = Fun (PubConst Value m) []")
             case False
             then obtain m where m: "\<I> y = Fun (Val m) []"
               using init.prems(7) y unfolding valconst_cases_def by blast
             have J_y: "\<J> y = \<I> y" using y m unfolding \<J>_def by simp
             show ?thesis using J_x J_y J_eq by presburger
           next
             case True
             then obtain m where m: "\<I> y = Fun (PubConst Value m) []" by blast
             hence "\<J> y = Fun (Val (\<delta> m)) []" using y unfolding \<J>_def by fastforce
             moreover have "\<delta> m \<in> T_val_fresh_vals" using \<delta>(2) y m unfolding pubvals_def by blast
             moreover have "n \<in> X_vals" using x n unfolding X_vals_def by blast
             ultimately have "\<J> y \<noteq> \<I> 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: "\<forall>n \<in> N. Fun (Val n) [] \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
       using B(5,6) T_val_fresh_vals by blast
 
     have 8: "db_upds_consts_fresh [] (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t [] \<union> X) \<J>" 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 \<A> T \<xi> \<sigma> \<alpha> N X')
     define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
     define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     define T'_pubvals where "T'_pubvals \<equiv> {n. \<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'. \<I> x = Fun (PubConst Value n) []}"
     define \<A>_vals where "\<A>_vals \<equiv> {n. Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>}"
     define \<I>_vals where "\<I>_vals \<equiv> {n. \<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'. \<I> x = Fun (Val n) []}"
     define \<sigma>_vals where "\<sigma>_vals \<equiv> {n. Fun (Val n) [] \<in> subst_range \<sigma>}"
 
     have 3: "welltyped_constraint_model \<I> \<A>"
             "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. valconst_cases \<I> x"
             "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'. valconst_cases \<I> x"
             "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}) (unlabel T') \<I>"
             "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'. valconst_cases \<I> 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 \<A>" "unlabel T'" \<I>]
             step.prems(7)
       unfolding \<theta>_def[symmetric] T'_def[symmetric] unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_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 \<xi>_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 "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}" \<theta>,
                         unfolded T'_def[symmetric]]
                       3(4)]
 
     note \<sigma>_dom = transaction_fresh_subst_domain[OF step.hyps(4)]
 
     have \<sigma>_ran: "\<exists>n. t = Fun (Val n) []" when t: "t \<in> subst_range \<sigma>" for t
     proof -
       obtain x where x: "x \<in> set (transaction_fresh T)" "t = \<sigma> x"
         using \<sigma>_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_\<sigma>: "Fun (Val k) [] \<in> subst_range \<sigma>"
       when k: "Fun (Val k) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for k
     proof -
       have "Fun (Val k) [] \<in> (subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>"
         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 \<theta>_def[symmetric] trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq by fast
       then obtain t where t: "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms_transaction T" "t \<cdot> \<theta> = Fun (Val k) []" by force
       hence "Fun (Val k) [] \<in> subst_range \<theta>"
         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)] \<xi>_empty
         unfolding \<theta>_def[symmetric] by blast
     qed
 
     have \<sigma>_vals_is_T'_vals: "k \<in> \<sigma>_vals \<longleftrightarrow> Fun (Val k) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for k
     proof
       show "k \<in> \<sigma>_vals" when "Fun (Val k) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
         using that T'_vals_in_\<sigma> unfolding \<sigma>_vals_def by blast
 
       show "Fun (Val k) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" when k: "k \<in> \<sigma>_vals"
       proof -
         have "Fun (Val k) [] \<in> subst_range \<sigma>" using k unfolding \<sigma>_vals_def by fast
         then obtain x where x: "x \<in> fv_transaction T" "\<sigma> 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 "\<theta> x = Fun (Val k) []" using x(2) unfolding \<theta>_def \<xi>_empty subst_compose_def by auto
         thus ?thesis
           using fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t_subst[OF x(1), of \<theta>]
                 admissible_transactionE(4)[OF T_adm]
           unfolding T'_def trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq unlabel_subst by simp
       qed
     qed
 
     have \<sigma>_vals_N_disj: "N \<inter> \<sigma>_vals = {}"
       using step.prems(4) \<sigma>_vals_is_T'_vals
       unfolding \<theta>_def[symmetric] T'_def[symmetric] unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_append by blast
 
     have T'_pubvals_finite: "finite T'_pubvals"
       using finite_surj[OF fv\<^sub>s\<^sub>s\<^sub>t_finite[of "unlabel T'"],
                         of T'_pubvals "\<lambda>x. THE n. \<I> x = Fun (PubConst Value n) []"]
       unfolding T'_pubvals_def by force
 
     have \<sigma>_vals_finite: "finite \<sigma>_vals"
     proof -
       have *: "finite (subst_range \<sigma>)" using transaction_fresh_subst_domain[OF step.hyps(4)] by simp
       show ?thesis
         using finite_surj[OF *, of \<sigma>_vals "\<lambda>t. THE n. t = Fun (Val n) []"]
         unfolding \<sigma>_vals_def by force
     qed
 
     have \<A>_vals_finite: "finite \<A>_vals"
     proof -
       have *: "\<A>_vals \<subseteq> (\<lambda>t. THE n. t = Fun (Val n) []) ` subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
         unfolding \<A>_vals_def by force
       show ?thesis
         by (rule finite_surj[OF subterms_union_finite[OF trms\<^sub>s\<^sub>s\<^sub>t_finite] *])
     qed
 
     have \<I>_vals_finite: "finite \<I>_vals"
     proof -
       define X where "X \<equiv> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
       have *: "finite X" using fv\<^sub>s\<^sub>s\<^sub>t_finite step.prems(6) unfolding X_def by blast
       show ?thesis
         using finite_surj[OF *, of \<I>_vals "\<lambda>x. THE n. \<I> x = Fun (Val n) []"]
         unfolding \<I>_vals_def X_def[symmetric] by force
     qed
 
     obtain T_val_fresh_vals and \<delta>::"nat \<Rightarrow> nat"
       where T_val_fresh_vals: "T_val_fresh_vals \<inter> (N \<union> \<sigma>_vals \<union> \<A>_vals \<union> \<I>_vals) = {}"
         and \<delta>: "inj \<delta>" "\<delta> ` T'_pubvals = T_val_fresh_vals"
       using step.prems(3) T'_pubvals_finite \<sigma>_vals_finite \<A>_vals_finite \<I>_vals_finite
       by (metis finite_UnI ex_finite_disj_nat_inj)
 
     define N' where "N' \<equiv> N \<union> \<sigma>_vals \<union> T_val_fresh_vals"
 
     have T_val_fresh_vals_finite: "finite T_val_fresh_vals"
       using T'_pubvals_finite \<delta>(2) by blast
 
     have N'_finite: "finite N'"
       using step.prems(3) T'_pubvals_finite T_val_fresh_vals_finite \<sigma>_vals_finite
       unfolding N'_def by auto
 
     have \<A>_vals_trms_in: "n \<in> \<A>_vals" when "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" for n
       using that unfolding \<A>_vals_def by blast
 
     have N'_notin_\<A>: "\<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" when n: "n \<in> N'" for n
     proof -
       have ?thesis when n': "n \<in> N"
         using n' step.prems(4) unfolding N'_def unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_append by blast
       moreover have ?thesis when n': "n \<in> \<sigma>_vals"
         using n' step.hyps(4) unfolding \<sigma>_vals_def transaction_fresh_subst_def by blast
       moreover have ?thesis when n': "n \<in> T_val_fresh_vals"
         using n' T_val_fresh_vals \<A>_vals_trms_in by blast
       ultimately show ?thesis using n unfolding N'_def by blast
     qed
 
     have T'_fv_\<A>_disj: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t 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 \<theta>_def[symmetric] T'_def fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq by blast
 
     have X'_disj: "X' \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}" "X' \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = {}"
       using step.prems(5)
       unfolding \<theta>_def[symmetric] T'_def[symmetric] unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
       by (blast, blast)
 
     have X'_disj': "(X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
       using X'_disj(1) T'_fv_\<A>_disj by blast
 
     have X'_finite: "finite (X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
       using step.prems(6) fv\<^sub>s\<^sub>s\<^sub>t_finite by blast
 
     have \<A>_X'_valconstcases: "\<forall>x \<in> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'. valconst_cases \<I> x"
       using 3(3,5) by blast
 
     have T'_value_vars: "\<Gamma>\<^sub>v x = TAtom Value" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for x
       using x reachable_constraints_fv_Value_typed[
                 OF P reachable_constraints.step[OF step.hyps]]
       unfolding \<theta>_def[symmetric] T'_def[symmetric] unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
     have X'_T'_value_vars: "\<forall>x \<in> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'. \<Gamma>\<^sub>v x = TAtom Value"
       using step.prems(8) T'_value_vars by blast
 
     have N'_not_subterms_\<A>: "\<forall>n \<in> N'. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       using N'_notin_\<A> by blast
 
     obtain \<B> \<J> where B:
         "\<B> \<in> reachable_constraints P" "?wt_model \<J> \<B>"
         "valconsts_only (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<J>" "?rcv_att \<A> n \<longrightarrow> ?rcv_att \<B> n"
         "subst_eq_on_privvals (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<J>"
         "subst_in_ik_if_subst_pubval (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<J> \<B>"
         "subst_eq_iff (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<J>"
         "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
         "\<forall>n \<in> N'. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
         "db_eq \<A> \<B> s_val T_upds"
         "db_upds_consts_fresh \<A> (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X' \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<J>"
       using step.IH[OF 3(1,2) N'_finite N'_not_subterms_\<A> X'_disj' X'_finite
                        \<A>_X'_valconstcases X'_T'_value_vars]
       unfolding Un_assoc by fast
 
     have J:
         "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<J>" "constr_sem_stateful \<J> (unlabel \<B>)"
         "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<J>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<J>)"
       using B(2) unfolding welltyped_constraint_model_def constraint_model_def by blast+
 
     have T_val_fresh_vals_notin_\<B>: "\<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
         when "n \<in> T_val_fresh_vals" for n
       using that B(12) unfolding N'_def by blast
     hence "\<forall>n \<in> T_val_fresh_vals. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)" by blast
     then obtain T_val_constr::"('fun,'atom,'sets,'lbl) prot_constr"
       where T_val_constr:
           "\<B>@T_val_constr \<in> reachable_constraints P"
           "T_val_constr \<in> reachable_constraints P"
           "T_upds = [] \<Longrightarrow> list_all is_Receive (unlabel T_val_constr)"
           "T_upds \<noteq> [] \<Longrightarrow> list_all (\<lambda>a. is_Insert a \<or> is_Receive a) (unlabel T_val_constr)"
           "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr = {}"
           "\<forall>n. Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<longrightarrow> Fun (Val n) [] \<notin> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr"
           "\<forall>n. Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr \<longrightarrow> Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr"
           "T_val_fresh_vals = {n. Fun (Val n) [] \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr}"
           "\<forall>l a. (l,a) \<in> set T_val_constr \<and> is_Insert a \<longrightarrow>
                   (l = l2_val \<and> (\<exists>n. a = insert\<langle>Fun (Val n) [],\<langle>s_val\<rangle>\<^sub>s\<rangle>))"
       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 \<in> T_val_fresh_vals \<longleftrightarrow> Fun (Val k) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr"
       for k
       using that T_val_constr(7,8) ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset by fast
 
     have T_val_constr_no_fv: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr = {}"
       using T_val_constr(5) vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t by fast
 
     have T_val_\<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<B>@T_val_constr))"
     proof -
       have "\<not>(t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<B>@T_val_constr))" when t: "t \<in> subst_range \<sigma>" for t
       proof -
         obtain k where k: "t = Fun (Val k) []" using t \<sigma>_ran by fast
         have "k \<in> \<sigma>_vals" using t unfolding k \<sigma>_vals_def by blast
         thus ?thesis
           using B(12) T_val_fresh_vals T_val_constr(7,8)
           unfolding N'_def k unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_append by blast
       qed
       thus ?thesis using step.hyps(4) unfolding transaction_fresh_subst_def by fast
     qed
 
     have T_val_\<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<B>@T_val_constr))"
       using step.hyps B(8) T_val_constr(5) by auto
 
     define \<B>' where "\<B>' \<equiv> \<B>@T_val_constr@T'"
 
     define \<K> where "\<K> \<equiv> \<lambda>x.
       if x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'
       then if \<exists>n. \<I> x = Fun (PubConst Value n) []
            then if \<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> y = \<I> x
                 then \<J> (SOME y. y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X' \<and> \<I> y = \<I> x)
                 else Fun (Val (\<delta> (THE n. \<I> x = Fun (PubConst Value n) []))) []
            else \<I> x
       else \<J> x"
 
     have \<sigma>_ground_ran: "ground (subst_range \<sigma>)" "range_vars \<sigma> = {}" 
       and \<xi>_ran_bvars_disj: "range_vars \<xi> \<inter> 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 \<B>_T'_fv_disj: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = {}"
       using T'_fv_\<A>_disj unfolding B(9) by argo
     hence \<J>_\<K>_fv_\<B>_eq: "\<J> x = \<K> x" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'" for x
       using x X'_disj unfolding \<K>_def by auto
 
     have B'1: "\<B>' \<in> reachable_constraints P"
       using reachable_constraints.step[OF T_val_constr(1) step.hyps(2,3) T_val_\<sigma> T_val_\<alpha>]
       unfolding \<B>'_def T'_def \<theta>_def by simp
 
     have "\<exists>n. \<K> x = Fun (Val n) []" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X'" for x
     proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'")
       case True
       note T = this
       show ?thesis
       proof (cases "\<exists>n. \<I> x = Fun (PubConst Value n) []")
         case True thus ?thesis
           using T B(3,9) someI_ex[of "\<lambda>y. y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X' \<and> \<I> y = \<I> x"]
           unfolding \<K>_def valconsts_only_def
           by (cases "\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> y = \<I> x") (meson, auto)
       next
         case False thus ?thesis
           using T 3(3) unfolding \<K>_def valconst_cases_def by fastforce
       qed
     next
       case False thus ?thesis using x B(3) unfolding \<K>_def valconsts_only_def by auto
     qed
     hence B'3: "valconsts_only (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X') \<K>" unfolding valconsts_only_def by blast
 
     have B'4: "?rcv_att \<B>' n" when "?rcv_att (\<A>@T') n"
       using that B(4) unfolding \<B>'_def by auto
 
     have "\<I> x = \<K> x" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X'" "\<I> x = Fun (Val n) []" for x n
     proof -
       have "\<K> x = \<J> x" when "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" using that unfolding \<K>_def by meson
       moreover have "\<K> x = \<I> x" when "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" using that x unfolding \<K>_def by simp
       ultimately show ?thesis
         using B(5) x
         unfolding subst_eq_on_privvals_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
         by (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'") auto
     qed
     hence B'5: "subst_eq_on_privvals (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X') \<K>"
       unfolding subst_eq_on_privvals_def by blast
 
     have \<A>_fv_\<K>_eq_\<J>: "\<K> x = \<J> x" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" for x
     proof -
       have "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" using x T'_fv_\<A>_disj X'_disj by blast
       thus ?thesis unfolding \<K>_def by argo
     qed
 
     have T'_fv_\<I>_val_\<K>_eq_\<J>: "\<K> x = \<I> x" 
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<nexists>n. \<I> x = Fun (PubConst Value n) []" for x
       using x B'5 3(3) unfolding unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append valconst_cases_def \<K>_def by meson
 
     have T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val:
         "\<K> x = Fun (Val (\<delta> n)) []" "\<delta> n \<in> T_val_fresh_vals" 
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<I> x = Fun (PubConst Value n) []" "\<forall>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> y \<noteq> \<I> x"
       for x n
     proof -
       show "\<K> x = Fun (Val (\<delta> n)) []" using x unfolding \<K>_def by auto
       show "\<delta> n \<in> T_val_fresh_vals" using \<delta>(2) x unfolding T'_pubvals_def by blast
     qed
 
     have T'_fv_\<I>_pubval_\<K>_eq_\<J>_val:
         "\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<exists>m. \<I> y = \<I> x \<and> \<K> x = \<J> y \<and> \<K> x = Fun (Val m) []"
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<I> x = Fun (PubConst Value n) []" "\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> y = \<I> x"
       for x n
     proof -
       have "\<K> x = \<J> (SOME y. y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X' \<and> \<I> y = \<I> x)" using x unfolding \<K>_def by meson
       then obtain y where y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'" "\<I> y = \<I> x" "\<K> x = \<J> y"
         using x(3) someI_ex[of "\<lambda>y. y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X' \<and> \<I> y = \<I> x"] by blast
       thus ?thesis using B(3,9) unfolding valconsts_only_def by auto
     qed
 
     have T'_fv_\<I>_pubval_\<K>_eq_val: "\<exists>n. \<K> x = Fun (Val n) []"
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<I> x = Fun (PubConst Value n) []" for x n
       using T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val[OF x] T'_fv_\<I>_pubval_\<K>_eq_\<J>_val[OF x] by auto
 
     have B'6': "\<K> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" "\<I> x = Fun (PubConst Value n) []" for x n
       using x B(6) \<A>_fv_\<K>_eq_\<J> x(2) unfolding B(8) subst_in_ik_if_subst_pubval_def by simp
 
     have B'6'': "\<K> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr"
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<I> x = Fun (PubConst Value n) []" for x n
     proof (cases "\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> y = \<I> x")
       case True thus ?thesis
         using B(6) x(2) T'_fv_\<I>_pubval_\<K>_eq_\<J>_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_\<I>_pubval_\<K>_eq_\<delta>_fresh_val[OF x] by force
     qed
 
     have "\<K> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'"
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X'" "\<I> x = Fun (PubConst Value n) []" for x n
     proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'")
       case True thus ?thesis using B'6''[OF _ x(2)] unfolding \<B>'_def by auto
     next
       case False
       hence "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'"
         using x(1) unfolding unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
       thus ?thesis using B'6' x(2) unfolding \<B>'_def by simp
     qed
     hence B'6: "subst_in_ik_if_subst_pubval (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X') \<K> \<B>'"
       unfolding subst_in_ik_if_subst_pubval_def by blast
 
     have B'7: "subst_eq_iff (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X') \<K>"
     proof (unfold subst_eq_iff_def; intro ballI)
       fix x y assume xy: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X'" "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X'"
 
       let ?Q = "\<lambda>x y. \<I> x = \<I> y \<longleftrightarrow> \<K> x = \<K> y"
 
       have *: "?Q x y"
         when xy: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" "y \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for x y
         using B(7) xy unfolding \<K>_def subst_eq_iff_def by force
 
       have **: "?Q x y" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" and y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for x y
       proof -
         have xy_neq: "x \<noteq> y" using x y T'_fv_\<A>_disj X'_disj by blast
 
         have x_eq: "\<K> x = \<J> x"
           using \<A>_fv_\<K>_eq_\<J> x by blast
 
         have x_eq_if_val: "\<I> x = \<J> x" when "\<I> 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: "\<I> x \<noteq> \<J> x" when "\<I> 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: "\<I> y = \<K> y" when "\<I> y = Fun (Val n) []" for n
           using that y B'5 unfolding subst_eq_on_privvals_def by simp
 
         have y_eq: "\<K> y = Fun (Val (\<delta> n)) []"
           when "\<I> y = Fun (PubConst Value n) []" "\<forall>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z \<noteq> \<I> y" for n
           by (rule T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val(1)[OF y that])
 
         have y_eq': "\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<exists>m. \<I> z = \<I> y \<and> \<K> y = \<J> z \<and> \<K> y = Fun (Val m) []"
           when "\<I> y = Fun (PubConst Value n) []" "\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z = \<I> y" for n
           by (rule T'_fv_\<I>_pubval_\<K>_eq_\<J>_val[OF y that])
 
         have K_eq_if_I_eq: "\<I> x = \<I> y \<Longrightarrow> \<K> x = \<K> y"
           apply (cases "\<exists>n. \<I> 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_\<I>_val_\<K>_eq_\<J>[OF y] 3(5) valconst_cases_def x_eq_if_val)
           done
 
         have K_neq_if_I_neq_val: "\<K> x \<noteq> \<K> y"
           when n: "\<I> y = Fun (Val n) []"
             and m: "\<I> x = Fun (PubConst Value m) []"
           for n m
         proof -
           have I_neq: "\<I> x \<noteq> \<I> 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: "\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z = \<I> x" using x unfolding B(9) by blast
           have J1: "\<J> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" using B(6) x m unfolding subst_in_ik_if_subst_pubval_def by fast
           have J2: "\<I> x \<noteq> \<J> x"
             by (metis m B(3) x UnI1 prot_fun.distinct(37) term.inject(2) valconsts_only_def)
           have J3: "\<I> y = \<J> y" using B(5) n y unfolding subst_eq_on_privvals_def by blast
           have K_x: "\<K> x \<noteq> \<I> x" using J2 x_eq by presburger
           have x_notin: "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" using x T'_fv_\<A>_disj X'_disj by blast
           have K_x': "\<K> x = \<J> x" using x_notin unfolding \<K>_def by argo
           have K_y: "\<K> y = \<J> y" using y_eq'' J3 by argo
 
           have "\<J> x \<noteq> \<J> 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 "\<I> x = \<I> y \<Longrightarrow> \<K> x = \<K> y" by (rule K_eq_if_I_eq)
         next
           assume xy_eq: "\<K> x = \<K> y" show "\<I> x = \<I> y"
           proof (cases "\<exists>n. \<I> y = Fun (PubConst Value n) []")
             case True
             then obtain n where n: "\<I> y = Fun (PubConst Value n) []" by blast
 
             show ?thesis
             proof (cases "\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z = \<I> 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: "\<forall>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z \<noteq> \<I> y" by blast
               note y_eq'' = y_eq[OF n F]
 
               have n_in: "\<delta> n \<in> T_val_fresh_vals"
                 using  \<delta>(2) x_eq xy_eq T_val_fresh_vals_notin_\<B> y n
                 unfolding T'_pubvals_def by blast
               hence y_notin: "\<not>(\<K> y \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
                 using T_val_fresh_vals_notin_\<B> y_eq'' ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset[of "unlabel \<B>"]
                 by auto
 
               show ?thesis
               proof (cases "\<exists>m. \<I> 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: "\<I> x = Fun (Val m) []"
                   using 3(5) x unfolding valconst_cases_def by fast
                 hence "\<I> x = \<J> x" using x B(5) unfolding subst_eq_on_privvals_def by blast
                 hence "\<K> x = Fun (Val m) []" using m x_eq by argo
                 moreover have "m \<notin> T_val_fresh_vals"
                   using m T_val_fresh_vals x unfolding \<I>_vals_def by blast
                 hence "m \<noteq> \<delta> 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: "\<I> 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 "\<exists>m. \<I> 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: "\<I> 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 \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" and y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for x y
       proof
         assume xy_eq: "\<I> x = \<I> y" show "\<K> x = \<K> y"
         proof (cases "\<exists>n. \<I> x = Fun (PubConst Value n) []")
           case True thus ?thesis
             using xy_eq x y B(7) T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val(1) T'_fv_\<I>_pubval_\<K>_eq_\<J>_val
             unfolding B(9) subst_eq_iff_def by (metis (no_types) UnI1)
         qed (metis xy_eq x y T'_fv_\<I>_val_\<K>_eq_\<J>)
       next
         assume xy_eq: "\<K> x = \<K> y"
 
         have case1: False
           when x': "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
             and y': "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
             and xy_eq': "\<K> x = \<K> y"
             and m: "\<I> x = Fun (PubConst Value m) []"
             and n: "\<I> y = Fun (Val n) []"
           for x y n m
         proof -
           have F: "\<nexists>n. \<I> y = Fun (PubConst Value n) []" using n by auto
 
           note x_eq = T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val[OF x' m]
           note y_eq = T'_fv_\<I>_val_\<K>_eq_\<J>[OF y' F]
 
           have "\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z = \<I> x"
           proof (rule ccontr)
             assume no_z: "\<not>(\<exists>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z = \<I> x)"
             hence "n \<noteq> \<delta> m" using n y' x_eq(2) T_val_fresh_vals unfolding \<I>_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 \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'" "\<I> z = \<I> x" "\<K> x = \<J> z" "\<K> x = Fun (Val k) []"
             using T'_fv_\<I>_pubval_\<K>_eq_\<J>_val[OF x' m] by blast
 
           have "\<I> y = \<J> z" using z(2,3) y_eq xy_eq' by presburger
           hence "\<I> x = \<I> y" using z(1,2) ** B(9) \<J>_\<K>_fv_\<B>_eq y' y_eq by metis
           thus False using n m by simp
         qed
 
         have case2: "m = n"
           when x': "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
             and y': "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
             and xy_eq': "\<K> x = \<K> y"
             and m: "\<I> x = Fun (PubConst Value m) []"
             and n: "\<I> y = Fun (PubConst Value n) []"
           for x y n m
         proof (cases "\<forall>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z \<noteq> \<I> x")
           case True show ?thesis
             apply (cases "\<forall>z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> X'. \<I> z \<noteq> \<I> y")
             subgoal
               using xy_eq' m n T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val[OF x' m True]
                     T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val[OF y' n] injD[OF \<delta>(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 \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
             and y': "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
             and xy_eq': "\<K> x = \<K> y"
             and m: "\<I> x = Fun (Val m) []"
             and n: "\<I> y = Fun (Val n) []"
           for x y n m
           using x' y' xy_eq' m n T'_fv_\<I>_val_\<K>_eq_\<J> by fastforce
 
         show "\<I> x = \<I> 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 \<in> X'" "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" for x y
       proof -
         have xy': "y \<notin> X'" "y \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
           using xy X'_disj T'_fv_\<A>_disj by (blast, blast, blast)
 
         have K_x: "\<K> x = \<J> x" using xy(2) unfolding \<K>_def by argo
 
         have I_iff_J: "\<I> x = \<I> y \<longleftrightarrow> \<J> x = \<J> y" using xy B(7) unfolding subst_eq_iff_def by fast
 
         show ?thesis using K_x I_iff_J K_x injD[OF \<delta>(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 fv\<^sub>s\<^sub>s\<^sub>t_append by (metis Un_iff)
     qed
 
     have B'8_9: "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') = vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'" "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'"
       using B(8,9) T_val_constr(5) vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel T_val_constr"]
       unfolding \<B>'_def unlabel_append vars\<^sub>s\<^sub>s\<^sub>t_append fv\<^sub>s\<^sub>s\<^sub>t_append by simp_all
 
     have I': "\<exists>n. \<I> x = Fun (PubConst Value n) []"
       when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "\<nexists>n. \<I> x = Fun (Val n) []" for x
       using x 3(3) unfolding valconst_cases_def by fast
 
     have B'10_11: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<subseteq> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'" "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'"
       using B(10,11) unfolding N'_def \<B>'_def unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_append ik\<^sub>s\<^sub>s\<^sub>t_append
       by (blast, blast)
 
     have B'12: "\<forall>n \<in> N. \<not>(Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>')"
       using B(12) \<sigma>_vals_is_T'_vals \<sigma>_vals_N_disj T_val_fresh_vals
             T_val_fresh_vals_is_T_val_constr_vals
       unfolding N'_def \<B>'_def unfolding unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_append ik\<^sub>s\<^sub>s\<^sub>t_append by fast
 
     have B'13: "db_eq (\<A>@T') \<B>' s_val T_upds"
     proof -
       let ?f = "filter is_Update \<circ> unlabel"
       let ?g = "filter (\<lambda>a. \<nexists>l t ts. a = (l, insert\<langle>t,Fun (Set s_val) ts\<rangle>))"
 
       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 \<or> is_Receive b" using a Cons.prems(1,2) by simp
           hence "\<exists>t. a = (l2_val, insert\<langle>t,\<langle>s_val\<rangle>\<^sub>s\<rangle>)" when b: "\<not>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 (\<A>@T')) = ?f (?g \<A>)@?f (?g T')"
             "?f (?g (\<B>@T_val_constr@T')) = ?f (?g \<B>)@?f (?g T')"
         when "T_upds \<noteq> []"
         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 (\<A>@T') = ?f \<A>@?f T'"
             "?f (\<B>@T_val_constr@T') = ?f \<B>@?f T'"
         when "T_upds = []"
         using that by auto
       ultimately show ?thesis using B(13) unfolding \<B>'_def db_eq_def Let_def by presburger  
     qed
 
     have B'14: "db_upds_consts_fresh (\<A>@T') (fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X') \<K>"
     proof (unfold db_upds_consts_fresh_def; intro ballI allI impI; elim exE)
       fix x s n m
       assume x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<union> X'"
         and n: "insert\<langle>Fun (Val n) [],s\<rangle> \<in> set (unlabel (\<A>@T')) \<or>
                 delete\<langle>Fun (Val n) [],s\<rangle> \<in> set (unlabel (\<A>@T'))"
               (is "?A (\<A>@T')")
         and m: "\<I> x = Fun (PubConst Value m) []"
 
       have A_cases: "?A \<A> \<or> ?A T'" using n by force
 
       have n_in_case: "n \<in> \<sigma>_vals" when A: "?A T'"
       proof -
         obtain t s' where t:
           "insert\<langle>t,s'\<rangle> \<in> set (unlabel (transaction_strand T)) \<or>
            delete\<langle>t,s'\<rangle> \<in> set (unlabel (transaction_strand T))"
           "Fun (Val n) [] = t \<cdot> \<theta>"
         using A dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(4,5)
               stateful_strand_step_mem_substD(4,5)[of _ _ _ \<theta>]
               subst_lsst_unlabel[of _ \<theta>]
         unfolding T'_def by (metis (no_types, opaque_lifting))
 
         have "Fun (Val n) [] \<in> subst_range \<theta>"
           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) [] \<in> subst_range \<sigma>"
           using transaction_decl_fresh_renaming_substs_range'(4)[
                   OF step.hyps(3,4,5) _ \<xi>_empty]
           unfolding \<theta>_def by blast
         thus ?thesis unfolding \<sigma>_vals_def by fast
       qed
 
       have in_A_case: "\<K> x \<noteq> Fun (Val n) []"
         when y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" "\<I> x = \<I> y" "\<K> x = \<J> y" for y
         using A_cases
       proof
         assume "?A \<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 \<in> N'" using n_in_case unfolding N'_def by blast
         moreover have "\<J> y \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
           using B(6) y(1) m ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_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 "\<K> x \<noteq> Fun (Val n) []"
       proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'")
         case True
         note 0 = T'_fv_\<I>_pubval_\<K>_eq_\<delta>_fresh_val[OF True m, unfolded B(9)[symmetric]]
         note 1 = T'_fv_\<I>_pubval_\<K>_eq_\<J>_val[OF True m, unfolded B(9)[symmetric]]
 
         show ?thesis
         proof (cases "\<forall>y\<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'. \<I> y \<noteq> \<I> x")
           case True show ?thesis
             using A_cases 0[OF True] T_val_fresh_vals n_in_case
             unfolding \<A>_vals_def by force
         next
           case False
           then obtain y where "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" "\<I> y = \<I> x" "\<K> x = \<J> y" using 1 by blast
           thus ?thesis using in_A_case by auto
         qed
       next
         case False
         hence x_in: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> X'" using x unfolding unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by fast
         hence x_eq: "\<K> x = \<J> x" using \<A>_fv_\<K>_eq_\<J> by blast
 
         show ?thesis using in_A_case[OF x_in _ x_eq] by blast
       qed
     qed
 
     have B'2: "?wt_model \<K> \<B>'"
     proof (unfold welltyped_constraint_model_def; intro conjI)
       have "\<Gamma> (\<K> x) = \<Gamma>\<^sub>v x" for x
       proof -
         have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<J>" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
           using B(2) 3(1) unfolding welltyped_constraint_model_def by (blast,blast)
         hence *: "\<And>y. \<Gamma> (\<J> y) = \<Gamma>\<^sub>v y" "\<And>y. \<Gamma> (\<I> y) = \<Gamma>\<^sub>v y" unfolding wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by auto
 
         show ?thesis
         proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'")
           case True
           note x = this
           show ?thesis
           proof (cases "\<exists>n. \<I> x = Fun (PubConst Value n) []")
             case True thus ?thesis using T'_fv_\<I>_pubval_\<K>_eq_val[OF x] T'_value_vars[OF x] by force
           next
             case False thus ?thesis using x * unfolding \<K>_def by presburger
           qed
         next
           case False thus ?thesis using *(1) unfolding \<K>_def by presburger
         qed
       qed
       thus "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<K>" unfolding \<K>_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by force
 
       show "constraint_model \<K> \<B>'"
       proof (unfold constraint_model_def; intro conjI)
         have *: "strand_sem_stateful {} {} (unlabel \<A>) \<I>"
                 "strand_sem_stateful {} {} (unlabel \<B>) \<J>"
                 "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<J>"
                 "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<J>)"
           using B(2) 3(1) unfolding welltyped_constraint_model_def constraint_model_def by fast+
 
         show K0: "subst_domain \<K> = UNIV"
         proof -
           have "x \<in> subst_domain \<K>" for x
           proof (cases "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'")
             case True thus ?thesis
               using T'_fv_\<I>_pubval_\<K>_eq_val[OF True] T'_fv_\<I>_val_\<K>_eq_\<J>[OF True] *(3)
               unfolding subst_domain_def by (cases "\<exists>n. \<I> x = Fun (PubConst Value n) []") auto
           next
             case False thus ?thesis using *(4) unfolding \<K>_def subst_domain_def by auto
           qed
           thus ?thesis by blast
         qed
 
         have "fv (\<K> x) = {}" for x
           using interpretation_grounds_all[OF *(3)]
                 interpretation_grounds_all[OF *(4)]
           unfolding \<K>_def by simp
         thus K1: "ground (subst_range \<K>)" by simp
 
         have "wf\<^sub>t\<^sub>r\<^sub>m (Fun (Val n) [])" for n by fastforce
         moreover have "wf\<^sub>t\<^sub>r\<^sub>m (\<I> x)" "wf\<^sub>t\<^sub>r\<^sub>m (\<J> x)" for x using *(5,6) by (fastforce,fastforce)
         ultimately have "wf\<^sub>t\<^sub>r\<^sub>m (\<K> x)" for x unfolding \<K>_def by auto
         thus K2: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<K>)" by simp
 
         show "strand_sem_stateful {} {} (unlabel \<B>') \<K>"
         proof (unfold \<B>'_def unlabel_append strand_sem_append_stateful Un_empty_left; intro conjI)
           let ?sem = "\<lambda>M D A. strand_sem_stateful M D (unlabel A) \<K>"
           let ?M1 = "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K>"
           let ?M2 = "?M1 \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K>)"
           let ?D1 = "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<B>) \<K> {}"
           let ?D2 = "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel T_val_constr) \<K> ?D1"
 
           show "?sem {} {} \<B>"
             using \<J>_\<K>_fv_\<B>_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 \<union> {(t \<cdot> \<K>, s \<cdot> \<K>) | t s. insert\<langle>t,s\<rangle> \<in> set (unlabel T_val_constr)}"
             using T_val_constr(3,4) dbupd\<^sub>s\<^sub>s\<^sub>t_no_deletes
             unfolding list_all_iff by blast
 
           have K3: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<K>"
             using K0 K1 by argo
 
           have rcv_\<theta>_is_\<alpha>: "t \<cdot> \<theta> = t \<cdot> \<alpha>"
             when t: "(l,receive\<langle>ts\<rangle>) \<in> set (transaction_receive T)" "t \<in> set ts" for l ts t
           proof -
             have "fv t \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
               using t(2) stateful_strand_step_fv_subset_cases(2)[OF unlabel_in[OF t(1)]] by auto
             hence "t \<cdot> \<sigma> = t" using t \<sigma>_dom \<sigma>_ran admissible_transactionE(12,13)[OF T_adm] by blast
             thus ?thesis unfolding \<theta>_def \<xi>_empty by simp
           qed
       
           have eq_\<theta>_is_\<alpha>: "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>"
             when t: "(l,\<langle>ac: t \<doteq> s\<rangle>) \<in> set (transaction_checks T)" for l ac t s
           proof -
             have "fv t \<union> fv s \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
               using stateful_strand_step_fv_subset_cases(3)[OF unlabel_in[OF t]] by auto
             hence "t \<cdot> \<sigma> = t" "s \<cdot> \<sigma> = s"
               using t \<sigma>_dom \<sigma>_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
             thus "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>" unfolding \<theta>_def \<xi>_empty by simp_all
           qed
 
           have noteq_\<theta>_is_\<alpha>: "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>"
             when t: "(l,\<langle>t != s\<rangle>) \<in> set (transaction_checks T)" for l t s
           proof -
             have "fv t \<union> fv s \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
               using stateful_strand_step_fv_subset_cases(8)[OF unlabel_in[OF t]] by auto
             hence "t \<cdot> \<sigma> = t" "s \<cdot> \<sigma> = s"
               using t \<sigma>_dom \<sigma>_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
             thus "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>" unfolding \<theta>_def \<xi>_empty by simp_all
           qed
 
           have in_\<theta>_is_\<alpha>: "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>"
             when t: "(l,\<langle>ac: t \<in> s\<rangle>) \<in> set (transaction_checks T)" for l ac t s
           proof -
             have "fv t \<union> fv s \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
               using stateful_strand_step_fv_subset_cases(6)[OF unlabel_in[OF t]] by auto
             hence "t \<cdot> \<sigma> = t" "s \<cdot> \<sigma> = s"
               using t \<sigma>_dom \<sigma>_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
             thus "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>" unfolding \<theta>_def \<xi>_empty by simp_all
           qed
 
           have notin_\<theta>_is_\<alpha>: "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>"
             when t: "(l,\<langle>t not in s\<rangle>) \<in> set (transaction_checks T)" for l t s
           proof -
             have "fv t \<union> fv s \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)"
               using stateful_strand_step_fv_subset_cases(9)[OF unlabel_in[OF t]] by auto
             hence "t \<cdot> \<sigma> = t" "s \<cdot> \<sigma> = s"
               using t \<sigma>_dom \<sigma>_ran admissible_transactionE(12,13)[OF T_adm] by (blast, blast)
             thus "t \<cdot> \<theta> = t \<cdot> \<alpha>" "s \<cdot> \<theta> = s \<cdot> \<alpha>" unfolding \<theta>_def \<xi>_empty by simp_all
           qed
 
           have T'_trm_no_val: "\<nexists>n. s = Fun (Val n) [] \<or> s = Fun (PubConst Value n) []"
             when t: "t \<in> trms_transaction T" "s \<sqsubseteq> t \<cdot> \<alpha>" for t s
           proof -
             have ?thesis when "s \<sqsubseteq> 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 [] \<sqsubseteq> u" when "Fun k [] \<sqsubseteq> u \<cdot> \<alpha>" 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 \<equiv> \<lambda>A::('fun,'atom,'sets,'lbl) prot_constr.
                                       filter is_Update (unlabel A)"
           define flt2 where "flt2 \<equiv> \<lambda>A::('fun,'atom,'sets,'lbl) prot_constr.
                                       filter (\<lambda>a. \<nexists>l t ts. a = (l, insert\<langle>t,\<langle>s_val\<langle>ts\<rangle>\<rangle>\<^sub>s\<rangle>)) A"
           define flt3 where "flt3 \<equiv> \<lambda>A::(('fun,'atom,'sets,'lbl) prot_fun,
                                           ('fun,'atom,'sets,'lbl) prot_var) stateful_strand.
                                       filter (\<lambda>a. \<nexists>t ts. a = insert\<langle>t,\<langle>s_val\<langle>ts\<rangle>\<rangle>\<^sub>s\<rangle>) A"
 
           have flt2_subset: "set (unlabel (flt2 A)) \<subseteq> 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 (\<lambda>a. \<nexists>t ts. a = insert\<langle>t,\<langle>s_val\<langle>ts\<rangle>\<rangle>\<^sub>s\<rangle>) 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 \<A>) = flt1 (flt2 \<B>)"
           proof -
             have *: "flt1 (flt2 \<A>) = filter is_Update (flt3 (unlabel \<A>))"
                     "flt1 (flt2 \<B>) = filter is_Update (flt3 (unlabel \<B>))"
               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 \<A>) = filter is_Update (unlabel \<B>)"
                 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: "\<forall>t s. insert\<langle>t,s\<rangle> \<in> set (unlabel \<A>) \<longrightarrow> (\<exists>g ts. s = Fun g ts)"
             using reachable_constraints_setops_form[OF step.hyps(1) P]
             unfolding setops\<^sub>s\<^sub>s\<^sub>t_def by fastforce
 
           have A_insert_delete_not_subterm:
               "\<I> x = \<K> x \<or> (\<not>(\<I> x \<sqsubseteq> t) \<and> \<not>(\<I> x \<sqsubseteq> s) \<and> \<not>(\<K> x \<sqsubseteq> t) \<and> \<not>(\<K> x \<sqsubseteq> s))"
             when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<union> fv t \<union> fv s"
               and x_neq: "\<I> x \<noteq> \<K> x"
               and ts: "insert\<langle>t,s\<rangle> \<in> set (unlabel \<A>) \<or> delete\<langle>t,s\<rangle> \<in> set (unlabel \<A>)"
             for x t s
           proof -
             have x_in: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t 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 *: "\<I> x = \<K> x" when n: "\<I> x = Fun (Val n) []" for n
               using n B'5 x_in
               unfolding subst_eq_on_privvals_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by blast
 
             have **: "\<not>(\<I> x \<sqsubseteq> t)" "\<not>(\<I> x \<sqsubseteq> s)" "\<not>(\<K> x \<sqsubseteq> t)" "\<not>(\<K> x \<sqsubseteq> s)"
               when n: "\<I> x = Fun (PubConst Value n) []" for n
             proof -
               show "\<not>(\<I> x \<sqsubseteq> s)"
                 using ts'(1) x_in 3(2,3) unfolding valconst_cases_def by fastforce
 
               show "\<not>(\<K> x \<sqsubseteq> s)"
                 using ts'(1) x_in B'3
                 unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by force
 
               show "\<not>(\<I> x \<sqsubseteq> t)" using n ts'(3) by fastforce
 
               from ts'(3) have "\<K> x \<noteq> t"
               proof
                 assume "\<exists>y. t = Var y" thus ?thesis
                   using B'3 x_in unfolding valconsts_only_def by force
               next
                 assume "\<exists>k. t = Fun (Val k) []" thus ?thesis
                   using B'14 n x_in ts unfolding db_upds_consts_fresh_def by auto
               qed
               thus "\<not>(\<K> x \<sqsubseteq> 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\<langle>u,v\<rangle> \<in> set (unlabel A) \<longleftrightarrow> insert\<langle>u,v\<rangle> \<in> set (unlabel (flt2 A))"
             (is "?A A \<longleftrightarrow> ?B A")
             when h: "s = \<langle>h\<rangle>\<^sub>s" "h \<noteq> s_val" and t: "(t \<cdot> I,s \<cdot> I) = (u,v) \<cdot>\<^sub>p I"
             for t s h u v A and I::"('fun,'atom,'sets,'lbl) prot_subst"
           proof
             show "?B A \<Longrightarrow> ?A A" using flt2_subset by fast
             show "?A A \<Longrightarrow> ?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\<langle>u,v\<rangle>")
                 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 \<cdot> \<K>, s \<cdot> \<K>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (flt2 \<B>)) \<K> {} \<longleftrightarrow>
                (t \<cdot> \<K>, s \<cdot> \<K>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<B>) \<K> {}"
             (is "?A \<longleftrightarrow> ?B")
             when h: "s = \<langle>h\<rangle>\<^sub>s" "h \<noteq> s_val"
             for t s h
           proof
             let ?C1 = "\<lambda>u v B C. suffix (delete\<langle>u,v\<rangle>#B) (unlabel C)"
             let ?C2 = "\<lambda>t s u v. (t,s) = (u,v) \<cdot>\<^sub>p \<K>"
             let ?C3 = "\<lambda>t s C. \<exists>u v. ?C2 t s u v \<and> insert\<langle>u,v\<rangle> \<in> set C"
             let ?D = "\<lambda>t s C. \<forall>u v B. ?C1 u v B C \<and> ?C2 t s u v \<longrightarrow> ?C3 t s B"
 
             let ?db = "\<lambda>C D. dbupd\<^sub>s\<^sub>s\<^sub>t C \<K> D"
 
             have "?C3 t s B"
               when "?D t s (flt2 \<B>)" "?C1 u v B \<B>" "?C2 t s u v" for u v B t s
               using that flt2_suffix flt2_subset by fastforce
             thus "?A \<Longrightarrow> ?B" using flt2_subset unfolding dbupd\<^sub>s\<^sub>s\<^sub>t_in_iff by blast
 
             show ?A when ?B using that
             proof (induction \<B> 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 dbupd\<^sub>s\<^sub>s\<^sub>t_append[of _ _ \<K> "{}"] unfolding a flt2_def by auto
 
               show ?case
               proof (cases "\<exists>u v. b = insert\<langle>u,v\<rangle> \<and> (t \<cdot> \<K>, s \<cdot> \<K>) = (u,v) \<cdot>\<^sub>p \<K>")
                 case True
                 then obtain u v where "b = insert\<langle>u,v\<rangle>" "(t \<cdot> \<K>, s \<cdot> \<K>) = (u, v) \<cdot>\<^sub>p \<K>" by force
                 thus ?thesis using h *(2) unfolding a flt2_def by auto
               next
                 case False
                 hence IH: "(t \<cdot> \<K>, s \<cdot> \<K>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel (flt2 A)) \<K> {}"
                   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\<langle>u,v\<rangle>" 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 \<cdot> \<K>, s \<cdot> \<K>) \<noteq> (u,v) \<cdot>\<^sub>p \<K>" 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 \<cdot> \<I>, s \<cdot> \<I>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {} \<longleftrightarrow>
                (t \<cdot> \<K>, s \<cdot> \<K>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<B>) \<K> {}"
             (is "?in \<I> (unlabel \<A>) \<longleftrightarrow> ?in \<K> (unlabel \<B>)")
             when h: "s = \<langle>h\<rangle>\<^sub>s"
                     "h \<noteq> s_val \<or> filter is_Update (unlabel \<A>) = filter is_Update (unlabel \<B>)"
               and t: "t = Var tx"
               and t_s_fv: "fv t \<union> fv s \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
               and q: "\<forall>x \<in> fv t \<union> fv s.
                         \<I> x = \<K> x \<or> (\<not>(\<I> x \<sqsubseteq> t) \<and> \<not>(\<I> x \<sqsubseteq> s) \<and> \<not>(\<K> x \<sqsubseteq> t) \<and> \<not>(\<K> x \<sqsubseteq> s))"
                      "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv t \<union> fv s. \<exists>c. \<I> x = Fun c []"
                      "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv t \<union> fv s. \<exists>c. \<K> x = Fun c []"
                      "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv t \<union> fv s. \<forall>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv t \<union> fv s.
                         \<I> x = \<I> y \<longleftrightarrow> \<K> x = \<K> y"
             for t s h tx
           proof -
             let ?upds = "\<lambda>A. filter is_Update (unlabel A)"
 
             have flt2_fv: "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (flt2 \<A>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
               using fv\<^sub>s\<^sub>s\<^sub>t_mono[OF flt2_subset[of \<A>]] by blast
 
             have upds_fv: "fv\<^sub>s\<^sub>s\<^sub>t (?upds \<A>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" by auto
 
             have flt2_upds_fv: "fv\<^sub>s\<^sub>s\<^sub>t (?upds (flt2 \<A>)) \<subseteq> fv\<^sub>s\<^sub>s\<^sub>t (?upds \<A>)"
               using flt2_subset[of \<A>] by auto
 
             have h_neq: "Set h \<noteq> (Set s_val::('fun,'atom,'sets,'lbl) prot_fun)"
               when "h \<noteq> s_val"
               using that by simp
 
             have *: "\<Union>(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` {}) = {}" "{} \<cdot>\<^sub>p\<^sub>s\<^sub>e\<^sub>t \<I> = {}" "{} \<cdot>\<^sub>p\<^sub>s\<^sub>e\<^sub>t \<K> = {}" by blast+
 
             have "?in \<I> (?upds (flt2 \<A>)) \<longleftrightarrow> ?in \<K> (?upds (flt2 \<A>))"
             proof
               let ?X = "fv\<^sub>s\<^sub>s\<^sub>t (?upds (flt2 \<A>)) \<union> fv t \<union> fv s \<union>
                          \<Union>(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` ({}::(('fun,'atom,'sets,'lbl) prot_term \<times>
                                           ('fun,'atom,'sets,'lbl) prot_term) set))"
 
               let ?q0 = "\<lambda>\<delta> \<theta>.
                     \<forall>x \<in> ?X.
                       \<delta> x = \<theta> x \<or>
                       (\<not>(\<delta> x \<sqsubseteq> t) \<and> \<not>(\<delta> x \<sqsubseteq> s) \<and>\<not>(\<theta> x \<sqsubseteq> t) \<and> \<not>(\<theta> x \<sqsubseteq> s) \<and>
                        (\<forall>(u,v) \<in> {}. \<not>(\<delta> x \<sqsubseteq> u) \<and> \<not>(\<delta> x \<sqsubseteq> v) \<and> \<not>(\<theta> x \<sqsubseteq> u) \<and> \<not>(\<theta> x \<sqsubseteq> v)) \<and>
                        (\<forall>u v. insert\<langle>u,v\<rangle> \<in> set (?upds (flt2 \<A>)) \<or>
                               delete\<langle>u,v\<rangle> \<in> set (?upds (flt2 \<A>)) \<longrightarrow>
                                 \<not>(\<delta> x \<sqsubseteq> u) \<and> \<not>(\<delta> x \<sqsubseteq> v) \<and> \<not>(\<theta> x \<sqsubseteq> u) \<and> \<not>(\<theta> x \<sqsubseteq> v)))"
 
               let ?q1 = "\<lambda>\<delta>. \<forall>x \<in> ?X. \<exists>c. \<delta> x = Fun c []"
 
               let ?q2 = "\<lambda>\<delta> \<theta>. \<forall>x \<in> ?X. \<forall>y \<in> ?X. \<delta> x = \<delta> y \<longleftrightarrow> \<theta> x = \<theta> y"
 
               have q0: "?q0 \<I> \<K>" "?q0 \<K> \<I>"
               proof -
                 have upd_ex:
                     "\<exists>u v. x \<in> fv u \<union> fv v \<and>
                            (insert\<langle>u,v\<rangle> \<in> set (?upds A) \<or> delete\<langle>u,v\<rangle> \<in> set (?upds A))"
                   when "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (?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 "\<not>(\<I> x \<sqsubseteq> t)" "\<not>(\<I> x \<sqsubseteq> s)" "\<not>(\<K> x \<sqsubseteq> t)" "\<not>(\<K> x \<sqsubseteq> s)"
                   when x: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (?upds (flt2 \<A>)) \<union> fv t \<union> fv s"
                     and x_neq: "\<I> x \<noteq> \<K> x"
                   for x
                 proof -
                   have "\<not>(\<I> x \<sqsubseteq> t) \<and> \<not>(\<I> x \<sqsubseteq> s) \<and> \<not>(\<K> x \<sqsubseteq> t) \<and> \<not>(\<K> x \<sqsubseteq> s)"
                   proof (cases "x \<in> fv t \<union> fv s")
                     case True thus ?thesis using q(1) x_neq by blast
                   next
                     case False
                     hence "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" using x flt2_upds_fv upds_fv by blast
                     hence "\<exists>n. \<K> x = Fun (Val n) []"
                           "\<exists>n. \<I> x = Fun (Val n) [] \<or> \<I> x = Fun (PubConst Value n) []"
                       using B'3 3(2)
                       unfolding valconst_cases_def valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
                       by (blast, blast)
                     thus ?thesis unfolding t h(1) by auto
                   qed
                   thus "\<not>(\<I> x \<sqsubseteq> t)" "\<not>(\<I> x \<sqsubseteq> s)" "\<not>(\<K> x \<sqsubseteq> t)" "\<not>(\<K> x \<sqsubseteq> s)" by simp_all
                 qed
                 moreover have "\<not>(\<I> x \<sqsubseteq> u)" "\<not>(\<I> x \<sqsubseteq> v)" "\<not>(\<K> x \<sqsubseteq> u)" "\<not>(\<K> x \<sqsubseteq> v)"
                   when x: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (?upds (flt2 \<A>)) \<union> fv t \<union> fv s"
                     and x_neq: "\<I> x \<noteq> \<K> x"
                     and uv: "insert\<langle>u,v\<rangle> \<in> set (?upds (flt2 \<A>)) \<or>
                              delete\<langle>u,v\<rangle> \<in> set (?upds (flt2 \<A>))"
                   for x u v
                 proof -
                   have uv': "insert\<langle>u,v\<rangle> \<in> set (unlabel \<A>) \<or> delete\<langle>u,v\<rangle> \<in> set (unlabel \<A>)"
                     using uv flt2_subset by auto
 
                   have x_in: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<union> fv u \<union> fv v"
                     using t_s_fv x flt2_upds_fv upds_fv by blast
 
                   show "\<not>(\<I> x \<sqsubseteq> u)" "\<not>(\<I> x \<sqsubseteq> v)" "\<not>(\<K> x \<sqsubseteq> u)" "\<not>(\<K> x \<sqsubseteq> v)"
                     using x_neq A_insert_delete_not_subterm[OF x_in x_neq uv'] by simp_all
                 qed
                 ultimately show "?q0 \<I> \<K>" unfolding upd_ex unfolding *
                   by (metis (no_types, lifting) empty_iff sup_bot_right)
                 thus "?q0 \<K> \<I>" by (metis (lifting) empty_iff)
               qed
 
               have q1: "?q1 \<I>" "?q1 \<K>"
                 using q(2,3) flt2_upds_fv upds_fv by (blast,blast)
 
               have q2: "?q2 \<I> \<K>" "?q2 \<K> \<I>"
                 using q(4) flt2_upds_fv upds_fv unfolding * by (blast,blast)
 
               show "?in \<I> (?upds (flt2 \<A>)) \<Longrightarrow> ?in \<K> (?upds (flt2 \<A>))"
                 using dbupd\<^sub>s\<^sub>s\<^sub>t_subst_const_swap[OF _ q0(1) q1(1,2) q2(1)] by force
 
               show "?in \<K> (?upds (flt2 \<A>)) \<Longrightarrow> ?in \<I> (?upds (flt2 \<A>))"
                 using dbupd\<^sub>s\<^sub>s\<^sub>t_subst_const_swap[OF _ q0(2) q1(2,1) q2(2)] by force
             qed
             hence flt2_subst_swap: "?in \<I> (unlabel (flt2 \<A>)) \<longleftrightarrow> ?in \<K> (unlabel (flt2 \<A>))"
               using dbupd\<^sub>s\<^sub>s\<^sub>t_filter by blast
 
             (* TODO: merge with similar proof above? *)
             have "?in \<I> (?upds \<A>) \<longleftrightarrow> ?in \<K> (?upds \<A>)"
             proof
               let ?X = "fv\<^sub>s\<^sub>s\<^sub>t (?upds \<A>) \<union> fv t \<union> fv s \<union>
                          \<Union>(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` ({}::(('fun,'atom,'sets,'lbl) prot_term \<times>
                                           ('fun,'atom,'sets,'lbl) prot_term) set))"
 
               let ?q0 = "\<lambda>\<delta> \<theta>.
                     \<forall>x \<in> ?X.
                       \<delta> x = \<theta> x \<or>
                       (\<not>(\<delta> x \<sqsubseteq> t) \<and> \<not>(\<delta> x \<sqsubseteq> s) \<and>\<not>(\<theta> x \<sqsubseteq> t) \<and> \<not>(\<theta> x \<sqsubseteq> s) \<and>
                        (\<forall>(u,v) \<in> {}. \<not>(\<delta> x \<sqsubseteq> u) \<and> \<not>(\<delta> x \<sqsubseteq> v) \<and> \<not>(\<theta> x \<sqsubseteq> u) \<and> \<not>(\<theta> x \<sqsubseteq> v)) \<and>
                        (\<forall>u v. insert\<langle>u,v\<rangle> \<in> set (?upds \<A>) \<or>
                               delete\<langle>u,v\<rangle> \<in> set (?upds \<A>) \<longrightarrow>
                                 \<not>(\<delta> x \<sqsubseteq> u) \<and> \<not>(\<delta> x \<sqsubseteq> v) \<and> \<not>(\<theta> x \<sqsubseteq> u) \<and> \<not>(\<theta> x \<sqsubseteq> v)))"
 
               let ?q1 = "\<lambda>\<delta>. \<forall>x \<in> ?X. \<exists>c. \<delta> x = Fun c []"
 
               let ?q2 = "\<lambda>\<delta> \<theta>. \<forall>x \<in> ?X. \<forall>y \<in> ?X. \<delta> x = \<delta> y \<longleftrightarrow> \<theta> x = \<theta> y"
 
               have q0: "?q0 \<I> \<K>" "?q0 \<K> \<I>"
               proof -
                 have upd_ex:
                     "\<exists>u v. x \<in> fv u \<union> fv v \<and>
                            (insert\<langle>u,v\<rangle> \<in> set (?upds A) \<or> delete\<langle>u,v\<rangle> \<in> set (?upds A))"
                   when "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (?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 "\<not>(\<I> x \<sqsubseteq> t)" "\<not>(\<I> x \<sqsubseteq> s)" "\<not>(\<K> x \<sqsubseteq> t)" "\<not>(\<K> x \<sqsubseteq> s)"
                   when x: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (?upds \<A>) \<union> fv t \<union> fv s"
                     and x_neq: "\<I> x \<noteq> \<K> x"
                   for x
                 proof -
                   have "\<not>(\<I> x \<sqsubseteq> t) \<and> \<not>(\<I> x \<sqsubseteq> s) \<and> \<not>(\<K> x \<sqsubseteq> t) \<and> \<not>(\<K> x \<sqsubseteq> s)"
                   proof (cases "x \<in> fv t \<union> fv s")
                     case True thus ?thesis using q(1) x_neq by blast
                   next
                     case False
                     hence "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" using x flt2_upds_fv upds_fv by blast
                     hence "\<exists>n. \<K> x = Fun (Val n) []"
                           "\<exists>n. \<I> x = Fun (Val n) [] \<or> \<I> x = Fun (PubConst Value n) []"
                       using B'3 3(2)
                       unfolding valconst_cases_def valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
                       by (blast, blast)
                     thus ?thesis unfolding t h(1) by auto
                   qed
                   thus "\<not>(\<I> x \<sqsubseteq> t)" "\<not>(\<I> x \<sqsubseteq> s)" "\<not>(\<K> x \<sqsubseteq> t)" "\<not>(\<K> x \<sqsubseteq> s)" by simp_all
                 qed
                 moreover have "\<not>(\<I> x \<sqsubseteq> u)" "\<not>(\<I> x \<sqsubseteq> v)" "\<not>(\<K> x \<sqsubseteq> u)" "\<not>(\<K> x \<sqsubseteq> v)"
                   when x: "x \<in> fv\<^sub>s\<^sub>s\<^sub>t (?upds \<A>) \<union> fv t \<union> fv s"
                     and x_neq: "\<I> x \<noteq> \<K> x"
                     and uv: "insert\<langle>u,v\<rangle> \<in> set (?upds \<A>) \<or>
                              delete\<langle>u,v\<rangle> \<in> set (?upds \<A>)"
                   for x u v
                 proof -
                   have uv': "insert\<langle>u,v\<rangle> \<in> set (unlabel \<A>) \<or> delete\<langle>u,v\<rangle> \<in> set (unlabel \<A>)"
                     using uv flt2_subset by auto
 
                   have x_in: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<union> fv u \<union> fv v"
                     using t_s_fv x flt2_upds_fv upds_fv by blast
 
                   show "\<not>(\<I> x \<sqsubseteq> u)" "\<not>(\<I> x \<sqsubseteq> v)" "\<not>(\<K> x \<sqsubseteq> u)" "\<not>(\<K> x \<sqsubseteq> v)"
                     using x_neq A_insert_delete_not_subterm[OF x_in x_neq uv'] by simp_all
                 qed
                 ultimately show "?q0 \<I> \<K>" unfolding upd_ex unfolding *
                   by (metis (no_types, lifting) empty_iff sup_bot_right)
                 thus "?q0 \<K> \<I>" by (metis (lifting) empty_iff)
               qed
 
               have q1: "?q1 \<I>" "?q1 \<K>"
                 using q(2,3) flt2_upds_fv upds_fv by (blast,blast)
 
               have q2: "?q2 \<I> \<K>" "?q2 \<K> \<I>"
                 using q(4) flt2_upds_fv upds_fv unfolding * by (blast,blast)
 
               show "?in \<I> (?upds \<A>) \<Longrightarrow> ?in \<K> (?upds \<A>)"
                 using dbupd\<^sub>s\<^sub>s\<^sub>t_subst_const_swap[OF _ q0(1) q1(1,2) q2(1)] by force
 
               show "?in \<K> (?upds \<A>) \<Longrightarrow> ?in \<I> (?upds \<A>)"
                 using dbupd\<^sub>s\<^sub>s\<^sub>t_subst_const_swap[OF _ q0(2) q1(2,1) q2(2)] by force
             qed
             hence db_subst_swap:
                 "?in \<I> (unlabel \<A>) \<longleftrightarrow> ?in \<K> (unlabel \<A>)"
               using dbupd\<^sub>s\<^sub>s\<^sub>t_filter by blast
 
             have "?in \<K> (unlabel \<B>)" when A: "?in \<I> (unlabel \<A>)" using h(2)
             proof
               assume h': "h \<noteq> s_val"
               have "?in \<I> (unlabel (flt2 \<A>))"
                 using A flt2_unlabel dbupd\<^sub>s\<^sub>s\<^sub>t_set_term_neq_in_iff[OF h_neq[OF h'] A_setops_Fun]
                 unfolding h(1) flt3_def by simp
               hence "?in \<K> (unlabel (flt2 \<A>))" using flt2_subst_swap by blast
               hence "?in \<K> (flt1 (flt2 \<A>))" using dbupd\<^sub>s\<^sub>s\<^sub>t_filter unfolding flt1_def by blast
               hence "?in \<K> (flt1 (flt2 \<B>))" using flt_AB by simp
               hence "?in \<K> (unlabel (flt2 \<B>))" using dbupd\<^sub>s\<^sub>s\<^sub>t_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 \<A>) = filter is_Update (unlabel \<B>)"
               have "?in \<K> (unlabel \<A>)" using A db_subst_swap by blast
               hence "?in \<K> (flt1 \<A>)" using dbupd\<^sub>s\<^sub>s\<^sub>t_filter unfolding flt1_def by blast
               hence "?in \<K> (flt1 \<B>)" using h' unfolding flt1_def by simp
               thus ?thesis using dbupd\<^sub>s\<^sub>s\<^sub>t_filter unfolding flt1_def by blast
             qed
             moreover have "\<not>?in \<K> (unlabel \<B>)" when A: "\<not>?in \<I> (unlabel \<A>)" using h(2)
             proof
               assume h': "h \<noteq> s_val"
               have "\<not>?in \<I> (unlabel (flt2 \<A>))"
                 using A flt2_unlabel dbupd\<^sub>s\<^sub>s\<^sub>t_set_term_neq_in_iff[OF h_neq[OF h'] A_setops_Fun]
                 unfolding h(1) flt3_def by simp
               hence "\<not>?in \<K> (unlabel (flt2 \<A>))" using flt2_subst_swap by blast
               hence "\<not>?in \<K> (flt1 (flt2 \<A>))" using dbupd\<^sub>s\<^sub>s\<^sub>t_filter unfolding flt1_def by blast
               hence "\<not>?in \<K> (flt1 (flt2 \<B>))" using flt_AB by simp
               hence "\<not>?in \<K> (unlabel (flt2 \<B>))" using dbupd\<^sub>s\<^sub>s\<^sub>t_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 \<A>) = filter is_Update (unlabel \<B>)"
               have "\<not>?in \<K> (unlabel \<A>)" using A db_subst_swap by blast
               hence "\<not>?in \<K> (flt1 \<A>)" using dbupd\<^sub>s\<^sub>s\<^sub>t_filter unfolding flt1_def by blast
               hence "\<not>?in \<K> (flt1 \<B>)" using h' unfolding flt1_def by simp
               thus ?thesis using dbupd\<^sub>s\<^sub>s\<^sub>t_filter unfolding flt1_def by blast
             qed
             ultimately show ?thesis by blast
           qed
 
           have "?M2 \<turnstile> t \<cdot> \<theta> \<cdot> \<K>"
             when ts: "(l, receive\<langle>ts\<rangle>) \<in> set (transaction_receive T)" "t \<in> set ts" for l t ts
           proof -
             have *: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<theta> \<cdot> \<I>" using 5 ts by blast
 
             note t\<theta>\<alpha> = rcv_\<theta>_is_\<alpha>[OF ts]
 
             have t_T'_trm: "t \<in> trms_transaction T"
               using trms\<^sub>s\<^sub>s\<^sub>t_memI(2)[OF unlabel_in[OF ts(1)] ts(2)]
               unfolding trms_transaction_unfold by blast
 
             have t_T'_trm': "t \<cdot> \<theta> \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
               using trms\<^sub>s\<^sub>s\<^sub>t_memI(2)[
                       OF stateful_strand_step_subst_inI(2)[
                           OF unlabel_in[OF ts(1)], unfolded unlabel_subst]]
                     ts(2)
               unfolding T'_def trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq trms_transaction_subst_unfold by auto
 
             note t_no_val = T'_trm_no_val[OF t_T'_trm, unfolded t\<theta>\<alpha>[symmetric]]
 
             have t_fv_T': "fv (t \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t 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 \<theta>]]
               unfolding T'_def unlabel_subst fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq fv_transaction_subst_unfold
               by auto
 
             have ik_B_fv_subset: "fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
               by (meson UnE fv_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t subset_iff)
 
             let ?fresh_vals = "(\<lambda>n. Fun (Val n) []) ` T_val_fresh_vals"
 
             have q0: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<theta> \<cdot> \<I>" using * B(10) by (blast intro: ideduct_mono)
 
             have q1: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>). valconst_cases \<I> x"
               using 3(2,3) t_fv_T' ik_B_fv_subset unfolding B(9) by blast
 
             have q2: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>). \<exists>n. \<K> x = Fun (Val n) []"
               using B'3 t_fv_T' ik_B_fv_subset
               unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append B(9)
               by blast
 
             have T_val_constr_ik:
               "\<exists>M. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr = M \<union> ?fresh_vals"
               "\<exists>M. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K> = (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K>) \<union> ?fresh_vals"
             proof -
               obtain M where M: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr = M \<union> ?fresh_vals"
                 using T_val_constr(8) by blast
               have "?fresh_vals \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K> = ?fresh_vals" by fastforce
               thus "\<exists>M. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr = M \<union> ?fresh_vals"
                    "\<exists>M. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K> = (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<K>) \<union> ?fresh_vals"
                 using M by (fastforce, fastforce)
             qed
 
             have "\<K> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T_val_constr"
               when x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>)" "\<I> 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 fv\<^sub>s\<^sub>s\<^sub>t_append by blast
             hence q3: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>).
                         (\<exists>n. \<I> x = Fun (PubConst Value n) []) \<longrightarrow> \<K> x \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<union> ?fresh_vals"
               using T_val_constr_ik(1) T_val_constr(8) q2
               unfolding B(9) \<B>'_def unlabel_append ik\<^sub>s\<^sub>s\<^sub>t_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by (metis (no_types, lifting) UnE UnI1 UnI2 image_iff mem_Collect_eq)
 
             have q4: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>). (\<exists>n. \<I> x = Fun (Val n) []) \<longrightarrow> \<I> x = \<K> x"
               using B'5 t_fv_T' ik_B_fv_subset
               unfolding subst_eq_on_privvals_def B(9) unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by blast
 
             have q5: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>). \<forall>y \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>) \<union> fv (t \<cdot> \<theta>).
                         \<I> x = \<I> y \<longleftrightarrow> \<K> x = \<K> y"
               using B'7 t_fv_T' ik_B_fv_subset
               unfolding subst_eq_iff_def B(9) unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by blast
 
             have q6: "\<forall>n. \<not>(Fun (PubConst Value n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t insert (t \<cdot> \<theta>) (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>))"
             proof -
               have "\<nexists>n. s = Fun (PubConst Value n) []" when s: "s \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'" for s
               proof -
                 have "f \<noteq> PubConst Value n" when f: "f \<in> 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 "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>'"
                 using ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset unfolding \<B>'_def unlabel_append trms\<^sub>s\<^sub>s\<^sub>t_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 \<cdot> \<theta> \<cdot> \<K> = s \<cdot> \<theta> \<cdot> \<K>"
             when ts: "(l, \<langle>ac: t \<doteq> s\<rangle>) \<in> set (transaction_checks T)" for l ac t s
           proof -
             have q0: "t \<cdot> \<theta> \<cdot> \<I> = s \<cdot> \<theta> \<cdot> \<I>" using 5 ts by blast
 
             have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\<langle>ac: (t \<cdot> \<theta>) \<doteq> (s \<cdot> \<theta>)\<rangle>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
               using stateful_strand_step_fv_subset_cases(3)[
                       OF stateful_strand_step_subst_inI(3)[OF unlabel_in[OF ts], of \<theta>]]
               unfolding unlabel_subst by simp
             hence t_s_fv: "fv (t \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "fv (s \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
               unfolding T'_def fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq fv_transaction_subst_unfold[of T \<theta>]
               by (fastforce, fastforce)
 
             have "t \<in> trms_transaction T" "s \<in> trms_transaction T"
               using trms\<^sub>s\<^sub>s\<^sub>t_memI(3,4)[OF unlabel_in[OF ts]]
               unfolding trms_transaction_unfold by (blast, blast)
             hence "\<nexists>n. u = Fun (Val n) [] \<or> u = Fun (PubConst Value n) []"
               when u: "u \<sqsubseteq> t \<cdot> \<theta> \<or> u \<sqsubseteq> s \<cdot> \<theta>" for u
               using u T'_trm_no_val unfolding eq_\<theta>_is_\<alpha>[OF ts] by blast
             hence "\<not>(\<I> x \<sqsubseteq> t \<cdot> \<theta>)" "\<not>(\<I> x \<sqsubseteq> s \<cdot> \<theta>)"
               when x: "x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>)" for x
               using x t_s_fv I' by (fast, fast)
             hence q1:
                 "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<I> x = \<K> x \<or> (\<not>(\<I> x \<sqsubseteq> t \<cdot> \<theta>) \<and> \<not>(\<I> x \<sqsubseteq> s \<cdot> \<theta>))"
               by blast
 
             have q2: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<I> x = Fun c []"
               using t_s_fv 3(3) unfolding valconst_cases_def by blast
 
             have q3: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<K> x = Fun c []"
               using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             have q4: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<forall>y \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                         \<I> x = \<I> y \<longleftrightarrow> \<K> x = \<K> y"
               using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             show ?thesis by (rule subst_const_swap_eq'[OF q0 q1 q2 q3 q4])
           qed
           moreover have "t \<cdot> \<theta> \<cdot> \<K> \<noteq> s \<cdot> \<theta> \<cdot> \<K>"
             when ts: "(l, \<langle>t != s\<rangle>) \<in> set (transaction_checks T)" for l t s
           proof -
             have q0: "t \<cdot> \<theta> \<cdot> \<I> \<noteq> s \<cdot> \<theta> \<cdot> \<I>" using 5 ts by blast
 
             have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\<langle>(t \<cdot> \<theta>) != (s \<cdot> \<theta>)\<rangle>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
               using stateful_strand_step_fv_subset_cases(8)[
                       OF stateful_strand_step_subst_inI(8)[OF unlabel_in[OF ts], of \<theta>]]
               unfolding unlabel_subst by simp
             hence t_s_fv: "fv (t \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "fv (s \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
               unfolding T'_def fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq fv_transaction_subst_unfold[of T \<theta>]
               by (fastforce, fastforce)
 
             have "t \<in> trms_transaction T" "s \<in> trms_transaction T"
               using trms\<^sub>s\<^sub>s\<^sub>t_memI(9)[OF unlabel_in[OF ts]]
               unfolding trms_transaction_unfold by auto
             hence "\<nexists>n. u = Fun (Val n) []" when u: "u \<sqsubseteq> t \<cdot> \<theta> \<or> u \<sqsubseteq> s \<cdot> \<theta>" for u
               using u T'_trm_no_val unfolding noteq_\<theta>_is_\<alpha>[OF ts] by blast
             hence "\<not>(\<K> x \<sqsubseteq> t \<cdot> \<theta>)" "\<not>(\<K> x \<sqsubseteq> s \<cdot> \<theta>)"
               when x: "x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>)" for x
               using x t_s_fv B'3
               unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by (fast, fast)
             hence q1: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<K> x = \<I> x \<or> (\<not>(\<K> x \<sqsubseteq> t \<cdot> \<theta>) \<and> \<not>(\<K> x \<sqsubseteq> s \<cdot> \<theta>))"
               by blast
 
             have q2: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<K> x = Fun c []"
               using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             have q3: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<I> x = Fun c []"
               using t_s_fv 3(3) unfolding valconst_cases_def by blast
 
             have q4: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<forall>y \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                         \<K> x = \<K> y \<longleftrightarrow> \<I> x = \<I> y"
               using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             show ?thesis using q0 subst_const_swap_eq'[OF _ q1 q2 q3 q4] by fast
           qed
           moreover have "(t \<cdot> \<theta> \<cdot> \<K>, s \<cdot> \<theta> \<cdot> \<K>) \<in> ?D2"
             when ts: "(l, \<langle>ac: t \<in> s\<rangle>) \<in> set (transaction_checks T)" for l ac t s
           proof -
             have s_neq_s_val:
                 "s \<noteq> \<langle>s_val\<rangle>\<^sub>s \<or> filter is_Update (unlabel \<A>) = filter is_Update (unlabel \<B>)"
             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': "\<langle>ac: t \<in> s\<rangle> \<in> set (unlabel (transaction_strand T))"
               using ts unlabel_in[OF ts] unfolding transaction_strand_def by fastforce
 
             have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\<langle>ac: (t \<cdot> \<theta>) \<in> (s \<cdot> \<theta>)\<rangle>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
               using stateful_strand_step_fv_subset_cases(6)[
                       OF stateful_strand_step_subst_inI(6)[OF unlabel_in[OF ts], of \<theta>]]
               unfolding unlabel_subst by simp
             hence t_s_fv: "fv (t \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "fv (s \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
               unfolding T'_def fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq fv_transaction_subst_unfold[of T \<theta>]
               by (fastforce, fastforce)
 
             have "t \<in> trms_transaction T" "s \<in> trms_transaction T"
               using ts' unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by (force, force)
             hence "\<nexists>n. u = Fun (Val n) [] \<or> u = Fun (PubConst Value n) []"
               when u: "u \<sqsubseteq> t \<cdot> \<theta> \<or> u \<sqsubseteq> s \<cdot> \<theta>" for u
               using u T'_trm_no_val unfolding in_\<theta>_is_\<alpha>[OF ts] by blast
             hence "\<not>(\<K> x \<sqsubseteq> t \<cdot> \<theta>)" "\<not>(\<K> x \<sqsubseteq> s \<cdot> \<theta>)" "\<not>(\<I> x \<sqsubseteq> t \<cdot> \<theta>)" "\<not>(\<I> x \<sqsubseteq> s \<cdot> \<theta>)"
               when x: "x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>)" for x
               using x t_s_fv B'3 I'
               unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by (fast,fast,fast,fast)
             hence q1: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                         \<I> x = \<K> x \<or>
                         (\<not>(\<I> x \<sqsubseteq> t \<cdot> \<theta>) \<and> \<not>(\<I> x \<sqsubseteq> s \<cdot> \<theta>) \<and> \<not>(\<K> x \<sqsubseteq> t \<cdot> \<theta>) \<and> \<not>(\<K> x \<sqsubseteq> s \<cdot> \<theta>))"
               by blast
 
             have q2: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<I> x = Fun c []"
               using t_s_fv 3(2,3) unfolding valconst_cases_def by blast
 
             have q3: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<K> x = Fun c []"
               using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             have q4: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                       \<forall>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                         \<I> x = \<I> y \<longleftrightarrow> \<K> x = \<K> y"
               using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             obtain h tx where s: "s = \<langle>h\<rangle>\<^sub>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 \<cdot> \<theta> = \<langle>h\<rangle>\<^sub>s"
                 "h \<noteq> s_val \<or> filter is_Update (unlabel \<A>) = filter is_Update (unlabel \<B>)"
               using s s_neq_s_val by (simp,blast)
 
             obtain ty where ty: "t \<cdot> \<theta> = Var ty"
               using tx transaction_renaming_subst_is_renaming(2)[OF step.hyps(5), of tx]
               unfolding in_\<theta>_is_\<alpha>[OF ts] by force
 
             have "(t \<cdot> \<theta> \<cdot> \<I>, s \<cdot> \<theta> \<cdot> \<I>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}" using 5 ts by blast
             hence "(t \<cdot> \<theta> \<cdot> \<K>, s \<cdot> \<theta> \<cdot> \<K>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<B>) \<K> {}"
               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 \<cdot> \<theta> \<cdot> \<K>, s \<cdot> \<theta> \<cdot> \<K>) \<notin> ?D2"
             when ts: "(l, \<langle>t not in s\<rangle>) \<in> set (transaction_checks T)" for l t s
           proof -
             have s_neq_s_val:
                 "(T_upds \<noteq> [] \<and> s \<noteq> \<langle>s_val\<rangle>\<^sub>s) \<or>
                  (T_upds = [] \<and> filter is_Update (unlabel \<A>) = filter is_Update (unlabel \<B>))"
             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': "\<langle>t not in s\<rangle> \<in> set (unlabel (transaction_strand T))"
               using ts unlabel_in[OF ts] unfolding transaction_strand_def by fastforce
 
             have "fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p (\<langle>(t \<cdot> \<theta>) not in (s \<cdot> \<theta>)\<rangle>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
               using stateful_strand_step_fv_subset_cases(9)[
                       OF stateful_strand_step_subst_inI(9)[OF unlabel_in[OF ts], of \<theta>]]
               unfolding unlabel_subst by simp
             hence t_s_fv: "fv (t \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'" "fv (s \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
               unfolding T'_def fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq fv_transaction_subst_unfold[of T \<theta>]
               by (fastforce, fastforce)
 
             have "t \<in> trms_transaction T" "s \<in> trms_transaction T"
               using ts' unfolding trms\<^sub>s\<^sub>s\<^sub>t_def by (force, force)
             hence "\<nexists>n. u = Fun (Val n) [] \<or> u = Fun (PubConst Value n) []"
               when u: "u \<sqsubseteq> t \<cdot> \<theta> \<or> u \<sqsubseteq> s \<cdot> \<theta>" for u
               using u T'_trm_no_val unfolding notin_\<theta>_is_\<alpha>[OF ts] by blast
             hence "\<not>(\<K> x \<sqsubseteq> t \<cdot> \<theta>)" "\<not>(\<K> x \<sqsubseteq> s \<cdot> \<theta>)" "\<not>(\<I> x \<sqsubseteq> t \<cdot> \<theta>)" "\<not>(\<I> x \<sqsubseteq> s \<cdot> \<theta>)"
               when x: "x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>)" for x
               using x t_s_fv B'3 I'
               unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append
               by (fast,fast,fast,fast)
             hence q1: "\<forall>x \<in> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                         \<I> x = \<K> x \<or>
                         (\<not>(\<I> x \<sqsubseteq> t \<cdot> \<theta>) \<and> \<not>(\<I> x \<sqsubseteq> s \<cdot> \<theta>) \<and> \<not>(\<K> x \<sqsubseteq> t \<cdot> \<theta>) \<and> \<not>(\<K> x \<sqsubseteq> s \<cdot> \<theta>))"
               by blast
 
             have q2: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<I> x = Fun c []"
               using t_s_fv 3(2,3) unfolding valconst_cases_def by blast
 
             have q3: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>). \<exists>c. \<K> x = Fun c []"
               using t_s_fv B'3 unfolding valconsts_only_def unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             have q4: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                       \<forall>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<union> fv (t \<cdot> \<theta>) \<union> fv (s \<cdot> \<theta>).
                         \<I> x = \<I> y \<longleftrightarrow> \<K> x = \<K> y"
               using B'7 t_s_fv unfolding subst_eq_iff_def B(9) unlabel_append fv\<^sub>s\<^sub>s\<^sub>t_append by blast
 
             obtain h tx where s: "s = \<langle>h\<rangle>\<^sub>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 \<cdot> \<theta> = \<langle>h\<rangle>\<^sub>s"
                 "h \<noteq> s_val \<or> filter is_Update (unlabel \<A>) = filter is_Update (unlabel \<B>)"
                 "T_upds \<noteq> [] \<Longrightarrow> h \<noteq> s_val"
               using s s_neq_s_val by (simp,blast,blast)
 
             obtain ty where ty: "t \<cdot> \<theta> = Var ty"
               using tx transaction_renaming_subst_is_renaming(2)[OF step.hyps(5), of tx]
               unfolding notin_\<theta>_is_\<alpha>[OF ts] by force
 
             have *: "(t \<cdot> \<theta> \<cdot> \<K>, s \<cdot> \<theta> \<cdot> \<K>) \<noteq> (u \<cdot> \<K>, v \<cdot> \<K>)"
               when u: "insert\<langle>u,v\<rangle> \<in> set (unlabel T_val_constr)"
                 and h': "h \<noteq> s_val"
               for u v
             proof -
               have "v = \<langle>s_val\<rangle>\<^sub>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 \<cdot> \<theta> \<cdot> \<I>, s \<cdot> \<theta> \<cdot> \<I>) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}" using 5 ts by blast
             hence **: "(t \<cdot> \<theta> \<cdot> \<K>, s \<cdot> \<theta> \<cdot> \<K>) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<B>) \<K> {}"
               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 "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel T_val_constr) I D = D" for I D
                 using T_val_constr_no_upds_if_no_T_upds[OF True]
                       dbupd\<^sub>s\<^sub>s\<^sub>t_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 \<theta>_def[symmetric] T'_def[symmetric] by blast
   qed
 
   obtain \<B> \<J> where B:
       "\<B> \<in> reachable_constraints P" "?wt_model \<J> \<B>"
       "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<exists>n. \<J> x = Fun (Val n) []" "?rcv_att \<A> n \<longrightarrow> ?rcv_att \<B> n" "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
     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: "\<forall>T \<in> set P. admissible_transaction T"
     and A: "\<A> \<in> reachable_constraints P"
   shows "\<exists>\<B> \<in> reachable_constraints (map add_occurs_msgs P). \<A> = rm_occurs_msgs_constr \<B>"
 using A
 proof (induction rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   let ?A' = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
   let ?B' = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (add_occurs_msgs T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
   obtain A B C D E F where T: "T = Transaction A B C D E F" by (cases T) simp
 
   have P': "\<forall>T \<in> set P. admissible_transaction' T"
              "\<forall>T \<in> 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 \<xi>_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 \<B> where B:
       "\<B> \<in> reachable_constraints (map add_occurs_msgs P)" "\<A> = rm_occurs_msgs_constr \<B>"
     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 \<in> set (map add_occurs_msgs P)"
     using step.hyps(2) by simp
 
   have 5: "transaction_decl_subst \<xi> (add_occurs_msgs T)"
     using step.hyps(3) 0(4) unfolding transaction_decl_subst_def by argo
 
   have "t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
        "t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction (add_occurs_msgs T))"
     when t: "t \<in> subst_range \<sigma>" 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 \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" "t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction T)"
       using t step.hyps(4) unfolding transaction_fresh_subst_def by (fast,fast)
 
     have "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<or> (\<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. t \<sqsubseteq> occurs (Var x)) \<or>
            (\<exists>c. Fun c [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<and> t \<sqsubseteq> occurs (Fun c []))"
       when t: "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>"
       using t rm_occurs_msgs_constr_reachable_constraints_trms_cases[OF P' B(2,1)] by fast
     thus "t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
       using *(1) unfolding c by fastforce
 
     show "t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms_transaction (add_occurs_msgs T))"
       using *(2) unfolding 2 c by force
   qed
   hence 6: "transaction_fresh_subst \<sigma> (add_occurs_msgs T) (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
     using step.hyps(4) unfolding transaction_fresh_subst_def 0(5) 2 by fast
 
   have 7: "transaction_renaming_subst \<alpha> (map add_occurs_msgs P) (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>)"
     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 \<theta>_def[symmetric] by metis
   hence 8: "\<A>@?A' = rm_occurs_msgs_constr (\<B>@?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 \<theta>_def by blast
 qed (metis reachable_constraints.init rm_occurs_msgs_constr.simps(1))
 
 private lemma add_occurs_msgs_soundness_aux3:
   assumes P: "\<forall>T \<in> set P. admissible_transaction T"
     and A: "\<A> \<in> reachable_constraints (map add_occurs_msgs P)"
            "welltyped_constraint_model \<I> (rm_occurs_msgs_constr \<A>)"
     and I: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<exists>n. \<I> x = Fun (Val n) []" (is "?I \<A>")
   shows "welltyped_constraint_model \<I> \<A>" (is "?Q \<I> \<A>")
 using A I
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   let ?f = rm_occurs_msgs_constr
   let ?sem = "\<lambda>B. strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}) (unlabel B) \<I>"
 
   define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   define \<B> where "\<B> \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
   obtain T' where T': "T' \<in> 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': "\<forall>T \<in> set (map add_occurs_msgs P). admissible_transaction' T"
            "\<forall>T \<in> set (map add_occurs_msgs P). admissible_transaction_occurs_checks T"
            "\<forall>T \<in> set P. admissible_transaction' T"
            "\<forall>T \<in> 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 \<xi>_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 \<I> (?f \<A>)" "?I \<A>" "?I \<B>"
     by (metis step.prems(1) welltyped_constraint_model_prefix rm_occurs_msgs_constr_append,
         simp_all add: step.prems(2) \<theta>_def \<B>_def)
 
   note IH = step.IH[OF 0(1,2)]
 
   have I': "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
     using step.prems(1) unfolding welltyped_constraint_model_def constraint_model_def by blast+
 
   have 1: "\<forall>x \<in> fv_transaction T. \<nexists>t. \<theta> x = occurs t"
           "\<forall>x \<in> fv_transaction T. \<theta> x \<noteq> Fun OccursSec []"
     using admissible_transaction_decl_fresh_renaming_subst_not_occurs[OF T_adm step.hyps(3,4,5)]
     unfolding \<theta>_def[symmetric] by simp_all
 
   have "(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?f \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     using rm_occurs_msgs_constr_ik_subset by fast
   hence 2: "?sem (?f \<B>)"
     using step.prems(1) strand_sem_append_stateful[of "{}" "{}" "unlabel (?f \<A>)" "unlabel (?f \<B>)"]
           rm_occurs_msgs_constr_dbupd\<^sub>s\<^sub>s\<^sub>t_eq[of \<A> \<I> "{}"] rm_occurs_msgs_constr_append[of \<A> \<B>]
           strand_sem_ik_mono_stateful[of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?f \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" _ _ _ "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"]
     unfolding welltyped_constraint_model_def constraint_model_def \<theta>_def[symmetric] \<B>_def[symmetric]
     by auto
 
   note 3 = rm_occurs_msgs_constr_transaction_strand''[
             OF T'_adm T'_no_occ 1[unfolded T'(2)], unfolded \<B>_def[symmetric] T'(2)[symmetric]]
 
   note 4 = add_occurs_msgs_cases[OF T'', unfolded T'(2)[symmetric]]
 
 
   define xs where "xs \<equiv> fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T'))"
   define flt where "flt \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T'))"
   define occs where "occs \<equiv> map (\<lambda>x. occurs (Var x)::('fun,'atom,'sets,'lbl) prot_term)"
 
   note 6 = add_occurs_msgs_transaction_strand_cases(7,8,9)[
             of T' \<theta>, unfolded xs_def[symmetric] flt_def[symmetric] occs_def[symmetric]
                               T'(2)[symmetric]]
 
   have 7: "x \<in> fv_transaction T - set (transaction_fresh T)"
     when x: "x \<in> set (flt xs)" for x
     using that fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t add_occurs_msgs_vars_eq(3,9)[OF T'_adm]
     unfolding xs_def flt_def T'(2) by force
 
   have 9: "\<exists>y. \<theta> x = Var y"
     when x: "x \<in> set (flt xs)" for x
   proof -
     have *: "x \<notin> fst ` set (transaction_decl T ())"
       using admissible_transactionE(1)[OF T_adm] by simp
 
     have **: "x \<notin> 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 \<theta>_def by blast
   qed
 
   have 8: "\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>. \<theta> x = Var y"
     when x: "x \<in> set (flt xs)" for x
   proof -
     note * = 7[OF x]
 
     obtain y where y: "\<theta> x = Var y" using 9[OF x] by blast
 
     have "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))" by (metis * Diff_iff fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq)
     have "\<theta> x \<in> \<theta> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)" using * by fast
     hence "fv (\<theta> x) \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t (\<theta> ` fv_transaction T)" by force
     hence "fv (\<theta> x) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
       using fv\<^sub>s\<^sub>s\<^sub>t_subst_if_no_bvars[OF admissible_transactionE(4)[OF T_adm], of \<theta>]
       by (metis unlabel_subst)
     hence "fv (\<theta> x) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" by (metis fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq \<B>_def)
     thus ?thesis using y by simp
   qed
 
   have \<B>_var_is_\<I>_val: "\<exists>n. \<I> x = Fun (Val n) []" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B>" for x
     using step.prems(2) x unfolding \<B>_def[symmetric] \<theta>_def[symmetric] by auto
 
   have T'_var_is_\<theta>\<I>_val: "\<exists>n. \<theta> x \<cdot> \<I> = Fun (Val n) []" when x: "x \<in> set (flt xs)" for x
     using 8[OF x] \<B>_var_is_\<I>_val by force
 
 
   (* TODO: extract lemma *)
   have poschecks_has_occ: "occurs (Fun (Val n) []) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
     when x: "\<langle>ac: t \<in> s\<rangle> \<in> set (unlabel \<B>)"
       and n: "t \<cdot> \<I> = Fun (Val n) []"
     for ac t s n
   proof -
     have *: "(t \<cdot> \<I>, s \<cdot> \<I>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}"
     proof -
       obtain t' s' where t':
           "\<langle>ac: t' \<in> s'\<rangle> \<in> set (unlabel (transaction_checks T'))" "t = t' \<cdot> \<theta>" "s = s' \<cdot> \<theta>"
         using 4(8) x stateful_strand_step_mem_substD(6)
               wellformed_transaction_strand_unlabel_memberD(10)[OF T_wf(1)]
               dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(6)
         unfolding \<B>_def by (metis (no_types) unlabel_subst dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst)
 
       have "(t' \<cdot> \<theta> \<cdot> \<I>, s' \<cdot> \<theta> \<cdot> \<I>) \<in> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}"
         using t'(1) 2
               wellformed_transaction_unlabel_sem_iff[
                 OF T'_wf(1) I'(2,3), of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}" \<theta>]
         unfolding 3 by blast
       thus ?thesis using t'(2,3) by simp
     qed
 
     have "t' \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
       when "insert\<langle>t',s'\<rangle> \<in> set (unlabel \<A>)" for t' s'
       using that by force
 
     have "t \<cdot> \<I> \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
     proof -
       obtain t' s' where t': "insert\<langle>t',s'\<rangle> \<in> set (unlabel \<A>)" "t \<cdot> \<I> = t' \<cdot> \<I>" "s \<cdot> \<I> = s' \<cdot> \<I>"
         using * db\<^sub>s\<^sub>s\<^sub>t_in_cases[of "t \<cdot> \<I>" "s \<cdot> \<I>" "unlabel \<A>" \<I> "[]"]
               db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>" \<I> "[]"]
         by auto
 
       have t'': "t' = t \<cdot> \<I> \<or> (\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. t' = Var y \<and> \<I> y = t \<cdot> \<I>)"
         using t'(1,2) stateful_strand_step_fv_subset_cases(4)
         unfolding n by (cases t') (force,force)
       thus ?thesis
       proof
         assume "t' = t \<cdot> \<I>" thus ?thesis using t'(1) by force
       next
         assume "\<exists>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. t' = Var y \<and> \<I> y = t \<cdot> \<I>"
         then obtain y where y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "\<I> y = t \<cdot> \<I>" by blast
 
         have "\<Gamma>\<^sub>v y = TAtom Value"
           using y(2) wt_subst_trm''[OF I'(1), of "Var y"] unfolding n by simp
         hence "\<exists>B. prefix B \<A> \<and> t \<cdot> \<I> \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t 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) []) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
     when ts: "send\<langle>ts\<rangle> \<in> set (unlabel \<B>)"
       and n: "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     for ts n
   proof -
     have "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using ts dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2) unfolding \<B>_def by metis
     then obtain ts' where ts':
         "receive\<langle>ts'\<rangle> \<in> set (unlabel (transaction_strand T))" "ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"
       by (metis subst_lsst_memD(1) unlabel_in unlabel_mem_has_label)
 
 
     have "?sem (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       using 2 strand_sem_append_stateful[of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}"]
       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 (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
       by (metis subst_lsst_unlabel subst_sst_list_all(2) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(1))
     hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) = {}"
       using in_ik\<^sub>s\<^sub>s\<^sub>t_iff unfolding list_all_iff is_Send_def by fast
     ultimately have *: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot>  \<I>"
       when "send\<langle>ts\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))" "t \<in> set ts"
       for t ts
       using strand_sem_stateful_sends_deduct[OF _ that] by simp
     hence *: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<theta> \<cdot> \<I>"
       when ts: "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T'))" "t \<in> set ts" for t ts
       using ts(2) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(2)[of "ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" "transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
             stateful_strand_step_subst_inI(2)[OF ts(1), of \<theta>, unfolded unlabel_subst]
       by auto
 
     have **: "set (flt xs) = fv_transaction T' - set (transaction_fresh T')"
       using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t unfolding flt_def xs_def by fastforce
 
     have rcv_case: ?thesis
       when "ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" "Fun (Val n) [] \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
            "receive\<langle>ts'\<rangle> \<in> 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\<langle>ts'\<rangle> \<in> set (unlabel (transaction_receive T))"
       using wellformed_transaction_strand_unlabel_memberD(1)[OF T_wf] ts'(1) by blast
     hence "(ts' = map (\<lambda>x. occurs (Var x)) (flt xs) \<and> ts' \<noteq> []) \<or>
            receive\<langle>ts'\<rangle> \<in> set (unlabel (transaction_receive T'))"
       (is "?A \<or> ?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 \<in> set (flt xs)" "Fun (Val n) [] \<sqsubseteq> \<theta> x \<cdot> \<I>"
         using ts' n by fastforce
       
       have x': "\<theta> x \<cdot> \<I> = Fun (Val n) []" "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
                "x \<in> fv_transaction T'" "x \<notin> set (transaction_fresh T')"
         using x(2) T'_var_is_\<theta>\<I>_val[OF x(1)] 7[OF x(1)] ** x(1) by fastforce+
 
       let ?snds = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       let ?chks = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
 
       have B_subsets: "set ?chks \<subseteq> set (unlabel \<B>)"
         unfolding \<B>_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 \<theta>]
       show ?thesis
       proof
         assume "\<exists>ts. send\<langle>ts\<rangle> \<in> set ?snds \<and> \<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts"
         then obtain ss where ss: "send\<langle>ss\<rangle> \<in> set ?snds" "\<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ss" by blast
         
         obtain ss' where ss':
             "ss = ss' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" "receive\<langle>ss'\<rangle> \<in> set (unlabel (transaction_receive T'))"
           by (metis ss(1) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_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 \<I>] 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 (\<theta> x \<cdot> \<I>) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" when x: "x \<in> set (flt xs)" for x
   proof -
     have "(\<exists>ac s. \<langle>ac: \<theta> x \<in> s\<rangle> \<in> set (unlabel \<B>)) \<or>
            (\<exists>ts. send\<langle>ts\<rangle> \<in> set (unlabel \<B>) \<and> \<theta> x \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts)"
       (is "(\<exists>ac s. ?A ac s) \<or> (\<exists>ts. ?B1 ts \<and> ?B2 ts)")
       using 7[OF x] admissible_transaction_fv_in_receives_or_selects_dual_subst[OF T_adm, of x \<theta>]
       unfolding \<B>_def transaction_dual_subst_unlabel_unfold by auto
     thus ?thesis
     proof
       assume "\<exists>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_\<theta>\<I>_val[OF x] by force
     next
       assume "\<exists>ts. ?B1 ts \<and> ?B2 ts"
       then obtain ts where ts: "?B1 ts" "?B2 ts" by meson
       have ts': "\<theta> x \<cdot> \<I> \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" by (metis ts(2) subst_subterms)
       show ?thesis using snds_has_occ[OF ts(1)] ts' T'_var_is_\<theta>\<I>_val[OF x] by force
     qed
   qed
   hence "occurs (\<theta> x \<cdot> \<I>) \<cdot> \<I> \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" when "x \<in> set (flt xs)" for x using that by fast
   moreover have "occurs (\<theta> x \<cdot> \<I>) \<cdot> \<I> = occurs (\<theta> x \<cdot> \<I>)" for x
     using subst_ground_ident[OF interpretation_grounds[OF I'(2), of "\<theta> x"], of \<I>] by simp
   ultimately have "occurs (\<theta> x \<cdot> \<I>) \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" when "x \<in> set (flt xs)" for x
     using that by auto
   hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<I>" when "t \<in> set (occs (flt xs) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)" for t
     using that unfolding occs_def by auto
   hence occs_sem: "?sem [\<langle>\<star>, send\<langle>occs (flt xs) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>]"
     by auto
 
 
   (* TODO: extract lemma *)
   have "?sem \<B>"
   proof -
     let ?IK = "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     let ?DB = "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>) \<I> {}"
     let ?snds = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     let ?snds_occs = "(\<langle>\<star>, send\<langle>occs (flt xs) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>)#?snds"
     let ?chks = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     let ?upds = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     let ?rcvs = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 
     note * = strand_sem_append_stateful[of _ _ _ _ \<I>]
     note ** = transaction_dual_subst_unlabel_unfold
     have ***: "\<And>M. M \<union> (ik\<^sub>s\<^sub>s\<^sub>t [] \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) = M"
               "\<And>D. dbupd\<^sub>s\<^sub>s\<^sub>t [] \<I> 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 dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(1)
       by (metis, metis (no_types) list.pred_inject(2) stateful_strand_step.disc(1) unlabel_Cons(1))
     hence "\<forall>a \<in> set (unlabel ?snds). \<not>is_Receive a \<and> \<not>is_Insert a \<and> \<not>is_Delete a"
           "\<forall>a \<in> set (unlabel ?snds_occs). \<not>is_Receive a \<and> \<not>is_Insert a \<and> \<not>is_Delete a"
       unfolding list_all_iff by (blast,blast)
     hence snds_no_upds:
         "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?snds \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> = {}"
         "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel ?snds) \<I> ?DB = ?DB"
         "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (?snds_occs) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> = {}"
         "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel ?snds_occs) \<I> ?DB = ?DB"
       by (metis ik\<^sub>s\<^sub>s\<^sub>t_snoc_no_receive_empty, metis dbupd\<^sub>s\<^sub>s\<^sub>t_no_upd,
           metis ik\<^sub>s\<^sub>s\<^sub>t_snoc_no_receive_empty, metis dbupd\<^sub>s\<^sub>s\<^sub>t_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 dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(11))
     hence "\<forall>a \<in> set (unlabel ?chks). \<not>is_Receive a \<and> \<not>is_Insert a \<and> \<not>is_Delete a"
       unfolding list_all_iff by blast
     hence chks_no_upds:
         "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?chks \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> = {}"
         "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel ?chks) \<I> ?DB = ?DB"
       by (metis ik\<^sub>s\<^sub>s\<^sub>t_snoc_no_receive_empty, metis dbupd\<^sub>s\<^sub>s\<^sub>t_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' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
       by (metis (no_types, opaque_lifting) subst_sst_list_all(1) unlabel_subst)
     hence rcvs_is_rcvs: "list_all is_Receive (unlabel ?rcvs)"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all(2) by blast
 
     have rcvs_sem: "strand_sem_stateful M D (unlabel rcvs) \<I>"
       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 "[]" \<I>, 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 _ _ _ _ \<I>]
             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 \<B>_def 6(1)[OF True] by force
     next
       case False
       note F = this
       show ?thesis
       proof (cases "\<exists>ts F'. transaction_send T' = \<langle>\<star>, send\<langle>ts\<rangle>\<rangle>#F'")
         case True
         obtain ts F' rcvs' where F':
             "transaction_send T' = \<langle>\<star>, send\<langle>ts\<rangle>\<rangle>#F'"
             "\<B> = (if flt xs = [] then ?snds else ?snds_occs)@?chks@?upds@rcvs'"
             "rcvs' = \<langle>\<star>, receive\<langle>occs (transaction_fresh T')@ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>#dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (F' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
           using 6(3)[OF F True] unfolding \<B>_def by blast
 
         have *: "list_all is_Receive (unlabel rcvs')"
           using rcvs_is_rcvs dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_Cons(1)[of \<star> ts "F' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
                 subst_lsst_cons[of "\<langle>\<star>, send\<langle>ts\<rangle>\<rangle>" F' \<theta>]
           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 (\<langle>\<star>, receive\<langle>occs (transaction_fresh T') \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>#?rcvs))"
           using rcvs_is_rcvs by auto
 
         show ?thesis using B_sem[OF *] unfolding \<B>_def 6(2)[OF F False] by fastforce
       qed
     qed
   qed
   thus ?case
     using IH strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "unlabel \<B>" \<I>]
     unfolding welltyped_constraint_model_def constraint_model_def \<theta>_def[symmetric] \<B>_def[symmetric]
     by simp
 qed simp
 
 theorem add_occurs_msgs_soundness:
   defines "wt_attack \<equiv> \<lambda>\<I> \<A> l n. welltyped_constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
   assumes P: "\<forall>T \<in> set P. admissible_transaction T"
              "has_initial_value_producing_transaction P"
     and A: "\<A> \<in> reachable_constraints P" "wt_attack \<I> \<A> l n"
   shows "\<exists>\<B> \<in> reachable_constraints (map add_occurs_msgs P). \<exists>\<J>. wt_attack \<J> \<B> l n"
 proof -
   have P': "\<forall>T \<in> set (map add_occurs_msgs P). admissible_transaction' T"
            "\<forall>T \<in> set (map add_occurs_msgs P). admissible_transaction_occurs_checks T"
            "\<forall>T \<in> set P. admissible_transaction' T"
            "\<forall>T \<in> set P. admissible_transaction_no_occurs_msgs T"
     using P admissible_transactionE' add_occurs_msgs_admissible_occurs_checks
     by (fastforce,fastforce,fastforce,fastforce)
 
   obtain \<A>' \<J> where A':
       "\<A>' \<in> reachable_constraints P" "wt_attack \<J> \<A>' l n" "\<forall>x\<in>fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>'. \<exists>n. \<J> 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 \<J> \<A>'"
     using A'(2) welltyped_constraint_model_prefix
     unfolding wt_attack_def by blast
 
   obtain \<B> where B:
       "\<B> \<in> reachable_constraints (map add_occurs_msgs P)" "\<A>' = rm_occurs_msgs_constr \<B>"
     using add_occurs_msgs_soundness_aux2[OF P(1) A'(1)] by blast
 
   have J': "welltyped_constraint_model \<J> \<B>"
     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\<langle>ts\<rangle> \<in> set (unlabel \<B>)" "attack\<langle>n\<rangle> \<in> 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 \<B>]
     unfolding B(2)[symmetric] by auto
 
   have J'': "wt_attack \<J> \<B> 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 \<open>Automatically Checking Protocol Security in a Typed Model\<close>
 context stateful_protocol_model
 begin
 
 definition abs_intruder_knowledge ("\<alpha>\<^sub>i\<^sub>k") where
   "\<alpha>\<^sub>i\<^sub>k S \<I> \<equiv> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<I>)"
 
 definition abs_value_constants ("\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s") where
   "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s S \<I> \<equiv> {t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>. \<exists>n. t = Fun (Val n) []} \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t S \<I>)"
 
 definition abs_term_implications ("\<alpha>\<^sub>t\<^sub>i") where
   "\<alpha>\<^sub>t\<^sub>i \<A> T \<theta> \<I> \<equiv> {(s,t) | s t x.
     s \<noteq> t \<and> x \<in> fv_transaction T \<and> x \<notin> set (transaction_fresh T) \<and>
     Fun (Abs s) [] = \<theta> x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) \<and>
     Fun (Abs t) [] = \<theta> x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I>)}"
 
 lemma abs_intruder_knowledge_append:
   "\<alpha>\<^sub>i\<^sub>k (A@B) \<I> =
     (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) \<I>) \<union>
     (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) \<I>)"
 by (metis unlabel_append abs_set_union image_Un ik\<^sub>s\<^sub>s\<^sub>t_append abs_intruder_knowledge_def)
 
 lemma abs_value_constants_append:
   fixes A B::"('a,'b,'c,'d) prot_strand"
   shows "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s (A@B) \<I> =
       {t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>. \<exists>n. t = Fun (Val n) []} \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) \<I>) \<union>
       {t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>. \<exists>n. t = Fun (Val n) []} \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@B) \<I>)"
 proof -
   define a0 where "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>s\<^sub>s\<^sub>t (unlabel (A@B)) \<I>)"
   define M where "M \<equiv> \<lambda>a::('a,'b,'c,'d) prot_strand.
                             {t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t a) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>. \<exists>n. t = Fun (Val n) []}"
 
   have "M (A@B) = M A \<union> M B"
     using image_Un[of "\<lambda>x. x \<cdot> \<I>" "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" "subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"]
     unfolding M_def unlabel_append[of A B] trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel A" "unlabel B"] by blast
   hence "M (A@B) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0 = (M A \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0) \<union> (M B \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0)" by (simp add: abs_set_union)
   thus ?thesis unfolding abs_value_constants_def a0_def M_def by force 
 qed
 
 lemma transaction_renaming_subst_has_no_pubconsts_abss:
   fixes \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_renaming_subst \<alpha> P A"
   shows "subst_range \<alpha> \<inter> pubval_terms = {}" (is ?A)
     and "subst_range \<alpha> \<inter> abs_terms = {}" (is ?B)
 proof -
   { fix t assume "t \<in> subst_range \<alpha>"
     then obtain x where "t = Var x" 
       using transaction_renaming_subst_is_renaming(1)[OF assms]
       by force
     hence "t \<notin> pubval_terms" "t \<notin> abs_terms" by simp_all
   } thus ?A ?B by auto
 qed
 
 lemma transaction_fresh_subst_has_no_pubconsts_abss:
   fixes \<sigma>::"('fun,'atom,'sets,'lbl) prot_subst"
   assumes "transaction_fresh_subst \<sigma> T \<A>" "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
   shows "subst_range \<sigma> \<inter> pubval_terms = {}" (is ?A)
     and "subst_range \<sigma> \<inter> abs_terms = {}" (is ?B)
 proof -
   { fix t assume "t \<in> subst_range \<sigma>"
     then obtain x where "x \<in> set (transaction_fresh T)" "\<sigma> x = t"
       using assms(1) unfolding transaction_fresh_subst_def by auto
     then obtain n where "t = Fun (Val n) []" 
       using transaction_fresh_subst_sends_to_val[OF assms(1)] assms(2)
       by meson
     hence "t \<notin> pubval_terms" "t \<notin> abs_terms" unfolding is_PubConstValue_def by simp_all
   } thus ?A ?B by auto
 qed
 
 lemma reachable_constraints_GSMP_no_pubvals_abss:
   assumes "\<A> \<in> reachable_constraints P"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and \<I>: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
            "\<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
            "\<forall>n. Abs n \<notin> \<Union>(funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
   shows "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<subseteq> GSMP (\<Union>T \<in> set P. trms_transaction T) - (pubval_terms \<union> abs_terms)"
     (is "?A \<subseteq> ?B")
 using assms(1) \<I>(4,5)
 proof (induction \<A> rule: reachable_constraints.induct)
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   define trms_P where "trms_P \<equiv> (\<Union>T \<in> set P. trms_transaction T)"
   define T' where "T' \<equiv> transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   have \<xi>_elim: "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = \<sigma> \<circ>\<^sub>s \<alpha>"
     using admissible_transaction_decl_subst_empty[OF bspec[OF P step.hyps(2)] step.hyps(3)]
     by simp
 
   note T_fresh = admissible_transactionE(2)[OF bspec[OF P step.hyps(2)]]
   note T_no_bvars = admissible_transactionE(4)[OF bspec[OF P step.hyps(2)]]
 
   have T_no_PubVal: "\<forall>T \<in> set P. \<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` trms_transaction T)"
     and T_no_Abs: "\<forall>T \<in> set P. \<forall>n. Abs n \<notin> \<Union>(funs_term ` trms_transaction T)"
     using admissible_transactions_no_Value_consts''[OF bspec[OF P]] by metis+
 
   have \<I>': "\<forall>n. PubConst Value n \<notin> \<Union> (funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
            "\<forall>n. Abs n \<notin> \<Union> (funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
     using step.prems fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] unlabel_append[of \<A>]
     by auto
 
   have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))" for X
     using wt_subst_rm_vars[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "set X"]
           transaction_decl_fresh_renaming_substs_wt[OF step.hyps(3-5)]
     by metis
   hence wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t ((rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<circ>\<^sub>s \<I>)" for X
     using \<I>(2) wt_subst_compose by fast
 
   have wftrms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range ((rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<circ>\<^sub>s \<I>))" for X
     using wf_trms_subst_compose[OF wf_trms_subst_rm_vars' \<I>(3)]
           transaction_decl_fresh_renaming_substs_range_wf_trms[OF step.hyps(3-5)]
     by fast
 
   have "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<subseteq> ?B"
   proof
     fix t assume "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T') \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     hence "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq by blast
     then obtain s X where s:
         "s \<in> trms_transaction T"
         "t = s \<cdot> rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<circ>\<^sub>s \<I>"
         "set X \<subseteq> bvars_transaction T"
       using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_subst'' unfolding T'_def by blast
 
     define \<theta> where "\<theta> \<equiv> rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
     note 0 = pubval_terms_subst_range_comp[OF 
               transaction_fresh_subst_has_no_pubconsts_abss(1)[OF step.hyps(4) T_fresh]
               transaction_renaming_subst_has_no_pubconsts_abss(1)[OF step.hyps(5)]]
              abs_terms_subst_range_comp[OF 
               transaction_fresh_subst_has_no_pubconsts_abss(2)[OF step.hyps(4) T_fresh]
               transaction_renaming_subst_has_no_pubconsts_abss(2)[OF step.hyps(5)]]
 
     have 1: "s \<in> trms_P" using step.hyps(2) s(1) unfolding trms_P_def by auto
 
     have s_nin: "s \<notin> pubval_terms" "s \<notin> abs_terms"
       using 1 T_no_PubVal T_no_Abs funs_term_Fun_subterm
       unfolding trms_P_def is_PubConstValue_def is_Abs_def is_PubConst_def
       by (fastforce, blast)
 
     have 2: "(\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')) \<inter> pubval_terms = {}"
             "(\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')) \<inter> abs_terms = {}"
             "subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<inter> pubval_terms = {}"
             "subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<inter> abs_terms = {}"
       using 0 step.prems funs_term_Fun_subterm
       unfolding T'_def \<theta>_def \<xi>_elim
       by (fastforce simp add: is_PubConstValue_def is_PubConst_def,
           fastforce simp add: is_Abs_def,
           argo, argo)
 
     have "subst_range \<theta> \<subseteq> subst_range (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using rm_vars_img_subset unfolding \<theta>_def \<xi>_elim by blast 
     hence 3: "subst_range \<theta> \<inter> pubval_terms = {}"
              "subst_range \<theta> \<inter> abs_terms = {}"
       using 2(3,4) step.prems funs_term_Fun_subterm
       unfolding T'_def \<theta>_def \<xi>_elim by (blast,blast)
     
     have "(\<I> ` fv (s \<cdot> \<theta>)) \<inter> pubval_terms = {}"
          "(\<I> ` fv (s \<cdot> \<theta>)) \<inter> abs_terms = {}"
     proof -
       have "\<theta> = \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "bvars_transaction T = {}" "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' = fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
         using s(3) T_no_bvars step.hyps(2) rm_vars_empty
               vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel T'"]
               bvars\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel (transaction_strand T)" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
               unlabel_subst[of "transaction_strand T" "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
         unfolding \<theta>_def T'_def by simp_all
       hence "fv (s \<cdot> \<theta>) \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"
         using trms\<^sub>s\<^sub>s\<^sub>t_fv_subst_subset[OF s(1), of \<theta>] unlabel_subst[of "transaction_strand T" \<theta>]
         unfolding T'_def by auto
       moreover have "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<subseteq> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"
         using fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>" "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')"]
               unlabel_append[of \<A> "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t T'"]
               fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of T']
         by simp_all
       hence "\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<inter> pubval_terms = {}" "\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<inter> abs_terms = {}"
         using 2(1,2) by blast+
       ultimately show "(\<I> ` fv (s \<cdot> \<theta>)) \<inter> pubval_terms = {}" "(\<I> ` fv (s \<cdot> \<theta>)) \<inter> abs_terms = {}"
         by blast+
     qed
     hence \<sigma>\<alpha>\<I>_disj: "((\<theta> \<circ>\<^sub>s \<I>) ` fv s) \<inter> pubval_terms = {}" 
                     "((\<theta> \<circ>\<^sub>s \<I>) ` fv s) \<inter> abs_terms = {}" 
       using pubval_terms_subst_range_comp'[of \<theta> "fv s" \<I>]
             abs_terms_subst_range_comp'[of \<theta> "fv s" \<I>]
             pubval_terms_subst_range_disj[OF 3(1), of s]
             abs_terms_subst_range_disj[OF 3(2), of s]
       by (simp_all add: subst_apply_fv_unfold)
     
     have 4: "t \<notin> pubval_terms" "t \<notin> abs_terms"
       using s(2) s_nin \<sigma>\<alpha>\<I>_disj
             pubval_terms_subst[of s "rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<circ>\<^sub>s \<I>"]
             pubval_terms_subst_range_disj[of "rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<circ>\<^sub>s \<I>" s]
             abs_terms_subst[of s "rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<circ>\<^sub>s \<I>"]
             abs_terms_subst_range_disj[of "rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<circ>\<^sub>s \<I>" s]
       unfolding \<theta>_def
       by blast+
 
     have "t \<in> SMP trms_P" "fv t = {}"
       by (metis s(2) SMP.Substitution[OF SMP.MP[OF 1] wt wftrms, of X], 
           metis s(2) subst_subst_compose[of s "rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)" \<I>]
                      interpretation_grounds[OF \<I>(1), of "s \<cdot> rm_vars (set X) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"])
     hence 5: "t \<in> GSMP trms_P" unfolding GSMP_def by simp
     
     show "t \<in> ?B" using 4 5 by (auto simp add: trms_P_def)
   qed
   thus ?case
     using step.IH[OF \<I>'] trms\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] unlabel_append[of \<A>]
           image_Un[of "\<lambda>x. x \<cdot> \<I>" "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"]
     by (simp add: T'_def)
 qed simp
 
 lemma \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_aux:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and t: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
            "t = Fun (Val n) [] \<or> t = Var x"
     and neq:
       "t \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) \<noteq>
        t \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>)"
   shows "\<exists>y \<in> fv_transaction T - set (transaction_fresh T).
           t \<cdot> \<I> = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<and> \<Gamma>\<^sub>v y = TAtom Value"
 proof -
   let ?\<A>' = "\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   let ?\<B> = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"
   let ?\<B>' = "?\<B> \<cdot>\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
   let ?\<B>'' = "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
 
   have \<I>_interp: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
     by (metis \<I> welltyped_constraint_model_def constraint_model_def,
         metis \<I> welltyped_constraint_model_def,
         metis \<I> welltyped_constraint_model_def constraint_model_def)
 
   note T_adm = bspec[OF P(1) T]
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
   note T_adm_upds = admissible_transaction_is_wellformed_transaction(3)[OF T_adm]
 
   have T_fresh_vars_value_typed: "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     using T P(1) protocol_transaction_vars_TAtom_typed(3)[of T] P(1) by simp
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm \<xi>]
 
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF \<xi> \<sigma> \<alpha>]
 
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(1) \<A>_reach)
   hence t_wf: "wf\<^sub>t\<^sub>r\<^sub>m t" using t by auto
 
   have \<A>_no_val_bvars: "\<not>TAtom Value \<sqsubseteq> \<Gamma>\<^sub>v x"
     when "x \<in> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" for x
     using P(1) reachable_constraints_no_bvars \<A>_reach
           vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"] that
           admissible_transactionE(4)
     by fast
 
   have x': "x \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" when "t = Var x"
     using that t by (simp add: var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t)
 
   have "\<exists>f \<in> funs_term (t \<cdot> \<I>). is_Val f"
     using abs_eq_if_no_Val neq by metis
   hence "\<exists>n T. Fun (Val n) T \<sqsubseteq> t \<cdot> \<I>"
     using funs_term_Fun_subterm
     unfolding is_Val_def by fast
   hence "TAtom Value \<sqsubseteq> \<Gamma> (Var x)" when "t = Var x"
     using wt_subst_trm''[OF \<I>_wt, of "Var x"] that
           subtermeq_imp_subtermtypeeq[of "t \<cdot> \<I>"] wf_trm_subst[OF \<I>_wf, of t] t_wf
     by fastforce
   hence x_val: "\<Gamma>\<^sub>v x = TAtom Value" when "t = Var x"
     using reachable_constraints_vars_TAtom_typed[OF \<A>_reach P x'] that
     by fastforce
   hence x_fv: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" when "t = Var x" using x'
     using reachable_constraints_Value_vars_are_fv[OF \<A>_reach P x'] that
     by blast
   then obtain m where m: "t \<cdot> \<I> = Fun (Val m) []"
     using constraint_model_Value_term_is_Val[
             OF \<A>_reach welltyped_constraint_model_prefix[OF \<I>] P P_occ, of x]
           t(2) x_val
     by force
   hence 0: "\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) m \<noteq> \<alpha>\<^sub>0 (db\<^sub>s\<^sub>s\<^sub>t (unlabel \<A>@?\<B>'') \<I>) m"
     using neq by (simp add: unlabel_def)
 
   have t_val: "\<Gamma> t = TAtom Value" using x_val t by force
 
   obtain u s where s: "t \<cdot> \<I> = u \<cdot> \<I>" "insert\<langle>u,s\<rangle> \<in> set ?\<B>' \<or> delete\<langle>u,s\<rangle> \<in> set ?\<B>'"
     using to_abs_neq_imp_db_update[OF 0] m
     by (metis (no_types, lifting) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst subst_lsst_unlabel)
   then obtain u' s' where s':
       "u = u' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" "s = s' \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       "insert\<langle>u',s'\<rangle> \<in> set ?\<B> \<or> delete\<langle>u',s'\<rangle> \<in> set ?\<B>"
     using stateful_strand_step_mem_substD(4,5)
     by blast
   hence s'': "insert\<langle>u',s'\<rangle> \<in> set (unlabel (transaction_strand T)) \<or>
               delete\<langle>u',s'\<rangle> \<in> set (unlabel (transaction_strand T))"
     using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(4,5)[of u' s' "transaction_strand T"]
     by simp_all
   then obtain y where y: "y \<in> fv_transaction T" "u' = Var y"
     using transaction_inserts_are_Value_vars[OF T_wf T_adm_upds, of u' s']
           transaction_deletes_are_Value_vars[OF T_wf T_adm_upds, of u' s']
           stateful_strand_step_fv_subset_cases(4,5)[of u' s' "unlabel (transaction_strand T)"]
     by auto
   hence 1: "t \<cdot> \<I> = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>" using y s(1) s'(1) by (metis eval_term.simps(1)) 
 
   have 2: "y \<notin> set (transaction_fresh T)" when "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<noteq> \<sigma> y"
     using transaction_fresh_subst_grounds_domain[OF \<sigma>, of y] subst_compose[of \<sigma> \<alpha> y] that \<xi>_empty
     by (auto simp add: subst_ground_ident)
 
   have 3: "y \<notin> set (transaction_fresh T)" when "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     using 2 that \<sigma> unfolding transaction_fresh_subst_def by fastforce
 
   have 4: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
             (\<exists>B. prefix B \<A> \<and> x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<and> \<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B))"
     by (metis welltyped_constraint_model_prefix[OF \<I>]
               constraint_model_Value_var_in_constr_prefix[OF \<A>_reach _ P P_occ])
 
   have 5: "\<Gamma>\<^sub>v y = TAtom Value"
     using 1 t_val
           wt_subst_trm''[OF \<xi>\<sigma>\<alpha>_wt, of "Var y"]
           wt_subst_trm''[OF \<I>_wt, of t]
           wt_subst_trm''[OF \<I>_wt, of "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y"]
     by (auto simp del: subst_subst_compose)
 
   have "y \<notin> set (transaction_fresh T)"
   proof (cases "t = Var x")
     case True (* \<I> x occurs in \<A> but not in subst_range \<sigma>, so y cannot be fresh *)
     hence *: "\<I> x = Fun (Val m) []" "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "\<I> x = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>"
       using m t(1) 1 x_fv x' by (force, blast, force)
 
     obtain B where B: "prefix B \<A>" "\<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       using *(2) 4 x_val[OF True] by fastforce
     hence "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       using transaction_fresh_subst_range_fresh(1)[OF \<sigma>] trms\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset(1)[of B]
       unfolding prefix_def by fast
     thus ?thesis using *(1,3) B(2) 2 by (metis subst_imgI term.distinct(1))
   next
     case False
     hence "t \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" using t by simp
     thus ?thesis using 1 3 by argo
   qed
   thus ?thesis using 1 5 y(1) by fast
 qed
 
 lemma \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_Var:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
   shows "\<I> x \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>) \<in>
             timpl_closure_set {\<I> x \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)} (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
 proof -
   define a0 where "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
   define a0' where "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>)"
   define a3 where "a3 \<equiv> \<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"
 
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(1) \<A>_reach)
 
   note T_adm = bspec[OF P(1) T]
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm \<xi>]
   note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF \<xi> \<sigma> \<alpha>]
 
   have \<I>_interp: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
     by (metis \<I> welltyped_constraint_model_def constraint_model_def,
         metis \<I> welltyped_constraint_model_def,
         metis \<I> welltyped_constraint_model_def constraint_model_def)
 
   have "\<Gamma>\<^sub>v x = Var Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = Var (prot_atom.Atom a))"
     using reachable_constraints_vars_TAtom_typed[OF \<A>_reach P, of x]
           x vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"]
     by auto
 
   hence "\<I> x \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {\<I> x \<cdot>\<^sub>\<alpha> a0} a3"
   proof
     assume x_val: "\<Gamma>\<^sub>v x = TAtom Value"
     show "\<I> x \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {\<I> x \<cdot>\<^sub>\<alpha> a0} a3"
     proof (cases "\<I> x \<cdot>\<^sub>\<alpha> a0 = \<I> x \<cdot>\<^sub>\<alpha> a0'")
       case False
       hence "\<exists>y \<in> fv_transaction T - set (transaction_fresh T).
               \<I> x = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<and> \<Gamma>\<^sub>v y = TAtom Value"
         using \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_aux[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t[OF x], of _ x]
         unfolding a0_def a0'_def
         by fastforce
       then obtain y where y:
           "y \<in> fv_transaction T - set (transaction_fresh T)"
           "\<I> x = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>"
           "\<I> x \<cdot>\<^sub>\<alpha> a0 = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0"
           "\<I> x \<cdot>\<^sub>\<alpha> a0' = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0'"
           "\<Gamma>\<^sub>v y = TAtom Value"
         by metis
       then obtain n where n: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> = Fun (Val n) []"
         using \<Gamma>\<^sub>v_TAtom''(2)[of y] x x_val
               transaction_var_becomes_Val[
                 OF reachable_constraints.step[OF \<A>_reach T \<xi> \<sigma> \<alpha>] \<I> \<xi> \<sigma> \<alpha> P P_occ T, of y]
         by force
 
       have "a0 n \<noteq> a0' n"
            "y \<in> fv_transaction T"
            "y \<notin> set (transaction_fresh T)"
            "absc (a0 n) = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0"
            "absc (a0' n) = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0'"
         using y n False by force+
       hence 1: "(a0 n, a0' n) \<in> a3" 
         unfolding a0_def a0'_def a3_def abs_term_implications_def
         by blast
       
       have 2: "\<I> x \<cdot>\<^sub>\<alpha> a0' \<in> set \<langle>a0 n --\<guillemotright> a0' n\<rangle>\<langle>\<I> x \<cdot>\<^sub>\<alpha> a0\<rangle>"
         using y n timpl_apply_const by auto
 
       show ?thesis
         using timpl_closure.TI[OF timpl_closure.FP 1] 2
               term_variants_pred_iff_in_term_variants[
                 of "(\<lambda>_. [])(Abs (a0 n) := [Abs (a0' n)])"]
         unfolding timpl_closure_set_def timpl_apply_term_def
         by auto
     qed (auto intro: timpl_closure_setI)
   next
     assume "\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)"
-    then obtain a where x_atom: "\<Gamma>\<^sub>v x = TAtom (Atom a)" by moura
+    then obtain a where x_atom: "\<Gamma>\<^sub>v x = TAtom (Atom a)" by force
 
     obtain f T where fT: "\<I> x = Fun f T"
       using interpretation_grounds[OF \<I>_interp, of "Var x"]
       by (cases "\<I> x") auto
 
     have fT_atom: "\<Gamma> (Fun f T) = TAtom (Atom a)"
       using wt_subst_trm''[OF \<I>_wt, of "Var x"] x_atom fT
       by simp
 
     have T: "T = []"
       using fT wf_trm_subst[OF \<I>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s, of "Var x"] const_type_inv_wf[OF fT_atom]
       by fastforce
 
     have f: "\<not>is_Val f" using fT_atom unfolding is_Val_def by auto
 
     have "\<I> x \<cdot>\<^sub>\<alpha> b = \<I> x" for b
       using T fT abs_term_apply_const(2)[OF f]
       by auto
     thus "\<I> x \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {\<I> x \<cdot>\<^sub>\<alpha> a0} a3"
       by (auto intro: timpl_closure_setI)
   qed
   thus ?thesis by (metis a0_def a0'_def a3_def)
 qed
 
 lemma \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_Val:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and n: "Fun (Val n) [] \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   shows "Fun (Val n) [] \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>) \<in>
             timpl_closure_set {Fun (Val n) [] \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)} (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
 proof -
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define a0 where "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
   define a0' where "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<I>)"
   define a3 where "a3 \<equiv> \<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"
 
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(1) \<A>_reach)
 
   note T_adm = bspec[OF P(1) T]
 
   have "Fun (Abs (a0' n)) [] \<in> timpl_closure_set {Fun (Abs (a0 n)) []} a3"
   proof (cases "a0 n = a0' n")
     case False
     then obtain x where x:
         "x \<in> fv_transaction T - set (transaction_fresh T)" "Fun (Val n) [] = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I>"
       using \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_aux[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ n]
       by (fastforce simp add: a0_def a0'_def T'_def)
     hence "absc (a0 n) = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0" "absc (a0' n) = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0'"
       by simp_all
     hence 1: "(a0 n, a0' n) \<in> a3"
       using False x(1)
       unfolding a0_def a0'_def a3_def abs_term_implications_def T'_def
       by blast
     show ?thesis
       using timpl_apply_Abs[of "[]" "[]" "a0 n" "a0' n"]
             timpl_closure.TI[OF timpl_closure.FP[of "Fun (Abs (a0 n)) []" a3] 1]
             term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs (a0 n) := [Abs (a0' n)])"]
       unfolding timpl_closure_set_def timpl_apply_term_def
       by force
   qed (auto intro: timpl_closure_setI)
   thus ?thesis by (simp add: a0_def a0'_def a3_def T'_def)
 qed
 
 lemma \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_ik:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and t: "t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
   shows "t \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>) \<in>
             timpl_closure_set {t \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)} (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
 proof -
   define a0 where "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
   define a0' where "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>)"
   define a3 where "a3 \<equiv> \<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"
 
   let ?U = "\<lambda>T a. map (\<lambda>s. s \<cdot> \<I> \<cdot>\<^sub>\<alpha> a) T"
 
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(1) \<A>_reach)
 
   note T_adm = bspec[OF P(1) T]
 
   have "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" "wf\<^sub>t\<^sub>r\<^sub>m t" using \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s t ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset by force+
   hence "\<forall>t0 \<in> subterms t. t0 \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {t0 \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0} a3"
   proof (induction t)
     case (Var x) thus ?case
       using \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_Var[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ, of x]
             ik\<^sub>s\<^sub>s\<^sub>t_var_is_fv[of x "unlabel \<A>"] vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"]
       by (simp add: a0_def a0'_def a3_def)
   next
     case (Fun f S)
     have IH: "\<forall>t0 \<in> subterms t. t0 \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {t0 \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0} a3"
       when "t \<in> set S" for t
       using that Fun.prems(1) wf_trm_param[OF Fun.prems(2)] Fun.IH
       by (meson in_subterms_subset_Union params_subterms subsetCE)
     hence "t \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {t \<cdot>\<^sub>\<alpha> a0} a3"
       when "t \<in> set (map (\<lambda>s. s \<cdot> \<I>) S)" for t
       using that by auto
     hence "t \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure (t \<cdot>\<^sub>\<alpha> a0) a3"
       when "t \<in> set (map (\<lambda>s. s \<cdot> \<I>) S)" for t
       using that timpl_closureton_is_timpl_closure by auto
     hence "(t \<cdot>\<^sub>\<alpha> a0, t \<cdot>\<^sub>\<alpha> a0') \<in> timpl_closure' a3"
       when "t \<in> set (map (\<lambda>s. s \<cdot> \<I>) S)" for t
       using that timpl_closure_is_timpl_closure' by auto
     hence IH': "((?U S a0) ! i, (?U S a0') ! i) \<in> timpl_closure' a3"
       when "i < length (map (\<lambda>s. s \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0) S)" for i
       using that by auto
 
     show ?case
     proof (cases "\<exists>n. f = Val n")
       case True
       then obtain n where "Fun f S = Fun (Val n) []"
         using Fun.prems(2) unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by force
       moreover have "Fun f S \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
         using ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset Fun.prems(1) by blast
       ultimately show ?thesis
         using \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_Val[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ]
         by (simp add: a0_def a0'_def a3_def)
     next
       case False
       hence "Fun f S \<cdot> \<I> \<cdot>\<^sub>\<alpha> a = Fun f (map (\<lambda>t. t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a) S)" for a by (cases f) simp_all
       hence "(Fun f S \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0, Fun f S \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0') \<in> timpl_closure' a3"
         using timpl_closure_FunI[OF IH']
         by simp
       hence "Fun f S \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {Fun f S \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0} a3"
         using timpl_closureton_is_timpl_closure
               timpl_closure_is_timpl_closure'
         by metis
       thus ?thesis using IH by simp
     qed
   qed
   thus ?thesis by (simp add: a0_def a0'_def a3_def)
 qed
 
 lemma transaction_prop1:
   assumes "\<delta> \<in> abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T)"
     and "x \<in> fv_transaction T"
     and "x \<notin> set (transaction_fresh T)"
     and "\<delta> x \<noteq> absdbupd (unlabel (transaction_updates T)) x (\<delta> x)"
     and "transaction_check' msgcs (FP, OCC, TI) T"
     and TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "(\<delta> x, absdbupd (unlabel (transaction_updates T)) x (\<delta> x)) \<in> (set TI)\<^sup>+"
 proof -
   let ?upd = "\<lambda>x. absdbupd (unlabel (transaction_updates T)) x (\<delta> x)"
 
   have 0: "fv_transaction T = set (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)))"
     by (metis fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]) 
 
   have 1: "transaction_check_post (FP, OCC, TI) T \<delta>"
     using assms(1,5)
     unfolding transaction_check_def transaction_check'_def list_all_iff
     by blast
 
   have "(\<delta> x, ?upd x) \<in> set TI \<longleftrightarrow> (\<delta> x, ?upd x) \<in> (set TI)\<^sup>+"
     using TI using assms(4) by blast
   thus ?thesis
     using assms(2,3,4) 0 1 in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
     unfolding transaction_check_post_def List.member_def Let_def by blast
 qed
 
 lemma transaction_prop2:
   assumes \<delta>: "\<delta> \<in> abs_substs_fun ` set (transaction_check_comp msgcs (FP, OCC, TI) T)"
     and x: "x \<in> fv_transaction T" "fst x = TAtom Value"
     and T_check: "transaction_check' msgcs (FP, OCC, TI) T"
     and T_adm: "admissible_transaction' T"
     and T_occ: "admissible_transaction_occurs_checks T"
     and FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "x \<notin> set (transaction_fresh T) \<Longrightarrow> \<delta> x \<in> set OCC" (is "?A' \<Longrightarrow> ?A")
     and "absdbupd (unlabel (transaction_updates T)) x (\<delta> x) \<in> set OCC" (is ?B)
 proof -
   let ?xs = "fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
   let ?ys = "filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) ?xs"
   let ?C = "unlabel (transaction_checks T)"
   let ?poss = "transaction_poschecks_comp ?C"
   let ?negs = "transaction_negchecks_comp ?C"
   let ?\<delta>upd = "\<lambda>y. absdbupd (unlabel (transaction_updates T)) y (\<delta> y)"
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have 0: "{x \<in> fv_transaction T - set (transaction_fresh T). fst x = TAtom Value} = set ?ys"
     using fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
     by force
 
   have 1: "transaction_check_pre (FP, OCC, TI) T \<delta>"
     using \<delta> unfolding transaction_check_comp_def Let_def by fastforce
 
   have 2: "transaction_check_post (FP, OCC, TI) T \<delta>"
     using \<delta> T_check unfolding transaction_check_def transaction_check'_def list_all_iff by auto
 
   have 3: "\<delta> \<in> abs_substs_fun ` set (abs_substs_set ?ys OCC ?poss ?negs msgcs)"
     using \<delta> unfolding transaction_check_comp_def Let_def by force
 
   show A: ?A when ?A' using that 0 3 x abs_substs_abss_bounded by blast
 
   have 4: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
     when x': "x \<in> set (transaction_fresh T)"
     using x' admissible_transactionE(7)[OF T_adm] by blast
 
   have "intruder_synth_mod_timpls FP TI (occurs (absc (?\<delta>upd x)))"
     when x': "x \<in> set (transaction_fresh T)"
   proof -
     obtain l ts S where ts:
         "transaction_send T = (l,send\<langle>ts\<rangle>)#S" "occurs (Var x) \<in> set ts"
       using admissible_transaction_occurs_checksE2[OF T_occ x'] by blast
     hence "occurs (Var x) \<in> set ts" "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
       using x' unfolding suffix_def by (fastforce, fastforce)
     thus ?thesis using 2 x unfolding transaction_check_post_def by fastforce
   qed
   hence "timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c occurs (absc (?\<delta>upd x))"
     when x': "x \<in> set (transaction_fresh T)"
     using x' intruder_synth_mod_timpls_is_synth_timpl_closure_set[
             OF TI, of FP "occurs (absc (?\<delta>upd x))"]
     by argo
   hence "Abs (?\<delta>upd x) \<in> \<Union>(funs_term ` timpl_closure_set (set FP) (set TI))"
     when x': "x \<in> set (transaction_fresh T)"
     using x' ideduct_synth_priv_fun_in_ik[
             of "timpl_closure_set (set FP) (set TI)" "occurs (absc (?\<delta>upd x))"]
     by simp
   hence "\<exists>t \<in> timpl_closure_set (set FP) (set TI). Abs (?\<delta>upd x) \<in> funs_term t"
     when x': "x \<in> set (transaction_fresh T)"
     using x' by force
   hence 5: "?\<delta>upd x \<in> set OCC" when x': "x \<in> set (transaction_fresh T)"
     using x' OCC by fastforce
 
   have 6: "?\<delta>upd x \<in> set OCC" when x': "x \<notin> set (transaction_fresh T)"
   proof (cases "\<delta> x = ?\<delta>upd x")
     case False
     hence "(\<delta> x, ?\<delta>upd x) \<in> (set TI)\<^sup>+" "\<delta> x \<in> set OCC"
       using A 2 x' x TI
       unfolding transaction_check_post_def fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t Let_def
                 in_trancl_closure_iff_in_trancl_fun[symmetric]
                 List.member_def
       by blast+
     thus ?thesis using timpl_closure_set_absc_subset_in[OF OCC(2)] by blast
   qed (simp add: A x' x(1))
 
   show ?B by (metis 5 6)
 qed
 
 lemma transaction_prop3:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
       "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and P:
       "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
   shows "\<forall>x \<in> set (transaction_fresh T). (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc {}" (is ?A)
     and "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T).
             intruder_synth_mod_timpls FP TI (t \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>))" (is ?B)
     and "\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
          \<forall>s. select\<langle>Var x,Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
                  \<longrightarrow> (\<exists>ss. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc ss \<and> s \<in> ss)" (is ?C)
     and "\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
          \<forall>s. \<langle>Var x in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
                  \<longrightarrow> (\<exists>ss. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc ss \<and> s \<in> ss)" (is ?D)
     and "\<forall>x \<in> fv_transaction T - set (transaction_fresh T).
          \<forall>s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
                  \<longrightarrow> (\<exists>ss. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc ss \<and> s \<notin> ss)" (is ?E)
     and "\<forall>x \<in> fv_transaction T - set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
          (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) \<in> absc ` set OCC" (is ?F)
 proof -
   let ?T' = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   let ?\<theta> = "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
   define a0 where "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
   define a0' where "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@?T') \<I>)"
   define fv_AT' where "fv_AT' \<equiv> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@?T')"
 
   note T_adm = bspec[OF P(1) T]
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
   note T_adm' = admissible_transaction_is_wellformed_transaction(2-4)[OF T_adm]
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm \<xi>]
   hence \<xi>_elim: "?\<theta> = \<sigma> \<circ>\<^sub>s \<alpha>" by simp
 
   have \<I>': "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
            "\<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
            "\<forall>n. Abs n \<notin> \<Union>(funs_term ` (\<I> ` fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>))"
            "\<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` (\<I> ` fv_AT'))"
            "\<forall>n. Abs n \<notin> \<Union>(funs_term ` (\<I> ` fv_AT'))"
     using \<I> admissible_transaction_occurs_checks_prop'[
             OF \<A>_reach welltyped_constraint_model_prefix[OF \<I>] P P_occ]
           admissible_transaction_occurs_checks_prop'[
             OF reachable_constraints.step[OF \<A>_reach T \<xi> \<sigma> \<alpha>] \<I> P P_occ]
     unfolding welltyped_constraint_model_def constraint_model_def is_Val_def is_Abs_def fv_AT'_def
     by (meson,meson,meson,metis,metis,metis,metis)
 
   have T_no_pubconsts: "\<forall>n. PubConst Value n \<notin> \<Union>(funs_term ` trms_transaction T)"
     and T_no_abss: "\<forall>n. Abs n \<notin> \<Union>(funs_term ` trms_transaction T)"
     and T_fresh_vars_value_typed: "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     and T_fv_const_typed: "\<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     using protocol_transaction_vars_TAtom_typed
           protocol_transactions_no_pubconsts
           protocol_transactions_no_abss
           funs_term_Fun_subterm P T
     by (fast, fast, fast, fast)
 
   have wt_\<sigma>\<alpha>\<I>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>)"
     using \<I>'(2) wt_subst_compose transaction_fresh_subst_wt[OF \<sigma>]
           transaction_renaming_subst_wt[OF \<alpha>]
     by blast
 
   have 1: "?\<theta> y \<cdot> \<I> = \<sigma> y" when "y \<in> set (transaction_fresh T)" for y
     using transaction_fresh_subst_grounds_domain[OF \<sigma> that] subst_compose[of \<sigma> \<alpha> y]
     unfolding \<xi>_elim by (simp add: subst_ground_ident)
 
   have 2: "?\<theta> y \<cdot> \<I> \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" when "y \<in> set (transaction_fresh T)" for y
     using 1[OF that] that \<sigma> unfolding transaction_fresh_subst_def by auto
 
   have 3: "\<forall>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
             (\<exists>B. prefix B \<A> \<and> x \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<and> \<I> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B))"
     by (metis welltyped_constraint_model_prefix[OF \<I>]
               constraint_model_Value_var_in_constr_prefix[OF \<A>_reach _ P P_occ])
 
   have 4: "\<exists>n. ?\<theta> y \<cdot> \<I> = Fun (Val n) []"
     when "y \<in> fv_transaction T" "\<Gamma>\<^sub>v y = TAtom Value" for y
     using transaction_var_becomes_Val[
             OF reachable_constraints.step[OF \<A>_reach T \<xi> \<sigma> \<alpha>] \<I> \<xi> \<sigma> \<alpha> P P_occ T]
           that T_fv_const_typed \<Gamma>\<^sub>v_TAtom''[of y]
     by metis
 
   have \<I>_is_T_model: "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) (set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)) (unlabel ?T') \<I>"
     using \<I> unlabel_append[of \<A> ?T'] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>" \<I> "[]"]
           strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "unlabel ?T'" \<I>]
     by (simp add: welltyped_constraint_model_def constraint_model_def db\<^sub>s\<^sub>s\<^sub>t_def)
 
   have T_rcv_no_val_bvars: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<inter> subst_domain ?\<theta> = {}"
     using admissible_transaction_no_bvars[OF T_adm] bvars_transaction_unfold[of T] by blast
 
   show ?A
   proof
     fix y assume y: "y \<in> set (transaction_fresh T)"
     then obtain yn where yn: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> = Fun (Val yn) []" "Fun (Val yn) [] \<in> subst_range \<sigma>"
       by (metis \<xi>_elim T_fresh_vars_value_typed transaction_fresh_subst_sends_to_val'[OF \<sigma>])
 
     { \<comment> \<open>since \<open>y\<close> is fresh \<open>(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>\<close> cannot be part of the database state of \<open>\<I> \<A>\<close>\<close>
       fix t' s assume t': "insert\<langle>t',s\<rangle> \<in> set (unlabel \<A>)" "t' \<cdot> \<I> = Fun (Val yn) []"
       then obtain z where t'_z: "t' = Var z" using 2[OF y] yn(1) by (cases t') auto
       hence z: "z \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "\<I> z = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>" using t' yn(1) by force+
       hence z': "\<Gamma>\<^sub>v z = TAtom Value"
         by (metis \<Gamma>.simps(1) \<Gamma>_consts_simps(2) t'(2) t'_z wt_subst_trm'' \<I>'(2))
 
       obtain B where B: "prefix B \<A>" "\<I> z \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)" using z z' 3 by fastforce
       hence "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
         using transaction_fresh_subst_range_fresh(1)[OF \<sigma>] trms\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset(1)[of B]
         unfolding prefix_def by fast
       hence False using B(2) 1[OF y] z yn(1) by (metis subst_imgI term.distinct(1)) 
     } hence "\<nexists>s. (?\<theta> y \<cdot> \<I>, s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
       using db\<^sub>s\<^sub>s\<^sub>t_in_cases[of "?\<theta> y \<cdot> \<I>" _ "unlabel \<A>" \<I> "[]"] yn(1)
       by (force simp add: db\<^sub>s\<^sub>s\<^sub>t_def)
     thus "?\<theta> y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc {}"
       using to_abs_empty_iff_notin_db[of yn "db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I> []"] yn(1)
       by (simp add: db\<^sub>s\<^sub>s\<^sub>t_def)
   qed
 
   show receives_covered: ?B
   proof
     fix t assume t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
     hence t_in_T: "t \<in> trms_transaction T"
       using trms\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset(1)[of "transaction_receive T"]
       unfolding transaction_strand_def by fast
 
     obtain ts where ts: "t \<in> set ts" "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))"
       using t wellformed_transaction_send_receive_trm_cases(1)[OF T_wf] by blast
 
     have t_rcv: "receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t ?\<theta>\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?\<theta>))"
       using subst_lsst_unlabel_member[of "receive\<langle>ts\<rangle>" "transaction_receive T" ?\<theta>]
             trms\<^sub>s\<^sub>s\<^sub>t_in[OF t] ts
       by fastforce
     
     have "list_all (\<lambda>t. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> ?\<theta> \<cdot> \<I>) ts"
       using wellformed_transaction_sem_receives[OF T_wf \<I>_is_T_model t_rcv]
       unfolding list_all_iff by fastforce
     hence *: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> ?\<theta> \<cdot> \<I>" using ts(1) unfolding list_all_iff by fast
 
     have t_fv: "fv (t \<cdot> ?\<theta>) \<subseteq> fv_AT'"
       using fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] unlabel_append[of \<A>]
             fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?\<theta>"]
             ts(1) t_rcv fv_transaction_subst_unfold[of T ?\<theta>]
       unfolding fv_AT'_def by force
 
     have **: "\<forall>t \<in> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
       using FP(3) by (auto simp add: a0_def abs_intruder_knowledge_def)
 
     note lms1 = pubval_terms_subst[OF _ pubval_terms_subst_range_disj[
                   OF transaction_fresh_subst_has_no_pubconsts_abss(1)[OF \<sigma>], of t]]
                 pubval_terms_subst[OF _ pubval_terms_subst_range_disj[
                   OF transaction_renaming_subst_has_no_pubconsts_abss(1)[OF \<alpha>], of "t \<cdot> \<sigma>"]]
 
     note lms2 = abs_terms_subst[OF _ abs_terms_subst_range_disj[
                   OF transaction_fresh_subst_has_no_pubconsts_abss(2)[OF \<sigma>], of t]]
                 abs_terms_subst[OF _ abs_terms_subst_range_disj[
                   OF transaction_renaming_subst_has_no_pubconsts_abss(2)[OF \<alpha>], of "t \<cdot> \<sigma>"]]
 
     have "t \<in> (\<Union>T\<in>set P. trms_transaction T)" "fv (t \<cdot> \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I>) = {}"
       using t_in_T T interpretation_grounds[OF \<I>'(1)] by fast+
     moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range (\<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>))"
       using wf_trm_subst_rangeI[of \<sigma>, OF transaction_fresh_subst_is_wf_trm[OF \<sigma>]]
             wf_trm_subst_rangeI[of \<alpha>, OF transaction_renaming_subst_is_wf_trm[OF \<alpha>]]
             wf_trms_subst_compose[of \<sigma> \<alpha>, THEN wf_trms_subst_compose[OF _ \<I>'(3)]]
       by blast
     moreover
     have "t \<notin> pubval_terms"
       using t_in_T T_no_pubconsts funs_term_Fun_subterm
       unfolding is_PubConstValue_def is_PubConst_def by fastforce
     hence "t \<cdot> ?\<theta> \<notin> pubval_terms"
       using lms1 T_fresh_vars_value_typed
       unfolding \<xi>_elim by auto
     hence "t \<cdot> ?\<theta> \<cdot> \<I> \<notin> pubval_terms"
       using \<I>'(6) t_fv pubval_terms_subst'[of "t \<cdot> ?\<theta>" \<I>]
       by auto
     moreover have "t \<notin> abs_terms"
       using t_in_T T_no_abss funs_term_Fun_subterm
       unfolding is_Abs_def by force
     hence "t \<cdot> ?\<theta> \<notin> abs_terms"
       using lms2 T_fresh_vars_value_typed
       unfolding \<xi>_elim by auto
     hence "t \<cdot> ?\<theta> \<cdot> \<I> \<notin> abs_terms"
       using \<I>'(7) t_fv abs_terms_subst'[of "t \<cdot> ?\<theta>" \<I>]
       by auto
     ultimately have ***:
         "t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I> \<in> GSMP (\<Union>T\<in>set P. trms_transaction T) - (pubval_terms \<union> abs_terms)"
       using SMP.Substitution[OF SMP.MP[of t "\<Union>T\<in>set P. trms_transaction T"], of "\<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>"]
             subst_subst_compose[of t ?\<theta> \<I>] wt_\<sigma>\<alpha>\<I>
       unfolding GSMP_def \<xi>_elim by fastforce
 
     have ****:
         "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<subseteq> GSMP (\<Union>T\<in>set P. trms_transaction T) - (pubval_terms \<union> abs_terms)"
       using reachable_constraints_GSMP_no_pubvals_abss[OF \<A>_reach P \<I>'(1-5)]
             ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset[of "unlabel \<A>"]
       by blast
 
     show "intruder_synth_mod_timpls FP TI (t \<cdot> ?\<theta> \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>))"
       using deduct_FP_if_deduct[OF **** ** * ***] deducts_eq_if_analyzed[OF FP(1)]
             intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI, of FP]
       unfolding a0_def by force
   qed
 
   show ?C
   proof (intro ballI allI impI)
     fix y s
     assume y: "y \<in> fv_transaction T - set (transaction_fresh T)"
        and s: "select\<langle>Var y, Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))"
     hence "select\<langle>Var y, Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_strand T))"
       unfolding transaction_strand_def unlabel_def by auto
     hence y_val: "\<Gamma>\<^sub>v y = TAtom Value"
       using transaction_selects_are_Value_vars[OF T_wf T_adm'(1)]
       by fastforce
 
     have "select\<langle>?\<theta> y, Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?\<theta>))"
       using subst_lsst_unlabel_member[OF s]
       by fastforce
     hence "((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>, Fun (Set s) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
       using wellformed_transaction_sem_pos_checks[
               OF T_wf \<I>_is_T_model,
               of Assign "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y" "Fun (Set s) []"]
       by simp
     thus "\<exists>ss. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc ss \<and> s \<in> ss"
       using to_abs_alt_def[of "db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>"] 4[of y] y y_val by auto
   qed
 
   show ?D
   proof (intro ballI allI impI)
     fix y s
     assume y: "y \<in> fv_transaction T - set (transaction_fresh T)"
        and s: "\<langle>Var y in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))"
     hence "\<langle>Var y in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_strand T))"
       unfolding transaction_strand_def unlabel_def by auto
     hence y_val: "\<Gamma>\<^sub>v y = TAtom Value"
       using transaction_inset_checks_are_Value_vars[OF T_adm]
       by fastforce
 
     have "\<langle>?\<theta> y in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?\<theta>))"
       using subst_lsst_unlabel_member[OF s]
       by fastforce
     hence "(?\<theta> y \<cdot> \<I>, Fun (Set s) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
       using wellformed_transaction_sem_pos_checks[
               OF T_wf \<I>_is_T_model,
               of Check "?\<theta> y" "Fun (Set s) []"]
       by simp
     thus "\<exists>ss. ?\<theta> y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc ss \<and> s \<in> ss"
       using to_abs_alt_def[of "db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>"] 4[of y] y y_val by auto
   qed
 
   show ?E
   proof (intro ballI allI impI)
     fix y s
     assume y: "y \<in> fv_transaction T - set (transaction_fresh T)"
        and s: "\<langle>Var y not in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))"
     hence "\<langle>Var y not in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_strand T))"
       unfolding transaction_strand_def unlabel_def by auto
     hence y_val: "\<Gamma>\<^sub>v y = TAtom Value"
       using transaction_notinset_checks_are_Value_vars(1)[
               OF T_adm, of "[]" "[]" "[(Var y, Fun (Set s) [])]" "Var y" "Fun (Set s) []"]
       by force
 
     have "\<langle>?\<theta> y not in Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?\<theta>))"
       using subst_lsst_unlabel_member[OF s]
       by fastforce
     hence "(?\<theta> y \<cdot> \<I>, Fun (Set s) []) \<notin> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
       using wellformed_transaction_sem_neg_checks'(2)[
               OF T_wf \<I>_is_T_model,
               of "[]" "?\<theta> y" "Fun (Set s) []"]
       by simp
     moreover have "list_all admissible_transaction_updates P"
       using Ball_set[of P "admissible_transaction"] P(1)
             Ball_set[of P admissible_transaction_updates]
             admissible_transaction_is_wellformed_transaction(3)
       by fast
     moreover have "list_all wellformed_transaction P"
       using P(1) Ball_set[of P "admissible_transaction"] Ball_set[of P wellformed_transaction]
             admissible_transaction_is_wellformed_transaction(1)
       by blast
     ultimately have "((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>, Fun (Set s) S) \<notin> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)" for S
       using reachable_constraints_db\<^sub>l\<^sub>s\<^sub>s\<^sub>t_set_args_empty[OF \<A>_reach] 
       unfolding admissible_transaction_updates_def
       by auto
     thus "\<exists>ss. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = absc ss \<and> s \<notin> ss"
       using to_abs_alt_def[of "db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>"] 4[of y] y y_val by auto
   qed
 
   show ?F
   proof (intro ballI impI)
     fix y assume y: "y \<in> fv_transaction T - set (transaction_fresh T)" "\<Gamma>\<^sub>v y = TAtom Value"
-    then obtain yn where yn: "?\<theta> y \<cdot> \<I> = Fun (Val yn) []" using 4 by moura
+    then obtain yn where yn: "?\<theta> y \<cdot> \<I> = Fun (Val yn) []" using 4 by blast
     hence y_abs: "?\<theta> y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) = Fun (Abs (\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) yn)) []" by simp
 
     have "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<or> (y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
           (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> y \<in> fv t \<union> fv s))"
       using admissible_transaction_fv_in_receives_or_selects[OF T_adm] y by blast
     thus "?\<theta> y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) \<in> absc ` set OCC"
     proof
       assume "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
       then obtain ts where ts:
           "receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))" "y \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts)"
         using wellformed_transaction_unlabel_cases(1)[OF T_wf]
         by (force simp add: unlabel_def)
       
       have *: "?\<theta> y \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set ts \<cdot>\<^sub>s\<^sub>e\<^sub>t ?\<theta> \<circ>\<^sub>s \<I>)"
               "list_all (\<lambda>t. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t \<cdot> ?\<theta> \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)) ts"
         using ts fv_subterms_substI[of y _ "?\<theta> \<circ>\<^sub>s \<I>"] subst_compose[of ?\<theta> \<I> y]
               subterms_subst_subset[of "?\<theta> \<circ>\<^sub>s \<I>"] receives_covered
         unfolding intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI, symmetric] list_all_iff
         by fastforce+
 
       have "Abs (\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) yn) \<in> \<Union>(funs_term ` (timpl_closure_set (set FP) (set TI)))"
         using * y_abs abs_subterms_in[of "?\<theta> y \<cdot> \<I>" _ "\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"]
               ideduct_synth_priv_fun_in_ik[
                 OF _ funs_term_Fun_subterm'[of "Abs (\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) yn)" "[]"]]
         unfolding list_all_iff by fastforce
       hence "?\<theta> y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) \<in> subterms\<^sub>s\<^sub>e\<^sub>t (timpl_closure_set (set FP) (set TI))"
         using y_abs wf_trms_subterms[OF timpl_closure_set_wf_trms[OF FP(2), of "set TI"]]
               funs_term_Fun_subterm[of "Abs (\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>) yn)"]
         unfolding wf\<^sub>t\<^sub>r\<^sub>m_def by fastforce
       hence "funs_term (?\<theta> y \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>))
               \<subseteq> (\<Union>t \<in> timpl_closure_set (set FP) (set TI). funs_term t)"
         using funs_term_subterms_eq(2)[of "timpl_closure_set (set FP) (set TI)"] by blast
       thus ?thesis using y_abs OCC(1) by fastforce
     next
       assume "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
           (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> y \<in> fv t \<union> fv s)"
       then obtain t t' where
           "select\<langle>t,t'\<rangle> \<in> set (unlabel (transaction_checks T))" "y \<in> fv t \<union> fv t'"
         by blast
       then obtain l s where "(l,select\<langle>Var y, Fun (Set s) []\<rangle>) \<in> set (transaction_checks T)"
         using admissible_transaction_strand_step_cases(2)[OF T_adm]
         unfolding unlabel_def by fastforce
       then obtain U where U:
           "prefix (U@[(l,select\<langle>Var y, Fun (Set s) []\<rangle>)]) (transaction_checks T)"
         using in_set_conv_decomp[of "(l, select\<langle>Var y,Fun (Set s) []\<rangle>)" "transaction_checks T"]
         by (auto simp add: prefix_def)
       hence "select\<langle>Var y, Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))"
         by (force simp add: prefix_def unlabel_def)
       hence "select\<langle>?\<theta> y, Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t ?\<theta>))"
         using subst_lsst_unlabel_member
         by fastforce
       hence "(Fun (Val yn) [], Fun (Set s) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
         using yn wellformed_transaction_sem_pos_checks[
                 OF T_wf \<I>_is_T_model, of Assign "?\<theta> y" "Fun (Set s) []"]
         by fastforce
       hence "Fun (Val yn) [] \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
         using db\<^sub>s\<^sub>s\<^sub>t_in_cases[of "Fun (Val yn) []"]
         by (fastforce simp add: db\<^sub>s\<^sub>s\<^sub>t_def)
       thus ?thesis
         using OCC(3) yn abs_in[of "Fun (Val yn) []" _ "\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"]
         unfolding abs_value_constants_def
         by (metis (mono_tags, lifting) mem_Collect_eq subsetCE) 
     qed
   qed
 qed
 
 lemma transaction_prop4:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and x: "x \<in> set (transaction_fresh T)"
     and y: "y \<in> fv_transaction T - set (transaction_fresh T)" "\<Gamma>\<^sub>v y = TAtom Value"
   shows "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>))" (is ?A)
     and "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>))" (is ?B)
 proof -
   let ?T' = "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
 
   from \<I> have \<I>': "welltyped_constraint_model \<I> \<A>"
     using welltyped_constraint_model_prefix by auto
 
   note T_P_adm = bspec[OF P(1)]
   note T_adm = bspec[OF P(1) T]
 
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have be: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
     using T_P_adm \<A>_reach reachable_constraints_no_bvars admissible_transaction_no_bvars(2)
     by blast
 
   have T_no_bvars: "fv_transaction T = vars_transaction T"
     using admissible_transaction_no_bvars[OF T_adm] by simp
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm \<xi>]
 
   have \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" by (metis \<I> welltyped_constraint_model_def)
 
   have x_val: "fst x = TAtom Value"
     using x admissible_transactionE(14)[OF T_adm] unfolding list_all_iff by blast
 
   obtain xn where xn: "\<sigma> x = Fun (Val xn) []"
     using x_val transaction_fresh_subst_sends_to_val[OF \<sigma> x] \<Gamma>\<^sub>v_TAtom''(2)[of x] by meson
   hence xnxn: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x = Fun (Val xn) []"
     unfolding subst_compose_def \<xi>_empty by auto
 
   from xn xnxn have a0: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> = Fun (Val xn) []"
     by auto
 
   have b0: "\<Gamma>\<^sub>v x = TAtom Value"
     using P x T protocol_transaction_vars_TAtom_typed(3)
     by metis
 
   note 0 = a0 b0
 
   have \<sigma>_x_nin_A: "\<sigma> x \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
   proof -
     have "\<sigma> x \<in> subst_range \<sigma>"
       by (metis transaction_fresh_subst_sends_to_val[OF \<sigma> x b0])
     moreover
     have "\<forall>t \<in> subst_range \<sigma>. t \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       using \<sigma> transaction_fresh_subst_def[of \<sigma> T "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"] by blast
     ultimately
     show ?thesis
       by auto
   qed
 
   have *: "y \<notin> set (transaction_fresh T)"
      using assms by auto
 
   have **: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<or> (y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
             (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> y \<in> fv t \<union> fv s))"
     using * y admissible_transaction_fv_in_receives_or_selects[OF T_adm]
     by blast
 
   have y_fv: "y \<in> fv_transaction T" using y fv_transaction_unfold by blast
   
   have y_val: "fst y = TAtom Value" using y(2) \<Gamma>\<^sub>v_TAtom''(2) by blast
 
   have "\<sigma> x \<cdot> \<I> \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>))"
   proof (rule ccontr)
     assume "\<not>\<sigma> x \<cdot> \<I> \<notin> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>))"
     then have a: "\<sigma> x \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>))"
       by auto
 
     then have \<sigma>_x_I_in_A: "\<sigma> x \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
       using reachable_constraints_subterms_subst[OF \<A>_reach \<I>' P] by blast
 
     have "\<exists>u. u \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<and> \<I> u = \<sigma> x"
     proof -
       from \<sigma>_x_I_in_A have "\<exists>tu. tu \<in> \<Union> (subterms ` (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)) \<and> tu \<cdot> \<I> = \<sigma> x \<cdot> \<I>"
         by force
       then obtain tu where tu: "tu \<in> \<Union> (subterms ` (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)) \<and> tu \<cdot> \<I> = \<sigma> x \<cdot> \<I>"
         by auto
       then have "tu \<noteq> \<sigma> x"
         using \<sigma>_x_nin_A by auto
       moreover
       have "tu \<cdot> \<I> = \<sigma> x"
         using tu by (simp add: xn)
       ultimately
       have "\<exists>u. tu = Var u"
         unfolding xn by (cases tu) auto
       then obtain u where "tu = Var u"
         by auto
       have "u \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<and> \<I> u = \<sigma> x"
       proof -
         have "u \<in> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
           using \<open>tu = Var u\<close> tu var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t by fastforce 
         then have "u \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>"
           using be vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"] by blast
         moreover
         have "\<I> u = \<sigma> x"
           using \<open>tu = Var u\<close> \<open>tu \<cdot> \<I> = \<sigma> x\<close> by auto
         ultimately
         show ?thesis
           by auto
       qed
       then show "\<exists>u. u \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<and> \<I> u = \<sigma> x"
         by metis
     qed
     then obtain u where u:
       "u \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" "\<I> u = \<sigma> x"
       by auto
     then have u_TA: "\<Gamma>\<^sub>v u = TAtom Value"
       using P(1) T x_val \<Gamma>\<^sub>v_TAtom''(2)[of x]
             wt_subst_trm''[OF \<I>_wt, of "Var u"] wt_subst_trm''[of \<sigma> "Var x"] 
             transaction_fresh_subst_wt[OF \<sigma>] protocol_transaction_vars_TAtom_typed(3)
       by force
     have "\<exists>B. prefix B \<A> \<and> u \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<and> \<I> u \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       using u u_TA
       by (metis welltyped_constraint_model_prefix[OF \<I>]
                 constraint_model_Value_var_in_constr_prefix[OF \<A>_reach _ P P_occ])
     then obtain B where "prefix B \<A> \<and> u \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<and> \<I> u \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       by blast
     moreover have "\<Union>(subterms ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t xs) \<subseteq> \<Union>(subterms ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t ys)"
       when "prefix xs ys"
       for xs ys::"('fun,'atom,'sets,'lbl) prot_strand"
       using that subterms\<^sub>s\<^sub>e\<^sub>t_mono trms\<^sub>s\<^sub>s\<^sub>t_mono unlabel_mono set_mono_prefix by metis
     ultimately have "\<I> u \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       by blast
     then have "\<sigma> x \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       using u by auto
     then show "False"
       using \<sigma>_x_nin_A by auto
   qed
   then show ?A
     using eval_term.simps(1)[of _ x \<sigma>]
     unfolding subst_compose_def xn \<xi>_empty by auto
 
   from ** show ?B
   proof
     define T' where "T' \<equiv> transaction_receive T"
     define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
     assume y: "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
     hence "Var y \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')" by (metis T'_def fv\<^sub>s\<^sub>s\<^sub>t_is_subterm_trms\<^sub>s\<^sub>s\<^sub>t)
     then obtain z where z: "z \<in> set (unlabel T')" "Var y \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p z)"
       by (induct T') auto
 
     have "is_Receive z"
       using Ball_set[of "unlabel T'" is_Receive] z(1)
             admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
       unfolding wellformed_transaction_def T'_def
       by blast
     then obtain tys where "z = receive\<langle>tys\<rangle>" by (cases z) auto
     hence tys: "receive\<langle>tys \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle> \<in> set (unlabel (T' \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))" "\<theta> y \<in> subterms\<^sub>s\<^sub>e\<^sub>t (set tys \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>)"
       using z subst_mono unfolding subst_apply_labeled_stateful_strand_def unlabel_def by force+
     hence y_deduct: "list_all (\<lambda>t. ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> t \<cdot> \<theta> \<cdot> \<I>) tys"
       using transaction_receive_deduct[OF T_wf _ \<xi> \<sigma> \<alpha>] \<I>
       unfolding T'_def \<theta>_def welltyped_constraint_model_def list_all_iff by auto
 
     obtain ty where ty: "ty \<in> set tys" "\<theta> y \<sqsubseteq> ty \<cdot> \<theta>" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> ty \<cdot> \<theta> \<cdot> \<I>"
       using tys y_deduct unfolding list_all_iff by blast
 
     obtain zn where zn: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> = Fun (Val zn) []"
       using transaction_var_becomes_Val[
               OF reachable_constraints.step[OF \<A>_reach T \<xi> \<sigma> \<alpha>] \<I> \<xi> \<sigma> \<alpha> P P_occ T y_fv y_val]
       by metis
 
     have "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>)"
       using ty tys(2) y_deduct private_fun_deduct_in_ik[of _ _ "Val zn"]
       by (metis \<theta>_def zn subst_mono public.simps(3))
     thus ?B
       using ik\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel \<A>" \<I>] unlabel_subst[of \<A> \<I>]
             subterms\<^sub>s\<^sub>e\<^sub>t_mono[OF ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset[of "unlabel (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>)"]]
       by fastforce
   next
     assume y': "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<and>
                 (\<exists>t s. select\<langle>t,s\<rangle> \<in> set (unlabel (transaction_checks T)) \<and> y \<in> fv t \<union> fv s)"
     then obtain s where s: "select\<langle>Var y,s\<rangle> \<in> set (unlabel (transaction_checks T))"
                            "fst y = TAtom Value"
       using admissible_transaction_strand_step_cases(1,2)[OF T_adm] by fastforce
 
     obtain z zn where zn: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y = Var z" "\<I> z = Fun (Val zn) []"
       using transaction_var_becomes_Val[
               OF reachable_constraints.step[OF \<A>_reach T \<xi> \<sigma> \<alpha>] \<I> \<xi> \<sigma> \<alpha> P P_occ T y_fv s(2)]
             transaction_decl_fresh_renaming_substs_range(4)[OF \<xi> \<sigma> \<alpha> _ *]
             transaction_decl_subst_empty_inv[OF \<xi>[unfolded \<xi>_empty]]
       by auto
 
     have transaction_selects_db_here:
         "\<And>n s. select\<langle>Var (TAtom Value, n), Fun (Set s) []\<rangle> \<in> set (unlabel (transaction_checks T))
                 \<Longrightarrow> (\<alpha> (TAtom Value, n) \<cdot> \<I>, Fun (Set s) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
       using transaction_selects_db[OF T_adm _ \<xi> \<sigma> \<alpha>] \<I>
       unfolding welltyped_constraint_model_def by auto
 
     have "\<exists>n. y = (Var Value, n)"
       using T \<Gamma>\<^sub>v_TAtom_inv(2) y_fv y(2)
       by blast
     moreover
     have "admissible_transaction_checks T"
       using admissible_transaction_is_wellformed_transaction(2)[OF T_adm]
       by blast
     then have "is_Fun_Set (the_set_term (select\<langle>Var y,s\<rangle>))"
       using s unfolding admissible_transaction_checks_def
       by auto
     then have "\<exists>ss. s = Fun (Set ss) []"
       using is_Fun_Set_exi
       by auto
     ultimately
     obtain n ss where nss: "y = (TAtom Value, n)" "s = Fun (Set ss) []"
       by auto
     then have "select\<langle>Var (TAtom Value, n), Fun (Set ss) []\<rangle> \<in> set (unlabel (transaction_checks T))"
       using s by auto
     then have in_db: "(\<alpha> (TAtom Value, n) \<cdot> \<I>, Fun (Set ss) []) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
       using transaction_selects_db_here[of n ss] by auto
     have "(\<I> z, s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
     proof -
       have "(\<alpha> y \<cdot> \<I>, s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
         using in_db nss by auto
       moreover 
       have "\<alpha> y = Var z"
         using zn \<xi>_empty * \<sigma>
         by (metis (no_types, opaque_lifting) subst_compose_def subst_imgI subst_to_var_is_var
                   term.distinct(1) transaction_fresh_subst_def var_comp(2)) 
       then have "\<alpha> y \<cdot> \<I> = \<I> z"
         by auto
       ultimately
       show "(\<I> z, s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
         by auto
     qed
     then have "\<exists>t' s'. insert\<langle>t',s'\<rangle> \<in> set (unlabel \<A>) \<and> \<I> z = t' \<cdot> \<I> \<and> s = s' \<cdot> \<I>"
       using db\<^sub>s\<^sub>s\<^sub>t_in_cases[of "\<I> z" s "unlabel \<A>" \<I> "[]"] unfolding db\<^sub>s\<^sub>s\<^sub>t_def by auto
     then obtain t' s' where t's': "insert\<langle>t',s'\<rangle> \<in> set (unlabel \<A>) \<and> \<I> z = t' \<cdot> \<I> \<and> s = s' \<cdot> \<I>"
       by auto
     then have "t' \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       by force
     then have "t' \<cdot> \<I> \<in> (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
       by auto
     then have "\<I> z \<in> (subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
       using t's' by auto
     then have "\<I> z \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A> \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<I>))"
       using reachable_constraints_subterms_subst[
               OF \<A>_reach welltyped_constraint_model_prefix[OF \<I>] P]
       by auto
     then show ?B
       using zn(1) by simp
   qed
 qed
 
 lemma transaction_prop5:
   fixes T \<xi> \<sigma> \<alpha> \<A> \<I> T' a0 a0' \<theta>
   defines "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     and "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
     and "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<I>)"
     and "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@T')"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
       "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and P:
       "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ:
       "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and step: "list_all (transaction_check (FP, OCC, TI)) P"
   shows "\<exists>\<delta> \<in> abs_substs_fun ` set (transaction_check_comp (\<lambda>_ _. True) (FP, OCC, TI) T).
          \<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
             (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 = absc (\<delta> x) \<and>
             (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' = absc (absdbupd (unlabel (transaction_updates T)) x (\<delta> x))"
 proof -
   define comp0 where
     "comp0 \<equiv> abs_substs_fun ` set (transaction_check_comp (\<lambda>_ _. True) (FP, OCC, TI) T)"
   define check0 where "check0 \<equiv> transaction_check (FP, OCC, TI) T"
   define upd where "upd \<equiv> \<lambda>\<delta> x. absdbupd (unlabel (transaction_updates T)) x (\<delta> x)"
   define b0 where "b0 \<equiv> \<lambda>x. THE b. absc b = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0"
 
   note all_defs = comp0_def check0_def a0_def a0'_def upd_def b0_def \<theta>_def T'_def
 
   have \<A>_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     by (metis reachable_constraints_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s admissible_transactions_wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s P(1) \<A>_reach)
 
   have \<I>_interp: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>"
     and \<I>_wf_trms: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>)"
     by (metis \<I> welltyped_constraint_model_def constraint_model_def,
         metis \<I> welltyped_constraint_model_def,
         metis \<I> welltyped_constraint_model_def constraint_model_def)
 
   have \<I>_is_T_model: "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) (set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)) (unlabel T') \<I>"
     using \<I> unlabel_append[of \<A> T'] db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>" \<I> "[]"]
           strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "unlabel T'" \<I>]
     by (simp add: welltyped_constraint_model_def constraint_model_def db\<^sub>s\<^sub>s\<^sub>t_def)
 
   note T_adm = bspec[OF P(1) T]
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have T_no_bvars: "fv_transaction T = vars_transaction T" "bvars_transaction T = {}"
     using admissible_transaction_no_bvars[OF T_adm] by simp_all
 
   have T_vars_const_typed: "\<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
     and T_fresh_vars_value_typed: "\<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
     using T P protocol_transaction_vars_TAtom_typed(2,3)[of T] by simp_all
 
   note \<xi>_empty = admissible_transaction_decl_subst_empty[OF T_adm \<xi>]
 
   have wt_\<sigma>\<alpha>\<I>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>)" and wt_\<sigma>\<alpha>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using \<I>_wt wt_subst_compose transaction_decl_fresh_renaming_substs_wt[OF \<xi> \<sigma> \<alpha>]
     by (blast, blast)
 
   have T_vars_vals: "\<forall>x \<in> fv_transaction T. \<exists>n. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> = Fun (Val n) []"
   proof
     fix x assume x: "x \<in> fv_transaction T"
     have "\<exists>n. (\<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> = Fun (Val n) []"
     proof (cases "x \<in> subst_domain \<sigma>")
       case True
       then obtain n where "\<sigma> x = Fun (Val n) []"
         using transaction_fresh_subst_sends_to_val[OF \<sigma>]
               transaction_fresh_subst_domain[OF \<sigma>]
               T_fresh_vars_value_typed
         by metis
       thus ?thesis by (simp add: subst_compose_def)
     next
       case False
       hence *: "(\<sigma> \<circ>\<^sub>s \<alpha>) x = \<alpha> x" by (auto simp add: subst_compose_def)
       
       obtain y where y: "\<Gamma>\<^sub>v x = \<Gamma>\<^sub>v y" "\<alpha> x = Var y"
         using transaction_renaming_subst_wt[OF \<alpha>]
               transaction_renaming_subst_is_renaming(1)[OF \<alpha>]
         by (metis \<Gamma>.simps(1) prod.exhaust wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def)
       hence "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<sigma> \<circ>\<^sub>s \<alpha>)"
         using x * T_no_bvars(2) unlabel_subst[of "transaction_strand T" "\<sigma> \<circ>\<^sub>s \<alpha>"]
               fv\<^sub>s\<^sub>s\<^sub>t_subst_fv_subset[of x "unlabel (transaction_strand T)" "\<sigma> \<circ>\<^sub>s \<alpha>"]
         by auto
       hence "y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<sigma> \<circ>\<^sub>s \<alpha>))"
         using fv\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<sigma> \<circ>\<^sub>s \<alpha>"]
               fv\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] unlabel_append[of \<A>]
         by auto
       thus ?thesis
         using x y * T P (* T_vars_const_typed *)
               constraint_model_Value_term_is_Val[
                 OF reachable_constraints.step[OF \<A>_reach T \<xi> \<sigma> \<alpha>] \<I>[unfolded T'_def] P P_occ, of y]
               admissible_transaction_Value_vars[of T] \<xi>_empty
         by simp
     qed
     thus "\<exists>n. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> = Fun (Val n) []" using \<xi>_empty by simp
   qed
 
   have T_vars_absc: "\<forall>x \<in> fv_transaction T. \<exists>!n. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 = absc n"
     using T_vars_vals by fastforce
   hence "(absc \<circ> b0) x = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0" when "x \<in> fv_transaction T" for x
     using that unfolding b0_def by fastforce
   hence T_vars_absc': "t \<cdot> (absc \<circ> b0) = t \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0"
     when "fv t \<subseteq> fv_transaction T" "\<nexists>n T. Fun (Val n) T \<in> subterms t" for t
     using that(1) abs_term_subst_eq'[OF _ that(2), of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>" a0 "absc \<circ> b0"]
           subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I>] subst_subst_compose[of t "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I>]
     by fastforce
 
   have "\<exists>\<delta> \<in> comp0. \<forall>x \<in> fv_transaction T. fst x = TAtom Value \<longrightarrow> b0 x = \<delta> x"
   proof -
     let ?C = "set (unlabel (transaction_checks T))"
     let ?xs = "fv_transaction T - set (transaction_fresh T)"
 
     note * = transaction_prop3[OF \<A>_reach T \<I>[unfolded T'_def] \<xi> \<sigma> \<alpha> FP OCC TI P P_occ]
 
     have **:
         "\<forall>x \<in> set (transaction_fresh T). b0 x = {}"
         "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> b0)"
           (is ?B)
     proof -
       show ?B
       proof (intro ballI impI)
         fix t assume t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)"
         hence t': "fv t \<subseteq> fv_transaction T" "\<nexists>n T. Fun (Val n) T \<in> subterms t"
           using trms_transaction_unfold[of T] vars_transaction_unfold[of T]
                 trms\<^sub>s\<^sub>s\<^sub>t_fv_vars\<^sub>s\<^sub>s\<^sub>t_subset[of t "unlabel (transaction_strand T)"]
                 admissible_transactions_no_Value_consts'[OF T_adm]
                 wellformed_transaction_send_receive_fv_subset(1)[OF T_wf t(1)]
           by blast+
         
         have "intruder_synth_mod_timpls FP TI (t \<cdot> (absc \<circ> b0))"
           using t(1) t' *(2) T_vars_absc'
           by (metis a0_def)
         moreover have "(absc \<circ> b0) x = (\<theta> b0) x" when "x \<in> fv t" for x
           using that T P admissible_transaction_Value_vars[of T]
                 \<open>fv t \<subseteq> fv_transaction T\<close> \<Gamma>\<^sub>v_TAtom''(2)[of x]
           unfolding \<theta>_def by fastforce
         hence "t \<cdot> (absc \<circ> b0) = t \<cdot> \<theta> b0"
           using term_subst_eq[of t "absc \<circ> b0" "\<theta> b0"] by argo
         ultimately show "intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> b0)"
           using intruder_synth.simps[of "set FP"] by (cases "t \<cdot> \<theta> b0") metis+
       qed
     qed (simp add: *(1) a0_def b0_def)
 
     have ***: "\<forall>x \<in> ?xs. \<forall>s. select\<langle>Var x,Fun (Set s) []\<rangle> \<in> ?C \<longrightarrow> s \<in> b0 x"
               "\<forall>x \<in> ?xs. \<forall>s. \<langle>Var x in Fun (Set s) []\<rangle> \<in> ?C \<longrightarrow> s \<in> b0 x"
               "\<forall>x \<in> ?xs. \<forall>s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> ?C \<longrightarrow> s \<notin> b0 x"
               "\<forall>x \<in> ?xs. fst x = TAtom Value \<longrightarrow> b0 x \<in> set OCC"
       unfolding a0_def b0_def
       using *(3,4) apply (force, force)
       using *(5) apply force
       using *(6) admissible_transaction_Value_vars[OF bspec[OF P T]] by force
 
     show ?thesis
       using transaction_check_comp_in[OF T_adm **[unfolded \<theta>_def] ***]
       unfolding comp0_def
       by metis
   qed
   hence 1: "\<exists>\<delta> \<in> comp0. \<forall>x \<in> fv_transaction T.
               fst x = TAtom Value \<longrightarrow> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 = absc (\<delta> x)"
     using T_vars_absc unfolding b0_def a0_def by fastforce
 
   obtain \<delta> where \<delta>:
       "\<delta> \<in> comp0"
       "\<forall>x \<in> fv_transaction T. fst x = TAtom Value \<longrightarrow> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 = absc (\<delta> x)"
-    using 1 by moura
+    using 1 by force
 
   have 2: "\<theta> x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) = absc (absdbupd (unlabel A) x d)"
     when "\<theta> x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 D = absc d"
     and "\<forall>t u. insert\<langle>t,u\<rangle> \<in> set (unlabel A) \<longrightarrow> (\<exists>y s. t = Var y \<and> u = Fun (Set s) [])"
     and "\<forall>t u. delete\<langle>t,u\<rangle> \<in> set (unlabel A) \<longrightarrow> (\<exists>y s. t = Var y \<and> u = Fun (Set s) [])"
     and "\<forall>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \<theta> x \<cdot> \<I> = \<theta> y \<cdot> \<I> \<longrightarrow> x = y"
     and "\<forall>y \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \<exists>n. \<theta> y \<cdot> \<I> = Fun (Val n) []"
     and x: "\<theta> x \<cdot> \<I> = Fun (Val n) []"
     and D: "\<forall>d \<in> set D. \<exists>s. snd d = Fun (Set s) []"
     for A::"('fun,'atom,'sets,'lbl) prot_strand" and x \<theta> D n d
     using that(2,3,4,5)
   proof (induction A rule: List.rev_induct)
     case (snoc a A)
     then obtain l b where a: "a = (l,b)" by (metis surj_pair)
 
     have IH: "\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n = absdbupd (unlabel A) x d"
       using snoc unlabel_append[of A "[a]"] a x
       by (simp del: unlabel_append)
 
     have b_prems: "\<forall>y \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p b. \<theta> x \<cdot> \<I> = \<theta> y \<cdot> \<I> \<longrightarrow> x = y"
                   "\<forall>y \<in> fv\<^sub>s\<^sub>s\<^sub>t\<^sub>p b. \<exists>n. \<theta> y \<cdot> \<I> = Fun (Val n) []"
       using snoc.prems(3,4) a by (simp_all add: unlabel_def)
 
     have *: "filter is_Update (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))) =
              filter is_Update (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)))"
             "filter is_Update (unlabel (A@[a])) = filter is_Update (unlabel A)"
       when "\<not>is_Update b"
       using that a
       by (cases b, simp_all add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def unlabel_def subst_apply_labeled_stateful_strand_def)+
 
     note ** = IH a dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_append[of A "[a]" \<theta>]
 
     note *** = * absdbupd_filter[of "unlabel (A@[a])"]
                absdbupd_filter[of "unlabel A"]
                db\<^sub>s\<^sub>s\<^sub>t_filter[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"]
                db\<^sub>s\<^sub>s\<^sub>t_filter[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"]
 
     note **** = **(2,3) dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_snoc[of A a \<theta>]
                 unlabel_append[of "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>" "[dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]"]
                 db\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)" "unlabel [dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>]" \<I> D]
 
     have "\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n = absdbupd (unlabel (A@[a])) x d" using ** ***
     proof (cases b)
       case (Insert t t')
       then obtain y s m where y: "t = Var y" "t' = Fun (Set s) []" "\<theta> y \<cdot> \<I> = Fun (Val m) []"
         using snoc.prems(1) b_prems(2) a by (fastforce simp add: unlabel_def)
       hence a': "db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D =
                  List.insert ((Fun (Val m) [], Fun (Set s) [])) (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<I> D)"
                 "unlabel [dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>] = [insert\<langle>\<theta> y, Fun (Set s) []\<rangle>]"
                 "unlabel [a] = [insert\<langle>Var y, Fun (Set s) []\<rangle>]"
         using **** Insert by simp_all
 
       show ?thesis
       proof (cases "x = y")
         case True
         hence "\<theta> x \<cdot> \<I> = \<theta> y \<cdot> \<I>" by simp
         hence "\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n =
                insert s (\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n)"
           by (metis (no_types, lifting) y(3) a'(1) x dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst to_abs_list_insert')
         thus ?thesis using True IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
       next
         case False
         hence "\<theta> x \<cdot> \<I> \<noteq> \<theta> y \<cdot> \<I>" using b_prems(1) y Insert by simp
         hence "\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n = \<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n"
           by (metis (no_types, lifting) y(3) a'(1) x dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst to_abs_list_insert)
         thus ?thesis using False IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
       qed
     next
       case (Delete t t')
       then obtain y s m where y: "t = Var y" "t' = Fun (Set s) []" "\<theta> y \<cdot> \<I> = Fun (Val m) []"
         using snoc.prems(2) b_prems(2) a by (fastforce simp add: unlabel_def)
       hence a': "db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D =
                  List.removeAll ((Fun (Val m) [], Fun (Set s) [])) (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<I> D)"
                 "unlabel [dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>] = [delete\<langle>\<theta> y, Fun (Set s) []\<rangle>]"
                 "unlabel [a] = [delete\<langle>Var y, Fun (Set s) []\<rangle>]"
         using **** Delete by simp_all
 
       have "\<exists>s S. snd d = Fun (Set s) []" when "d \<in> set (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<I> D)" for d
         using snoc.prems(1,2) db\<^sub>l\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_set_ex[OF that _ _ D] by (simp add: unlabel_def)
       moreover {
         fix t::"('fun,'atom,'sets,'lbl) prot_term"
           and D::"(('fun,'atom,'sets,'lbl) prot_term \<times> ('fun,'atom,'sets,'lbl) prot_term) list"
         assume "\<forall>d \<in> set D. \<exists>s. snd d = Fun (Set s) []"
         hence "removeAll (t, Fun (Set s) []) D = filter (\<lambda>d. \<nexists>S. d = (t, Fun (Set s) S)) D"
           by (induct D) auto
       } ultimately have a'':
           "List.removeAll ((Fun (Val m) [], Fun (Set s) [])) (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<I> D) =
            filter (\<lambda>d. \<nexists>S. d = (Fun (Val m) [], Fun (Set s) S)) (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<I> D)"
         by simp
 
       show ?thesis
       proof (cases "x = y")
         case True
         hence "\<theta> x \<cdot> \<I> = \<theta> y \<cdot> \<I>" by simp
         hence "\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n =
                (\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n) - {s}"
           using y(3) a'' a'(1) x by (simp add: dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst to_abs_list_remove_all')
         thus ?thesis using True IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
       next
         case False
         hence "\<theta> x \<cdot> \<I> \<noteq> \<theta> y \<cdot> \<I>" using b_prems(1) y Delete by simp
         hence "\<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[a] \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n = \<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<I> D) n"
           by (metis (no_types, lifting) y(3) a'(1) x dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst to_abs_list_remove_all)
         thus ?thesis using False IH a'(3) absdbupd_append[of "unlabel A"] by (simp add: unlabel_def)
       qed
     qed simp_all
     thus ?case by (simp add: x)
   qed (simp add: that(1))
 
   have 3: "x = y"
     when xy: "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I>" "x \<in> fv_transaction T" "y \<in> fv_transaction T"
     for x y
   proof -
     have "x \<notin> set (transaction_fresh T) \<Longrightarrow> y \<notin> set (transaction_fresh T) \<Longrightarrow> ?thesis"
       using xy admissible_transaction_strand_sem_fv_ineq[OF T_adm \<I>_is_T_model[unfolded T'_def]]
       by fast
     moreover {
       assume *: "x \<in> set (transaction_fresh T)" "y \<in> set (transaction_fresh T)"
       hence "\<Gamma>\<^sub>v x = TAtom Value" "\<Gamma>\<^sub>v y = TAtom Value"
         using T_fresh_vars_value_typed by (blast, blast)
       then obtain xn yn where "\<sigma> x = Fun (Val xn) []" "\<sigma> y = Fun (Val yn) []"
         using * transaction_fresh_subst_sends_to_val[OF \<sigma>] by meson
       hence "\<sigma> x = \<sigma> y" using that(1) \<xi>_empty by (simp add: subst_compose)
       moreover have "inj_on \<sigma> (subst_domain \<sigma>)" "x \<in> subst_domain \<sigma>" "y \<in> subst_domain \<sigma>"
         using * \<sigma> unfolding transaction_fresh_subst_def by auto
       ultimately have ?thesis unfolding inj_on_def by blast
     } moreover have False when "x \<in> set (transaction_fresh T)" "y \<notin> set (transaction_fresh T)"
       using that(2) xy T_no_bvars admissible_transaction_Value_vars[OF bspec[OF P T], of y]
             transaction_prop4[OF \<A>_reach T \<I>[unfolded T'_def] \<xi> \<sigma> \<alpha> P P_occ that(1), of y]
       by auto
     moreover have False when "x \<notin> set (transaction_fresh T)" "y \<in> set (transaction_fresh T)"
       using that(1) xy T_no_bvars admissible_transaction_Value_vars[OF bspec[OF P T], of x]
             transaction_prop4[OF \<A>_reach T \<I>[unfolded T'_def] \<xi> \<sigma> \<alpha> P P_occ that(2), of x]
       by fastforce
     ultimately show ?thesis by metis
   qed
 
   have 4: "\<exists>y s. t = Var y \<and> u = Fun (Set s) []"
     when "insert\<langle>t,u\<rangle> \<in> set (unlabel (transaction_strand T))" for t u
     using that admissible_transaction_strand_step_cases(3)[OF T_adm] T_wf
     by blast
 
   have 5: "\<exists>y s. t = Var y \<and> u = Fun (Set s) []"
     when "delete\<langle>t,u\<rangle> \<in> set (unlabel (transaction_strand T))" for t u
     using that admissible_transaction_strand_step_cases(3)[OF T_adm] T_wf
     by blast
 
   have 6: "\<exists>n. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) y \<cdot> \<I> = Fun (Val n) []" when "y \<in> fv_transaction T" for y
     using that by (simp add: T_vars_vals)
 
   have "list_all wellformed_transaction P" "list_all admissible_transaction_updates P"
     using P(1) Ball_set[of P admissible_transaction'] Ball_set[of P wellformed_transaction]
           Ball_set[of P admissible_transaction_updates]
           admissible_transaction_is_wellformed_transaction(1,3)
     by fastforce+
   hence 7: "\<exists>s. snd d = Fun (Set s) []" when "d \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)" for d
     using that reachable_constraints_db\<^sub>l\<^sub>s\<^sub>s\<^sub>t_set_args_empty[OF \<A>_reach]
     unfolding admissible_transaction_updates_def by (cases d) simp
 
   have "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' = absc (upd \<delta> x)"
     when x: "x \<in> fv_transaction T" "fst x = TAtom Value" for x
   proof -
     have "(\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I> (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>))
            = absc (absdbupd (unlabel (transaction_strand T)) x (\<delta> x))"
       using 2[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" x "db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>" "\<delta> x" "transaction_strand T"]
             3[OF _ x(1)] 4 5 6[OF that(1)] 6 7 x \<delta>(2)
       unfolding all_defs by blast
     thus ?thesis
       using x db\<^sub>s\<^sub>s\<^sub>t_append[of "unlabel \<A>"] absdbupd_wellformed_transaction[OF T_wf]
       unfolding all_defs db\<^sub>s\<^sub>s\<^sub>t_def by force
   qed
   thus ?thesis using \<delta> \<Gamma>\<^sub>v_TAtom''(2) unfolding all_defs by blast
 qed
 
 lemma transaction_prop6:
   fixes T \<xi> \<sigma> \<alpha> \<A> \<I> T' a0 a0'
   defines "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     and "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
     and "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<I>)"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@T')"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
       "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and P:
       "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ:
       "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and step: "list_all (transaction_check (FP, OCC, TI)) P"
   shows "\<forall>t \<in> timpl_closure_set (\<alpha>\<^sub>i\<^sub>k \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>).
           timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t" (is ?A)
     and "timpl_closure_set (\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>) \<subseteq> absc ` set OCC" (is ?B)
     and "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T). is_Fun (t \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0') \<longrightarrow>
           timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0'" (is ?C)
     and "\<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
           (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> absc ` set OCC" (is ?D)
 proof -
   define comp0 where
     "comp0 \<equiv> abs_substs_fun ` set (transaction_check_comp (\<lambda>_ _. True) (FP, OCC, TI) T)"
   define check0 where "check0 \<equiv> transaction_check (FP, OCC, TI) T"
 
   define upd where "upd \<equiv> \<lambda>\<delta> x. absdbupd (unlabel (transaction_updates T)) x (\<delta> x)"
 
   define \<theta> where "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
 
   note T_adm = bspec[OF P T]
   note T_occ = bspec[OF P_occ T]
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have \<theta>_prop: "\<theta> \<sigma> x = absc (\<sigma> x)" when "\<Gamma>\<^sub>v x = TAtom Value" for \<sigma> x
     using that \<Gamma>\<^sub>v_TAtom''(2)[of x] unfolding \<theta>_def by simp
 
    \<comment> \<open>The set-membership status of all value constants in T under \<open>\<I>\<close>, \<open>\<sigma>\<close>, \<open>\<alpha>\<close> are covered by the check\<close>
   have 0: "\<exists>\<delta> \<in> comp0. \<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
             (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 = absc (\<delta> x) \<and>
             (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' = absc (upd \<delta> x)"
     using transaction_prop5[OF \<A>_reach T \<I>[unfolded T'_def] \<xi> \<sigma> \<alpha> FP OCC TI P P_occ step]
     unfolding a0_def a0'_def T'_def upd_def comp0_def
     by blast
 
   \<comment> \<open>All set-membership changes are covered by the term implication graph\<close>
   have 1: "(\<delta> x, upd \<delta> x) \<in> (set TI)\<^sup>+"
     when "\<delta> \<in> comp0" "\<delta> x \<noteq> upd \<delta> x" "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
     for x \<delta> 
     using T that step Ball_set[of P "transaction_check (FP, OCC, TI)"]
           transaction_prop1[of \<delta> "\<lambda>_ _. True" FP OCC TI T x] TI
     unfolding upd_def comp0_def transaction_check_def
     by blast
 
   \<comment> \<open>All set-membership changes are covered by the fixed point\<close>
   have 2: (* "\<delta> x \<in> set OCC" *) "upd \<delta> x \<in> set OCC"
     when "\<delta> \<in> comp0" "x \<in> fv_transaction T" "fst x = TAtom Value" for x \<delta>
     using T that step Ball_set[of P "transaction_check (FP, OCC, TI)"]
           T_adm T_occ FP OCC TI transaction_prop2[of \<delta> "\<lambda>_ _. True" FP OCC TI T x]
     unfolding upd_def comp0_def transaction_check_def
     by blast
   
   obtain \<delta> where \<delta>:
       "\<delta> \<in> comp0"
       "\<forall>x \<in> fv_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<longrightarrow>
         (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 = absc (\<delta> x) \<and>
         (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' = absc (upd \<delta> x)"
-    using 0 by moura
+    using 0 by force
 
   have "\<exists>x. ab = (\<delta> x, upd \<delta> x) \<and> x \<in> fv_transaction T - set (transaction_fresh T) \<and> \<delta> x \<noteq> upd \<delta> x"
     when ab: "ab \<in> \<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>" for ab
   proof -
     obtain a b where ab': "ab = (a,b)" by (metis surj_pair)
     then obtain x where x:
         "a \<noteq> b" "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
         "absc a = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0" "absc b = (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) x \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0'"
       using ab unfolding abs_term_implications_def a0_def a0'_def T'_def by blast
     hence "absc a = absc (\<delta> x)" "absc b = absc (upd \<delta> x)"
       using \<delta>(2) admissible_transaction_Value_vars[OF bspec[OF P T] x(2)]
       by metis+
     thus ?thesis using x ab' by blast
   qed
   hence \<alpha>\<^sub>t\<^sub>i_TI_subset: "\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I> \<subseteq> {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}" using 1[OF \<delta>(1)] by blast
   
   have "timpl_closure_set (timpl_closure_set (set FP) (set TI)) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>) \<turnstile>\<^sub>c t"
     when t: "t \<in> timpl_closure_set (\<alpha>\<^sub>i\<^sub>k \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)" for t
     using timpl_closure_set_is_timpl_closure_union[of "\<alpha>\<^sub>i\<^sub>k \<A> \<I>" "\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"]
           intruder_synth_timpl_closure_set FP(3) t
     by blast
   thus ?A
     using ideduct_synth_mono[OF _ timpl_closure_set_mono[OF
             subset_refl[of "timpl_closure_set (set FP) (set TI)"]
             \<alpha>\<^sub>t\<^sub>i_TI_subset]]
           timpl_closure_set_timpls_trancl_eq'[of "timpl_closure_set (set FP) (set TI)" "set TI"]
     unfolding timpl_closure_set_idem
     by force
 
   have "timpl_closure_set (\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>) \<subseteq>
         timpl_closure_set (absc ` set OCC) {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     using timpl_closure_set_mono[OF _ \<alpha>\<^sub>t\<^sub>i_TI_subset] OCC(3) by blast
   thus ?B using OCC(2) timpl_closure_set_timpls_trancl_subset' by blast
 
   have "transaction_check_post (FP, OCC, TI) T \<delta>"
     using T \<delta>(1) step
     unfolding transaction_check_def transaction_check'_def comp0_def list_all_iff
     by fastforce
   hence 3: "timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t \<cdot> \<theta> (upd \<delta>)"
     when "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "is_Fun (t \<cdot> \<theta> (upd \<delta>))" for t
     using that
     unfolding transaction_check_post_def upd_def \<theta>_def
               intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI, symmetric]
     by fastforce
 
   have 4: "\<forall>x \<in> fv t. (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>) x \<cdot>\<^sub>\<alpha> a0' = \<theta> (upd \<delta>) x"
     when "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" for t
     using wellformed_transaction_send_receive_fv_subset(2)[OF T_wf that]
           \<delta>(2) subst_compose[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I>] \<theta>_prop
           admissible_transaction_Value_vars[OF bspec[OF P T]]
     by fastforce
   
   have 5: "\<nexists>n T. Fun (Val n) T \<in> subterms t" when "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" for t
     using that admissible_transactions_no_Value_consts'[OF T_adm] trms_transaction_unfold[of T]
     by blast
 
   show ?D using 2[OF \<delta>(1)] \<delta>(2) \<Gamma>\<^sub>v_TAtom''(2) unfolding a0'_def T'_def by blast
 
   show ?C using 3 abs_term_subst_eq'[OF 4 5] by simp
 qed
 
 lemma reachable_constraints_covered_step:
   fixes \<A>::"('fun,'atom,'sets,'lbl) prot_constr"
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and T: "T \<in> set P"
     and \<I>: "welltyped_constraint_model \<I> (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>))"
     and \<xi>: "transaction_decl_subst \<xi> T"
     and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
     and FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
       "ground (set FP)"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
       "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and P:
       "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ:
       "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and transactions_covered: "list_all (transaction_check (FP, OCC, TI)) P"
   shows "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I>.
           timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t" (is ?A)
     and "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s (\<A>@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) \<I> \<subseteq> absc ` set OCC" (is ?B)
 proof -
   note step_props =
     transaction_prop6[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> FP(1,2,3) OCC TI P P_occ transactions_covered]
 
   define T' where "T' \<equiv> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define a0 where "a0 \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>)"
   define a0' where "a0' \<equiv> \<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (\<A>@T') \<I>)"
 
   define vals where "vals \<equiv> \<lambda>S::('fun,'atom,'sets,'lbl) prot_constr.
       {t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>. \<exists>n. t = Fun (Val n) []}"
 
   define vals_sym where "vals_sym \<equiv> \<lambda>S::('fun,'atom,'sets,'lbl) prot_constr.
       {t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t S). (\<exists>n. t = Fun (Val n) []) \<or> (\<exists>m. t = Var (TAtom Value,m))}"
 
   have \<I>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>" by (metis \<I> welltyped_constraint_model_def)
 
   have \<I>_grounds: "fv (t \<cdot> \<I>) = {}" for t
     using \<I> interpretation_grounds[of \<I>]
     unfolding welltyped_constraint_model_def constraint_model_def by auto
 
   have wt_\<sigma>\<alpha>\<I>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>)" and wt_\<sigma>\<alpha>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     using \<I>_wt wt_subst_compose transaction_decl_fresh_renaming_substs_wt[OF \<xi> \<sigma> \<alpha>]
     by (blast, blast)
 
   have "\<forall>T\<in>set P. bvars_transaction T = {}"
     using P admissible_transactionE(4) by metis
   hence \<A>_no_bvars: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> = {}"
     using reachable_constraints_no_bvars[OF \<A>_reach] by metis
 
   have \<I>_vals: "\<exists>n. \<I> (TAtom Value, m) = Fun (Val n) []"
     when "(TAtom Value, m) \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" for m
     using constraint_model_Value_term_is_Val'[
             OF \<A>_reach welltyped_constraint_model_prefix[OF \<I>] P P_occ]
           \<A>_no_bvars vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel \<A>"] that
     by blast
 
   have vals_sym_vals: "t \<cdot> \<I> \<in> vals \<A>" when t: "t \<in> vals_sym \<A>" for t
   proof (cases t)
     case (Var x)
     then obtain m where *: "x = (TAtom Value,m)" using t unfolding vals_sym_def by blast
     moreover have "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" using t unfolding vals_sym_def by blast
     hence "t \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "\<exists>n. \<I> (Var Value, m) = Fun (Val n) []"
       using Var * \<I>_vals[of m] var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t[of x "unlabel \<A>"]
             \<Gamma>\<^sub>v_TAtom[of Value m] reachable_constraints_Value_vars_are_fv[OF \<A>_reach P(1), of x]
       by blast+
     ultimately show ?thesis using Var unfolding vals_def by auto
   next
     case (Fun f T)
     then obtain n where "f = Val n" "T = []" using t unfolding vals_sym_def by blast
     moreover have "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" using t unfolding vals_sym_def by blast
     hence "t \<cdot> \<I> \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" using Fun by blast
     ultimately show ?thesis using Fun unfolding vals_def by auto
   qed
 
   have vals_vals_sym: "\<exists>s. s \<in> vals_sym \<A> \<and> t = s \<cdot> \<I>" when "t \<in> vals \<A>" for t
     using that constraint_model_Val_is_Value_term[OF \<I>]
     unfolding vals_def vals_sym_def by fast
 
   note T_adm = bspec[OF P T]
   note T_wf = admissible_transaction_is_wellformed_transaction(1)[OF T_adm]
 
   have 0:
       "\<alpha>\<^sub>i\<^sub>k (\<A>@T') \<I> = (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0' \<union> (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0'"
       "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s (\<A>@T') \<I> = vals \<A> \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0' \<union> vals T' \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0'"
     by (metis abs_intruder_knowledge_append a0'_def,
         metis abs_value_constants_append[of \<A> T' \<I>] a0'_def vals_def)
 
   have 1: "(ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t T' \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0' =
            (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0'"
     by (metis T'_def dual_transaction_ik_is_transaction_send''[OF T_wf])
 
   have 2: "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<inter> subst_domain \<xi> = {}"
           "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<inter> subst_domain \<sigma> = {}"
           "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<inter> subst_domain \<alpha> = {}"
     using admissible_transactionE(4)[OF T_adm] by blast+
 
   have "vals T' \<subseteq> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` fv_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
   proof
     fix t assume "t \<in> vals T'"
     then obtain s n where s:
         "s \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t T')" "t = s \<cdot> \<I>" "t = Fun (Val n) []"
       unfolding vals_def by fast
     then obtain u where u:
         "u \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))"
         "s = u \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
       using transaction_decl_fresh_renaming_substs_trms[OF \<xi> \<sigma> \<alpha> 2]
             trms\<^sub>s\<^sub>s\<^sub>t_unlabel_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_eq[of "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
       unfolding T'_def by blast
 
     have *: "t = u \<cdot> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>)" using s(2) u(2) subst_subst_compose by simp
     then obtain x where x: "u = Var x"
       using s(3) admissible_transactions_no_Value_consts(1)[OF T_adm u(1)] by (cases u) force+
     hence **: "x \<in> vars_transaction T"
       by (metis u(1) var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t)
 
     have "\<Gamma>\<^sub>v x = TAtom Value"
       using * x s(3) wt_subst_trm''[OF wt_\<sigma>\<alpha>\<I>, of u]
       by simp
     thus "t \<in> (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` fv_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
       using admissible_transaction_Value_vars_are_fv[OF T_adm **] x *
             eval_term.simps(1)[of _ x "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s \<I>"]
             subst_comp_set_image[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" \<I> "fv_transaction T"]
       by blast
   qed
   hence 3: "vals T' \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0' \<subseteq> ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` fv_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0'"
     by (simp add: abs_apply_terms_def image_mono)
 
   have "t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set (\<alpha>\<^sub>i\<^sub>k \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
     when "t \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>" for t
     using that abs_in[OF imageI[OF that]]
           \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_ik[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ]
           timpl_closure_set_mono[of "{t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0}" "\<alpha>\<^sub>i\<^sub>k \<A> \<I>" "\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"
                                     "\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"]
     unfolding a0_def a0'_def T'_def abs_intruder_knowledge_def by fast
   hence A: "\<alpha>\<^sub>i\<^sub>k (\<A>@T') \<I> \<subseteq>
               timpl_closure_set (\<alpha>\<^sub>i\<^sub>k \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>) \<union>
               (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0'"
     using 0(1) 1 by (auto simp add: abs_apply_terms_def)
 
   have "t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set {t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0} (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
     when t: "t \<in> vals_sym \<A>" for t
   proof -
     have "(\<exists>n. t = Fun (Val n) [] \<and> t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)) \<or>
           (\<exists>n. t = Var (TAtom Value,n) \<and> (TAtom Value,n) \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)"
       (is "?P \<or> ?Q")
       using t var_subterm_trms\<^sub>s\<^sub>s\<^sub>t_is_vars\<^sub>s\<^sub>s\<^sub>t[of _ "unlabel \<A>"]
             \<Gamma>\<^sub>v_TAtom[of Value] reachable_constraints_Value_vars_are_fv[OF \<A>_reach P(1)]
       unfolding vals_sym_def by fast
     thus ?thesis
     proof
       assume ?P
-      then obtain n where n: "t = Fun (Val n) []" "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" by moura
+      then obtain n where n: "t = Fun (Val n) []" "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>)" by force
       thus ?thesis 
         using \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_Val[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ, of n]
         unfolding a0_def a0'_def T'_def by fastforce
     next
       assume ?Q
       thus ?thesis
         using \<alpha>\<^sub>t\<^sub>i_covers_\<alpha>\<^sub>0_Var[OF \<A>_reach T \<I> \<xi> \<sigma> \<alpha> P P_occ]
         unfolding a0_def a0'_def T'_def by fastforce
     qed
   qed
   moreover have "t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0 \<in> \<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>"
     when "t \<in> vals_sym \<A>" for t
     using that abs_in vals_sym_vals
     unfolding a0_def abs_value_constants_def vals_sym_def vals_def
     by (metis (mono_tags, lifting))
   ultimately have "t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set (\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
     when t: "t \<in> vals_sym \<A>" for t
     using t timpl_closure_set_mono[of "{t \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0}" "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>" "\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"
                                       "\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>"]
     by blast
   hence "t \<cdot>\<^sub>\<alpha> a0' \<in> timpl_closure_set (\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>)"
     when t: "t \<in> vals \<A>" for t
     using vals_vals_sym[OF t] by blast
   hence B: "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s (\<A>@T') \<I> \<subseteq>
               timpl_closure_set (\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I>) (\<alpha>\<^sub>t\<^sub>i \<A> T (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) \<I>) \<union>
               ((\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) ` fv_transaction T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a0'"
     using 0(2) 3
     by (simp add: abs_apply_terms_def image_subset_iff)
 
   have 4: "fv (t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I> \<cdot>\<^sub>\<alpha> a) = {}" for t a
     using \<I>_grounds[of "t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] abs_fv[of "t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I>" a]
     by argo
 
   have "is_Fun (t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<cdot> \<I> \<cdot>\<^sub>\<alpha> a0')" for t
     using 4[of t a0'] by force
   thus ?A
     using A step_props(1,3)
     unfolding T'_def a0_def a0'_def abs_apply_terms_def
     by blast
 
   show ?B
     using B step_props(2,4) admissible_transaction_Value_vars[OF bspec[OF P T]]
     by (auto simp add: T'_def a0_def a0'_def abs_apply_terms_def)
 qed
 
 lemma reachable_constraints_covered:
   assumes \<A>_reach: "\<A> \<in> reachable_constraints P"
     and \<I>: "welltyped_constraint_model \<I> \<A>"
     and FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "ground (set FP)"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and P:
       "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ:
       "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and transactions_covered: "list_all (transaction_check (FP, OCC, TI)) P"
   shows "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
     and "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
 using \<A>_reach \<I>
 proof (induction rule: reachable_constraints.induct)
   case init
   { case 1 show ?case by (simp add: abs_intruder_knowledge_def) }
   { case 2 show ?case by (simp add: abs_value_constants_def) }
 next
   case (step \<A> T \<xi> \<sigma> \<alpha>)
   { case 1
     hence "welltyped_constraint_model \<I> \<A>"
       by (metis welltyped_constraint_model_prefix)
     hence IH: "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
               "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
       using step.IH by metis+
     show ?case
       using reachable_constraints_covered_step[
               OF step.hyps(1,2) "1.prems" step.hyps(3-5) FP(1,2) IH(1)
                  FP(3) OCC IH(2) TI P P_occ transactions_covered]
       by metis
   }
   { case 2
     hence "welltyped_constraint_model \<I> \<A>"
       by (metis welltyped_constraint_model_prefix)
     hence IH: "\<forall>t \<in> \<alpha>\<^sub>i\<^sub>k \<A> \<I>. timpl_closure_set (set FP) (set TI) \<turnstile>\<^sub>c t"
               "\<alpha>\<^sub>v\<^sub>a\<^sub>l\<^sub>s \<A> \<I> \<subseteq> absc ` set OCC"
       using step.IH by metis+
     show ?case
       using reachable_constraints_covered_step[
               OF step.hyps(1,2) "2.prems" step.hyps(3-5) FP(1,2) IH(1)
                  FP(3) OCC IH(2) TI P P_occ transactions_covered]
       by metis
   }
 qed
 
 lemma attack_in_fixpoint_if_attack_in_ik:
   fixes FP::"('fun,'atom,'sets,'lbl) prot_terms"
   assumes "\<forall>t \<in> IK \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a. FP \<turnstile>\<^sub>c t"
     and "attack\<langle>n\<rangle> \<in> IK"
   shows "attack\<langle>n\<rangle> \<in> FP"
 proof -
   have "attack\<langle>n\<rangle> \<cdot>\<^sub>\<alpha> a \<in> IK \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a" by (rule abs_in[OF assms(2)])
   hence "FP \<turnstile>\<^sub>c attack\<langle>n\<rangle> \<cdot>\<^sub>\<alpha> a" using assms(1) by blast
   moreover have "attack\<langle>n\<rangle> \<cdot>\<^sub>\<alpha> a = attack\<langle>n\<rangle>" by simp
   ultimately have "FP \<turnstile>\<^sub>c attack\<langle>n\<rangle>" by metis
   thus ?thesis using ideduct_synth_priv_const_in_ik[of FP "Attack n"] by simp
 qed
 
 lemma attack_in_fixpoint_if_attack_in_timpl_closure_set:
   fixes FP::"('fun,'atom,'sets,'lbl) prot_terms"
   assumes "attack\<langle>n\<rangle> \<in> timpl_closure_set FP TI"
   shows "attack\<langle>n\<rangle> \<in> FP"
 proof -
   have "\<forall>f \<in> funs_term (attack\<langle>n\<rangle>). \<not>is_Abs f" by auto
   thus ?thesis using timpl_closure_set_no_Abs_in_set[OF assms] by blast
 qed
 
 theorem prot_secure_if_fixpoint_covered_typed:
   assumes FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "ground (set FP)"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and P:
       "\<forall>T \<in> set P. admissible_transaction T"
       "has_initial_value_producing_transaction P"
     and transactions_covered: "list_all (transaction_check (FP, OCC, TI)) (map add_occurs_msgs P)"
     and attack_notin_FP: "attack\<langle>n\<rangle> \<notin> set FP"
     and \<A>: "\<A> \<in> reachable_constraints P"
   shows "\<nexists>\<I>. welltyped_constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])" (is "\<nexists>\<I>. ?Q \<I>")
 proof
   assume "\<exists>\<I>. ?Q \<I>"
   then obtain \<I> \<B> where
         \<B>: "\<B> \<in> reachable_constraints (map add_occurs_msgs P)"
     and \<I>: "welltyped_constraint_model \<I> (\<B>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
     using add_occurs_msgs_soundness[OF P \<A>]
     unfolding list_all_iff by blast
 
   have P':
       "\<forall>T \<in> set (map add_occurs_msgs P). admissible_transaction' T"
       "\<forall>T \<in> set (map add_occurs_msgs P). admissible_transaction_occurs_checks T"
     using P add_occurs_msgs_admissible_occurs_checks[OF admissible_transactionE'(1)] by auto
 
   have 0: "attack\<langle>n\<rangle> \<notin> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>"
     using welltyped_constraint_model_prefix[OF \<I>]
           reachable_constraints_covered(1)[OF \<B> _ FP OCC TI P' transactions_covered]
           attack_in_fixpoint_if_attack_in_ik[
             of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>" "\<alpha>\<^sub>0 (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<I>)" "timpl_closure_set (set FP) (set TI)" n]
           attack_in_fixpoint_if_attack_in_timpl_closure_set
           attack_notin_FP
     unfolding abs_intruder_knowledge_def by blast
 
   have 1: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<B> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> attack\<langle>n\<rangle>"
     using \<I> strand_sem_append_stateful[of "{}" "{}" "unlabel \<B>" _ \<I>]
     unfolding welltyped_constraint_model_def constraint_model_def by force
 
   show False
     using 0 private_const_deduct[OF _ 1]
           reachable_constraints_receive_attack_if_attack'(1)[
             OF \<B> P'(1) welltyped_constraint_model_prefix[OF \<I>] 1]
     by simp
 qed
 
 end
 
 
 subsection \<open>Theorem: A Protocol is Secure if it is Covered by a Fixed-Point\<close>
 context stateful_protocol_model
 begin
 
 theorem prot_secure_if_fixpoint_covered:
   fixes P
   assumes FP:
       "analyzed (timpl_closure_set (set FP) (set TI))"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
       "ground (set FP)"
     and OCC:
       "\<forall>t \<in> timpl_closure_set (set FP) (set TI). \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
       "timpl_closure_set (absc ` set OCC) (set TI) \<subseteq> absc ` set OCC"
     and TI:
       "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and M:
       "has_all_wt_instances_of \<Gamma> (\<Union>T \<in> set P. trms_transaction T) N"
       "finite N"
       "tfr\<^sub>s\<^sub>e\<^sub>t N"
       "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N"
     and P:
       "\<forall>T \<in> set P. admissible_transaction T"
       "\<forall>T \<in> set P. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
       "has_initial_value_producing_transaction P"
     and transactions_covered: "list_all (transaction_check (FP, OCC, TI)) (map add_occurs_msgs P)"
     and attack_notin_FP: "attack\<langle>n\<rangle> \<notin> set FP"
     and A: "\<A> \<in> reachable_constraints P"
   shows "\<nexists>\<I>. constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
     (is "\<nexists>\<I>. constraint_model \<I> ?A")
 proof
   assume "\<exists>\<I>. constraint_model \<I> ?A"
-  then obtain \<I> where "constraint_model \<I> ?A" by moura
+  then obtain \<I> where "constraint_model \<I> ?A" by force
   then obtain \<I>\<^sub>\<tau> where I: "welltyped_constraint_model \<I>\<^sub>\<tau> ?A"
     using reachable_constraints_typing_result[OF M P(1,2) A] by blast
 
   note a = FP OCC TI P(1,3) transactions_covered attack_notin_FP A
 
   show False
     using prot_secure_if_fixpoint_covered_typed[OF a] I
     by force
 qed
 
 end
 
 subsection \<open>Alternative Protocol-Coverage Check\<close>
 context stateful_protocol_model
 begin
 
 context
 begin
 
 private lemma transaction_check_variant_soundness_aux0:
   assumes S: "S \<equiv> unlabel (transaction_strand T)"
     and xs: "xs \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S)"
     and x: "fst x = Var Value" "x \<in> fv_transaction T" "x \<notin> set (transaction_fresh T)"
   shows "x \<in> set xs"
 using x fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
 unfolding xs S by auto
 
 private lemma transaction_check_variant_soundness_aux1:
   fixes T FP S C xs OCC negs poss as
   assumes C: "C \<equiv> unlabel (transaction_checks T)"
     and S: "S \<equiv> unlabel (transaction_strand T)"
     and xs: "xs \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S)"
     and poss: "poss \<equiv> transaction_poschecks_comp C"
     and negs: "negs \<equiv> transaction_negchecks_comp C"
     and as: "as \<equiv> map (\<lambda>x. (x, set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC))) xs"
     and f: "f \<equiv> \<lambda>x. case List.find (\<lambda>p. fst p = x) as of Some p \<Rightarrow> snd p | None \<Rightarrow> {}"
     and x: "x \<in> set xs"
   shows "f x = set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC)"
 proof -
   define g where "g \<equiv> \<lambda>x. set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC)"
   define gs where "gs \<equiv> map (\<lambda>x. (x, g x)) xs"
 
   have 1: "(x, g x) \<in> set gs" using x unfolding gs_def by simp
   
   have 2: "distinct xs" unfolding xs fv_list\<^sub>s\<^sub>s\<^sub>t_def by auto
   
   have "\<exists>i < length xs. xs ! i = x \<and> (\<forall>j < i. xs ! j \<noteq> x)" when x: "x \<in> set xs" for x
   proof (rule ex1E[OF distinct_Ex1[OF 2 x]])
     fix i assume i: "i < length xs \<and> xs ! i = x" and "\<forall>j. j < length xs \<and> xs ! j = x \<longrightarrow> j = i"
     hence "\<forall>j < length xs. xs ! j = x \<longrightarrow> j = i" by blast
     hence "\<forall>j < i. xs ! j = x \<longrightarrow> j = i" using i by auto
     hence "\<forall>j < i. xs ! j \<noteq> x" by blast 
     thus ?thesis using i by blast
   qed
   hence "\<exists>i < length gs. gs ! i = (x, g x) \<and> (\<forall>j < i. gs ! j \<noteq> (x, g x))"
     using 1 unfolding gs_def by fastforce
   hence "\<exists>i < length gs. fst (gs ! i) = x \<and> (x, g x) = gs ! i \<and> (\<forall>j < i. fst (gs ! j) \<noteq> x)"
     using nth_map[of _ xs "\<lambda>x. (x, g x)"] length_map[of "\<lambda>x. (x, g x)" xs]
     unfolding gs_def by (metis (no_types, lifting) fstI min.strict_order_iff min_less_iff_conj)
   hence "List.find (\<lambda>p. fst p = x) gs = Some (x, g x)"
     using find_Some_iff[of "\<lambda>p. fst p = x" gs "(x, g x)"] by blast
   thus ?thesis
     unfolding f as gs_def g_def by force
 qed
 
 private lemma transaction_check_variant_soundness_aux2:
   fixes T FP S C xs OCC negs poss as
   assumes C: "C \<equiv> unlabel (transaction_checks T)"
     and S: "S \<equiv> unlabel (transaction_strand T)"
     and xs: "xs \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S)"
     and poss: "poss \<equiv> transaction_poschecks_comp C"
     and negs: "negs \<equiv> transaction_negchecks_comp C"
     and as: "as \<equiv> map (\<lambda>x. (x, set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC))) xs"
     and f: "f \<equiv> \<lambda>x. case List.find (\<lambda>p. fst p = x) as of Some p \<Rightarrow> snd p | None \<Rightarrow> {}"
     and x: "x \<notin> set xs"
   shows "f x = {}"
 proof -
   define g where "g \<equiv> \<lambda>x. set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC)"
   define gs where "gs \<equiv> map (\<lambda>x. (x, g x)) xs"
 
   have "(x, y) \<notin> set gs" for y using x unfolding gs_def by force
   thus ?thesis
     using find_None_iff[of "\<lambda>p. fst p = x" gs]
     unfolding f as gs_def g_def by fastforce
 qed
 
 private lemma synth_abs_substs_constrs_rel_if_synth_abs_substs_constrs:
   fixes T OCC negs poss
   defines "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
     and "ts \<equiv> trms_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_receive T))"
   assumes ts_wf: "\<forall>t \<in> set ts. wf\<^sub>t\<^sub>r\<^sub>m t"
     and FP_ground: "ground (set FP)"
     and FP_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
   shows "synth_abs_substs_constrs_rel FP OCC TI ts (synth_abs_substs_constrs (FP,OCC,TI) T)"
 proof -
   let ?R = "synth_abs_substs_constrs_rel FP OCC TI"
   let ?D = "synth_abs_substs_constrs_aux FP OCC TI"
 
   have *: "?R [t] (?D t)" when "wf\<^sub>t\<^sub>r\<^sub>m t" for t using that
   proof (induction t)
     case (Var x) thus ?case
       using synth_abs_substs_constrs_rel.SolveValueVar[of "?D (Var x)" OCC x TI FP]
       by fastforce
   next
     case (Fun f ss)
     let ?xs = "fv (Fun f ss)"
     let ?lst = "map (match_abss OCC TI (Fun f ss)) FP"
 
     define flt where
       "flt = (\<lambda>\<delta>::(('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set set) option. \<delta> \<noteq> None)"
     define \<Delta> where "\<Delta> = map the (filter flt (map (match_abss OCC TI (Fun f ss)) FP))"
     define \<theta>1 where "\<theta>1 = fun_point_Union (set \<Delta>)"
     define \<theta>2 where "\<theta>2 = fun_point_Inter (?D ` set ss)"
 
     have f: "arity f = length ss" using wf_trm_arity[OF Fun.prems] by simp 
 
     have IH: "?R [s] (?D s)" when s: "s \<in> set ss" for s
       using Fun.IH[OF s wf_trm_subterm[OF Fun.prems Fun_param_is_subterm[OF s]]] s
       by force
 
     have \<Delta>3: "\<forall>\<delta>. \<delta> \<in> set \<Delta> \<longleftrightarrow> (\<exists>s \<in> set FP. match_abss OCC TI (Fun f ss) s = Some \<delta>)"
         (is "\<forall>\<delta>. \<delta> \<in> set \<Delta> \<longleftrightarrow> ?P \<delta>")
     proof (intro allI iffI)
       fix \<delta> assume "\<delta> \<in> set \<Delta>"
       then obtain u where "u \<in> set FP" "match_abss OCC TI (Fun f ss) u = Some \<delta>"
         unfolding \<Delta>_def flt_def by fastforce
       thus "?P \<delta>" by blast
     next
       fix \<delta> assume "?P \<delta>"
       then obtain u where u: "u \<in> set FP" "match_abss OCC TI (Fun f ss) u = Some \<delta>" by blast
 
       have "Some \<delta> \<in> set ?lst" using u unfolding flt_def by force
       hence "Some \<delta> \<in> set (filter flt ?lst)" unfolding flt_def by force
       moreover have "\<exists>\<theta>. d = Some \<theta>" when d: "d \<in> set (filter flt ?lst)" for d
         using d unfolding flt_def by simp
       ultimately have "\<delta> \<in> set (map the (filter flt ?lst))" by force
       thus "\<delta> \<in> set \<Delta>" unfolding \<Delta>_def by blast
     qed
 
     show ?case
     proof (cases "ss = []")
       case True
       note ss = this
       show ?thesis
       proof (cases "\<not>public f \<and> Fun f ss \<notin> set FP")
         case True thus ?thesis
           using synth_abs_substs_constrs_rel.SolvePrivConstNotin[of f FP OCC TI]
           unfolding ss by force
       next
         case False thus ?thesis
           using f synth_abs_substs_constrs_rel.SolvePubConst[of f FP OCC TI]
                 synth_abs_substs_constrs_rel.SolvePrivConstIn[of f FP OCC TI]
           unfolding ss by auto
       qed
     next
       case False
       note ss = this
       hence f': "arity f > 0" using f by auto
       have IH': "?R ss (fun_point_Inter (?D ` set ss))"
         using IH synth_abs_substs_constrs_rel.SolveCons[OF ss, of FP OCC TI ?D] by blast
 
       have "?D (Fun f ss) = (
               fun_point_union (fun_point_Union_list \<Delta>) (fun_point_Inter_list (map ?D ss)))"
         using ss synth_abs_substs_constrs_aux.simps(2)[of FP OCC TI f ss]
         unfolding Let_def \<Delta>_def flt_def by argo
       hence "?D (Fun f ss) = fun_point_union \<theta>1 \<theta>2"
         using fun_point_Inter_set_eq[of "map ?D ss"] fun_point_Union_set_eq[of \<Delta>]
         unfolding \<theta>1_def \<theta>2_def by simp
       thus ?thesis
         using synth_abs_substs_constrs_rel.SolveComposed[
                 OF f' f[symmetric] \<Delta>3 \<theta>1_def IH']
         unfolding \<theta>2_def by argo
     qed
   qed
 
   note l0 = synth_abs_substs_constrs_rel.SolveNil[of FP OCC TI]
   note d0 = synth_abs_substs_constrs_def ts_def
 
   note l1 = * ts_wf synth_abs_substs_constrs_rel.SolveCons[of ts FP OCC TI ?D]
   note d1 = d0 Let_def fun_point_Inter_set_eq[symmetric] fun_point_Inter_def
 
   show ?thesis
   proof (cases "ts = []")
     case True thus ?thesis using l0 unfolding d0 by simp
   next
     case False thus ?thesis using l1 unfolding d1 by auto
   qed
 qed
 
 private function (sequential) match_abss'_timpls_transform
 ::"('c set \<times> 'c set) list \<Rightarrow>
    ('a,'b,'c,'d) prot_subst \<Rightarrow>
    ('a,'b,'c,'d) prot_term \<Rightarrow>
    ('a,'b,'c,'d) prot_term \<Rightarrow>
    (('a,'b,'c,'d) prot_var \<Rightarrow> 'c set set) option"
 where
   "match_abss'_timpls_transform TI \<delta> (Var x) (Fun (Abs a) _) = (
     if \<exists>b ts. \<delta> x = Fun (Abs b) ts \<and> (a = b \<or> (a,b) \<in> set TI)
     then Some ((\<lambda>_. {})(x := {a}))
     else None)"
 | "match_abss'_timpls_transform TI \<delta> (Fun f ts) (Fun g ss) = (
     if f = g \<and> length ts = length ss
     then map_option fun_point_Union_list (those (map2 (match_abss'_timpls_transform TI \<delta>) ts ss))
     else None)"
 | "match_abss'_timpls_transform _ _ _ _ = None"
 by pat_completeness auto
 termination
 proof -
   let ?m = "measures [size \<circ> fst \<circ> snd \<circ> snd]"
 
   have 0: "wf ?m" by simp
 
   show ?thesis
     apply (standard, use 0 in fast)
     by (metis (no_types) comp_def fst_conv snd_conv measures_less Fun_zip_size_lt(1))
 qed
 
 private lemma match_abss'_timpls_transform_Var_inv:
   assumes "match_abss'_timpls_transform TI \<delta> (Var x) (Fun (Abs a) ts) = Some \<sigma>"
   shows "\<exists>b ts. \<delta> x = Fun (Abs b) ts \<and> (a = b \<or> (a, b) \<in> set TI)"
    and "\<sigma> = ((\<lambda>_. {})(x := {a}))"
 using assms match_abss'_timpls_transform.simps(1)[of TI \<delta> x a ts]
 by (metis option.distinct(1), metis option.distinct(1) option.inject)
 
 private lemma match_abss'_timpls_transform_Fun_inv:
   assumes "match_abss'_timpls_transform TI \<delta> (Fun f ts) (Fun g ss) = Some \<sigma>"
   shows "f = g" (is ?A)
     and "length ts = length ss" (is ?B)
     and "\<exists>\<theta>. Some \<theta> = those (map2 (match_abss'_timpls_transform TI \<delta>) ts ss) \<and> \<sigma> = fun_point_Union_list \<theta>" (is ?C)
     and "\<forall>(t,s) \<in> set (zip ts ss). \<exists>\<sigma>'. match_abss'_timpls_transform TI \<delta> t s = Some \<sigma>'" (is ?D)
 proof -
   note 0 = assms match_abss'_timpls_transform.simps(2)[of TI \<delta> 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'_timpls_transform TI \<delta>" ts ss] by fastforce
 qed
 
 private lemma match_abss'_timpl_transform_nonempty_is_fv:
   assumes "match_abss'_timpls_transform TI \<delta> s t = Some \<sigma>"
     and "\<sigma> x \<noteq> {}"
   shows "x \<in> fv s"
 using assms
 proof (induction s t arbitrary: TI \<delta> \<sigma> rule: match_abss'_timpls_transform.induct)
   case (1 TI \<delta> y a ts) show ?case
     using match_abss'_timpls_transform_Var_inv[OF "1.prems"(1)] "1.prems"(2)
     by fastforce
 next
   case (2 TI \<delta> f ts g ss)
   note prems = "2.prems"
   note IH = "2.IH"
 
   obtain \<theta> where \<theta>:
           "Some \<theta> = those (map2 (match_abss'_timpls_transform TI \<delta>) ts ss)"
           "\<sigma> = fun_point_Union_list \<theta>"
       and fg: "f = g" "length ts = length ss"
     using match_abss'_timpls_transform_Fun_inv[OF prems(1)] by fast
 
   have "\<exists>\<sigma> \<in> set \<theta>. \<sigma> x \<noteq> {}"
     using fg(2) prems \<theta> unfolding fun_point_Union_list_def by auto
   then obtain t' s' \<sigma> where ts':
       "(t',s') \<in> set (zip ts ss)" "match_abss'_timpls_transform TI \<delta> t' s' = Some \<sigma>" "\<sigma> x \<noteq> {}"
     using those_map2_SomeD[OF \<theta>(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
 
 private lemma match_abss'_timpls_transformI:
   fixes s t::"('a,'b,'c,'d) prot_term"
     and \<delta>::"('a,'b,'c,'d) prot_subst"
     and \<sigma>::"('a,'b,'c,'d) prot_var \<Rightarrow> 'c set set"
   assumes TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and \<delta>: "timpls_transformable_to TI t (s \<cdot> \<delta>)"
     and \<sigma>: "match_abss' s t = Some \<sigma>"
     and t: "fv t = {}"
     and s: "\<forall>f \<in> funs_term s. \<not>is_Abs f"
            "\<forall>x \<in> fv s. \<exists>a. \<delta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
   shows "match_abss'_timpls_transform TI \<delta> s t = Some \<sigma>"
 using \<delta> \<sigma> t s
 proof (induction t arbitrary: s \<delta> \<sigma>)
   case (Fun f ts)
   note prems = Fun.prems
   note IH = Fun.IH
   show ?case
   proof (cases s)
     case (Var x)
     obtain a b where a: "f = Abs a" "\<sigma> = (\<lambda>_. {})(x := {a})" and b: "\<delta> x = \<langle>b\<rangle>\<^sub>a\<^sub>b\<^sub>s"
       using match_abss'_Var_inv[OF prems(2)[unfolded Var]] prems(5)[unfolded Var]
       by auto
     thus ?thesis
       using prems(1) timpls_transformable_to_inv(3)[of TI f ts "Abs b" "[]"]
       unfolding Var by auto
   next
     case (Fun g ss)
     note 0 = timpls_transformable_to_inv[OF prems(1)[unfolded Fun eval_term.simps(2)]]
     note 1 = match_abss'_Fun_inv[OF prems(2)[unfolded Fun]]
 
     obtain \<theta> where \<theta>: "those (map2 match_abss' ss ts) = Some \<theta>" "\<sigma> = fun_point_Union_list \<theta>"
       using 1(3) by force
 
     have "timpls_transformable_to TI t' (s' \<cdot> \<delta>)" "\<exists>\<sigma>'. match_abss' s' t' = Some \<sigma>'"
       when "(t',s') \<in> set (zip ts ss)" for s' t'
       by (metis 0(2) nth_map[of _ ss] zip_arg_index[OF that],
           use that 1(4) in_set_zip_swap[of t' s' ts ss] in fast)
     hence IH': "match_abss'_timpls_transform TI \<delta> s' t' = Some \<sigma>'"
       when "(t',s') \<in> set (zip ts ss)" "match_abss' s' t' = Some \<sigma>'" for s' t' \<sigma>'
       using that IH[of t' s' \<delta> \<sigma>'] prems(3-) unfolding Fun
       by (metis (no_types, lifting) set_zip_leftD set_zip_rightD subsetI subset_empty term.set_intros(2) term.set_intros(4)) 
     
     have "those (map2 (match_abss'_timpls_transform TI \<delta>) ss ts) = Some \<theta>"
       using IH' \<theta>(1) 1(4) in_set_zip_swap[of _ _ ss ts]
             those_Some_iff[of "map2 match_abss' ss ts" \<theta>]
             those_Some_iff[of "map2 (match_abss'_timpls_transform TI \<delta>) ss ts" \<theta>]
       by auto
     thus ?thesis using \<theta>(2) 1(1,2) Fun by simp
   qed
 qed simp
 
 lemma timpls_transformable_to_match_abss'_nonempty_disj':
   fixes s t::"('a,'b,'c,'d) prot_term"
     and \<delta>::"('a,'b,'c,'d) prot_subst"
     and \<sigma>::"('a,'b,'c,'d) prot_var \<Rightarrow> 'c set set"
   assumes TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and \<delta>: "timpls_transformable_to TI t (s \<cdot> \<delta>)"
     and \<sigma>: "match_abss' s t = Some \<sigma>"
     and x: "x \<in> fv s"
     and t: "fv t = {}"
     and s: "\<forall>f \<in> funs_term s. \<not>is_Abs f"
            "\<forall>x \<in> fv s. \<exists>a. \<delta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
     and a: "\<delta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
   shows "\<forall>b \<in> \<sigma> x. (b,a) \<in> (set TI)\<^sup>*" (is "?P \<sigma> x")
 proof -
   note 0 = match_abss'_subst_disj_nonempty[OF TI]
 
   have 1: "s \<cdot> \<delta> \<in> timpl_closure t (set TI)"
     using timpls_transformable_to_iff_in_timpl_closure[OF TI] \<delta> by blast
 
   have 2: "match_abss'_timpls_transform TI \<delta> s t = Some \<sigma>"
     using match_abss'_timpls_transformI[OF TI \<delta> \<sigma> t s] by simp
 
   show "?P \<sigma> x" using 2 TI x t s a
   proof (induction TI \<delta> s t arbitrary: \<sigma> rule: match_abss'_timpls_transform.induct)
     case (1 TI \<delta> y c ts) thus ?case
       using match_abss'_timpls_transform_Var_inv[OF "1.prems"(1)] by auto
   next
     case (2 TI \<delta> f ts g ss)
     obtain \<theta> where fg: "f = g" "length ts = length ss"
         and \<theta>: "Some \<theta> = those (map2 (match_abss'_timpls_transform TI \<delta>) ts ss)"
                "\<sigma> = fun_point_Union_list \<theta>"
                "\<forall>(t, s)\<in>set (zip ts ss). \<exists>\<sigma>'. match_abss'_timpls_transform TI \<delta> t s = Some \<sigma>'"
       using match_abss'_timpls_transform_Fun_inv[OF "2.prems"(1)] by blast
 
     have "(b,a) \<in> (set TI)\<^sup>*" when \<theta>': "\<theta>' \<in> set \<theta>" "b \<in> \<theta>' x" for \<theta>' b
     proof -
       obtain t' s' where t':
           "(t',s') \<in> set (zip ts ss)" "match_abss'_timpls_transform TI \<delta> t' s' = Some \<theta>'"
         using those_map2_SomeD[OF \<theta>(1)[symmetric] \<theta>'(1)] by blast
 
       have *: "fv s' = {}" "\<forall>f \<in> funs_term t'. \<not>is_Abs f" "\<forall>x \<in> fv t'. \<exists>a. \<delta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
         using "2.prems"(4-6) set_zip_leftD[OF t'(1)] set_zip_rightD[OF t'(1)]
         by (fastforce, fastforce, fastforce)
 
       have **: "x \<in> fv t'"
         using \<theta>'(2) match_abss'_timpl_transform_nonempty_is_fv[OF t'(2)] by blast
 
       show ?thesis
         using \<theta>'(2) "2.IH"[OF conjI[OF fg] t'(1) _ t'(2) "2.prems"(2) ** * "2.prems"(7)] by blast
     qed
     thus ?case using \<theta>(1) unfolding \<theta>(2) fun_point_Union_list_def by simp
   qed auto
 qed
 
 lemma timpls_transformable_to_match_abss'_nonempty_disj:
   fixes s t::"('a,'b,'c,'d) prot_term"
     and \<delta>::"('a,'b,'c,'d) prot_subst"
     and \<sigma>::"('a,'b,'c,'d) prot_var \<Rightarrow> 'c set set"
   assumes TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and \<delta>: "timpls_transformable_to TI t (s \<cdot> \<delta>)"
     and \<sigma>: "match_abss' s t = Some \<sigma>"
     and x: "x \<in> fv s"
     and t: "fv t = {}"
     and s: "\<forall>f \<in> funs_term s. \<not>is_Abs f"
            "\<forall>x \<in> fv s. \<exists>a. \<delta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
   shows "\<Inter>(ticl_abs TI ` \<sigma> x) \<noteq> {}"
 proof -
   have 0: "(a,b) \<in> (set TI)\<^sup>*" when y: "y \<in> fv s" "a \<in> \<sigma> y" "\<delta> y = \<langle>b\<rangle>\<^sub>a\<^sub>b\<^sub>s" for a b y
     using timpls_transformable_to_match_abss'_nonempty_disj'[OF TI \<delta> \<sigma> y(1) t s y(3)] y(2) by blast
 
   obtain b where b: "\<delta> x = \<langle>b\<rangle>\<^sub>a\<^sub>b\<^sub>s" using x s(2) by blast
 
   have "b \<in> ticl_abs TI a" when a: "a \<in> \<sigma> x" for a
     using 0[OF x a b] unfolding ticl_abs_iff[OF TI] by blast
   thus ?thesis by blast
 qed
 
 lemma timpls_transformable_to_subst_subterm:
   fixes s t::"(('a,'b,'c,'d) prot_fun, 'v) term"
     and \<delta> \<sigma>::"(('a,'b,'c,'d) prot_fun, 'v) subst"
   assumes "timpls_transformable_to TI (t \<cdot> \<delta>) (t \<cdot> \<sigma>)"
     and "s \<sqsubseteq> t"
   shows "timpls_transformable_to TI (s \<cdot> \<delta>) (s \<cdot> \<sigma>)"
 using assms
 proof (induction "t \<cdot> \<delta>" "t \<cdot> \<sigma>" arbitrary: t rule: timpls_transformable_to.induct)
   case (1 TI x y) thus ?case by (cases t) auto
 next
   case (2 TI f T g S)
   note prems = "2.prems"
   note hyps = "2.hyps"(2-)
   note IH = "2.hyps"(1)
 
   show ?case
   proof (cases "s = t")
     case False
     then obtain h U u where t: "t = Fun h U" "u \<in> set U" "s \<sqsubseteq> u"
       using prems(2) by (cases t) auto
     then obtain i where i: "i < length U" "U ! i = u"
       by (metis in_set_conv_nth)
 
     have "timpls_transformable_to TI (u \<cdot> \<delta>) (u \<cdot> \<sigma>)"
       using t i prems(1) timpls_transformable_to_inv(2)[of TI h "U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>" h "U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<sigma>" i] by simp
     thus ?thesis using IH hyps t by auto
   qed (use prems in auto)
 qed simp_all
 
 lemma timpls_transformable_to_subst_match_case:
   assumes "timpls_transformable_to TI s (t \<cdot> \<theta>)"
     and "fv s = {}"
     and "\<forall>f \<in> funs_term t. \<not>is_Abs f"
     and "distinct (fv_list t)"
     and "\<forall>x \<in> fv t. \<exists>a. \<theta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
   shows "\<exists>\<delta>. s = t \<cdot> \<delta>"
 using assms
 proof (induction s "t \<cdot> \<theta>" arbitrary: t rule: timpls_transformable_to.induct)
   case (2 TI f T g S)
   note prems = "2.prems"
   note hyps = "2.hyps"(2-)
   note IH = "2.hyps"(1)
 
   show ?case
   proof (cases t)
     case (Var x)
     then obtain a where a: "t \<cdot> \<theta> = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s" using prems(5) by fastforce
     show ?thesis
       using hyps timpls_transformable_to_inv'[OF prems(1)[unfolded a]]
       unfolding Var by force
   next
     case (Fun h U)
     have g: "g = h" and S: "S = U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"
       using hyps unfolding Fun by simp_all
 
     note 0 = distinct_fv_list_Fun_param[OF prems(4)[unfolded Fun]]
 
     have 1: "\<forall>f \<in> funs_term u. \<not>is_Abs f" when u: "u \<in> set U" for u
       using prems(3) u unfolding Fun by fastforce
 
     have 2: "fv t' = {}" when t': "t' \<in> set T" for t'
       using t' prems(2) by simp
 
     have 3: "\<forall>x \<in> fv u. \<exists>a. \<theta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s" when u: "u \<in> set U" for u
       using u prems(5) unfolding Fun by simp
 
     have "\<not>is_Abs f"
       using prems(3) timpls_transformable_to_inv(3)[OF prems(1)[unfolded hyps[symmetric] S g]]
       unfolding Fun by auto
     hence f: "f = h" and T: "length T = length U"
       using prems(1) timpls_transformable_to_inv(1,3)[of TI f T h "U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"]
       unfolding Fun by fastforce+
 
     define \<Delta> where "\<Delta> \<equiv> \<lambda>i. if i < length T then SOME \<delta>. T ! i = U ! i \<cdot> \<delta> else undefined"
 
     have "timpls_transformable_to TI (T ! i) (U ! i \<cdot> \<theta>)" when i: "i < length T" for i
       using prems(1)[unfolded Fun] T i timpls_transformable_to_inv(2)[of TI f T h "U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" i]
       by auto
     hence "\<exists>\<delta>. T ! i = U ! i \<cdot> \<delta>" when i: "i < length T" for i
       using i T IH[OF _ _ _ 2 1 0 3, of "T ! i" "U ! i"]
       unfolding Fun g S by simp
     hence \<Delta>: "T ! i = U ! i \<cdot> \<Delta> i" when i: "i < length T" for i
       using i someI2[of "\<lambda>\<delta>. T ! i = U ! i \<cdot> \<delta>" _ "\<lambda>\<delta>. T ! i = U ! i \<cdot> \<delta>"]
       unfolding \<Delta>_def by fastforce
 
     define \<delta> where "\<delta> \<equiv> \<lambda>x. if \<exists>i < length T. x \<in> fv (U ! i)
                             then \<Delta> (SOME i. i < length T \<and> x \<in> fv (U ! i)) x
                             else undefined"
 
     have "T ! i = U ! i \<cdot> \<delta>" when i: "i < length T" for i
     proof -
       have "j = i"
         when x: "x \<in> fv (U ! i)" and j: "j < length T" "x \<in> fv (U ! j)" for j x
         using x i j T distinct_fv_list_idx_fv_disjoint[OF prems(4)[unfolded Fun], of h U]
         by (metis (no_types, lifting) disjoint_iff_not_equal neqE term.dual_order.refl)
       hence "\<delta> x = \<Delta> i x" when x: "x \<in> fv (U ! i)" for x
         using x i some_equality[of "\<lambda>i. i < length T \<and> x \<in> fv (U ! i)" i]
         unfolding \<delta>_def by (metis (no_types, lifting))
       thus ?thesis by (metis \<Delta> i term_subst_eq)
     qed
     hence "T = U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>" by (metis (no_types, lifting) T length_map nth_equalityI nth_map)
     hence "Fun f T = Fun f U \<cdot> \<delta>" by simp
     thus ?thesis using Fun f by fast
   qed
 qed simp_all
 
 lemma timpls_transformable_to_match_abss'_case:
   assumes "timpls_transformable_to TI s (t \<cdot> \<theta>)"
     and "fv s = {}"
     and "\<forall>f \<in> funs_term t. \<not>is_Abs f"
     and "\<forall>x \<in> fv t. \<exists>a. \<theta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
   shows "\<exists>\<delta>. match_abss' t s = Some \<delta>"
 using assms
 proof (induction s "t \<cdot> \<theta>" arbitrary: t rule: timpls_transformable_to.induct)
   case (2 TI f T g S)
   note prems = "2.prems"
   note hyps = "2.hyps"(2-)
   note IH = "2.hyps"(1)
 
   show ?case
   proof (cases t)
     case (Var x)
     then obtain a where a: "t \<cdot> \<theta> = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s" using prems(4) by fastforce
     thus ?thesis
       using timpls_transformable_to_inv'(4)[OF prems(1)[unfolded a]] 
       by (metis (no_types) Var is_Abs_def term.sel(2) match_abss'.simps(1))
   next
     case (Fun h U)
     have g: "g = h" and S: "S = U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"
       using hyps unfolding Fun by simp_all
 
     have 1: "\<forall>f \<in> funs_term u. \<not>is_Abs f" when u: "u \<in> set U" for u
       using prems(3) u unfolding Fun by fastforce
 
     have 2: "fv t' = {}" when t': "t' \<in> set T" for t'
       using t' prems(2) by simp
 
     have 3: "\<forall>x \<in> fv u. \<exists>a. \<theta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s" when u: "u \<in> set U" for u
       using u prems(4) unfolding Fun by simp
 
     have "\<not>is_Abs f"
       using prems(3) timpls_transformable_to_inv(3)[OF prems(1)[unfolded hyps[symmetric] S g]]
       unfolding Fun by auto
     hence f: "f = h" and T: "length T = length U"
       using prems(1) timpls_transformable_to_inv(1,3)[of TI f T h "U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>"]
       unfolding Fun by fastforce+
 
     define \<Delta> where "\<Delta> \<equiv> \<lambda>i.
       if i < length T
       then SOME \<delta>. match_abss' (U ! i) (T ! i) = Some \<delta>
       else undefined"
 
     have "timpls_transformable_to TI (T ! i) (U ! i \<cdot> \<theta>)" when i: "i < length T" for i
       using prems(1)[unfolded Fun] T i timpls_transformable_to_inv(2)[of TI f T h "U \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" i]
       by auto
     hence "\<exists>\<delta>. match_abss' (U ! i) (T ! i) = Some \<delta>" when i: "i < length T" for i
       using i T IH[OF _ _ _ 2 1 3, of "T ! i" "U ! i"]
       unfolding Fun g S by simp
     hence "match_abss' (U ! i) (T ! i) = Some (\<Delta> i)" when i: "i < length T" for i
       using i someI2[of "\<lambda>\<delta>. match_abss' (U ! i) (T ! i) = Some \<delta>" _
                         "\<lambda>\<delta>. match_abss' (U ! i) (T ! i) = Some \<delta>"]
       unfolding \<Delta>_def by fastforce
     thus ?thesis
       using match_abss'_FunI[OF _ T] unfolding Fun f by auto
   qed
 qed simp_all
 
 lemma timpls_transformable_to_match_abss_case:
   assumes TI: "set TI = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and "timpls_transformable_to TI s (t \<cdot> \<theta>)"
     and "fv s = {}"
     and "\<forall>f \<in> funs_term t. \<not>is_Abs f"
     and "\<forall>x \<in> fv t. \<exists>a. \<theta> x = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s"
   shows "\<exists>\<delta>. match_abss OCC TI t s = Some \<delta>"
 proof -
   obtain \<delta> where \<delta>: "match_abss' t s = Some \<delta>"
     using timpls_transformable_to_match_abss'_case[OF assms(2-)] by blast
 
   show ?thesis
     using \<delta> timpls_transformable_to_match_abss'_nonempty_disj[OF assms(1,2) \<delta> _ assms(3-5)]
     unfolding match_abss_def by simp
 qed
 
 private lemma transaction_check_variant_soundness_aux3:
   fixes T FP S C xs OCC negs poss as
   defines "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
     and "C \<equiv> unlabel (transaction_checks T)"
     and "S \<equiv> unlabel (transaction_strand T)"
     and "ts \<equiv> trms_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_receive T))"
     and "xs \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S)"
   assumes TI0: "\<forall>(a,b) \<in> set TI. \<forall>(c,d) \<in> set TI. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> set TI"
                "\<forall>(a,b) \<in> set TI. a \<noteq> b"
     and OCC: "\<forall>t \<in> set FP. \<forall>a. Abs a \<in> funs_term t \<longrightarrow> a \<in> set OCC"
     and FP_ground: "ground (set FP)"
     and x: "x \<in> set xs"
     and xs: "\<forall>x. x \<in> set xs \<longrightarrow> \<delta> x \<in> set OCC"
             "\<forall>x. x \<in> set xs \<longrightarrow> poss x \<subseteq> \<delta> x"
             "\<forall>x. x \<in> set xs \<longrightarrow> \<delta> x \<inter> negs x = {}"
             "\<forall>x. x \<notin> set xs \<longrightarrow> \<delta> x = {}"
     and ts: "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)"
             "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). \<forall>f \<in> funs_term t. \<not>is_Abs f"
             "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)). fst x = TAtom Value"
     and C: "\<forall>a x s. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> set C \<longrightarrow> s \<in> \<delta> x"
            "\<forall>x s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> set C \<longrightarrow> s \<notin> \<delta> x"
     and \<sigma>: "synth_abs_substs_constrs_rel FP OCC TI ts \<sigma>"
   shows "\<delta> x \<in> \<sigma> x"
 proof -
   note defs = assms(1-5)
 
   note TI = trancl_eqI'[OF TI0]
 
   have \<delta>x0: "\<delta> x \<in> set OCC" "poss x \<subseteq> \<delta> x" "\<delta> x \<inter> negs x = {}" using x xs by (blast,blast,blast)
 
   have ts0: "\<forall>t \<in> set ts. intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)"
     using ts(1) trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t unfolding ts_def by blast
 
   have ts1: "\<not>Fun (Abs n) S \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t set ts" for n S
     using ts(2) funs_term_Fun_subterm'
     unfolding ts_def trms_transaction_unfold trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t[symmetric] is_Abs_def
     by fastforce
 
   have ts2: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts). fst x = TAtom Value"
     using ts(3)
     unfolding ts_def trms_transaction_unfold trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t[symmetric]
     by fastforce
 
   show ?thesis using \<sigma> ts0 ts1 ts2
   proof (induction rule: synth_abs_substs_constrs_rel.induct)
     case (SolvePrivConstNotin c)
     hence "intruder_synth_mod_timpls FP TI (Fun c [])" by force
     hence "list_ex (\<lambda>t. timpls_transformable_to TI t (Fun c [])) FP"
       using SolvePrivConstNotin.hyps(1,2) by simp
     then obtain t where t: "t \<in> set FP" "timpls_transformable_to TI t (Fun c [])"
       unfolding list_ex_iff by blast
 
     have "\<not>is_Abs c"
       using SolvePrivConstNotin.prems(2)[of _ "[]"]
       by (metis in_subterms_Union is_Abs_def list.set_intros(1))
     hence "t = Fun c []"
       using t(2) timpls_transformable_to_inv[of TI] by (cases t) auto
     thus ?case using t(1) SolvePrivConstNotin.hyps(3) by fast
   next
     case (SolveValueVar \<theta>1 y)
     have "list_ex (\<lambda>t. timpls_transformable_to TI t \<langle>\<delta> y\<rangle>\<^sub>a\<^sub>b\<^sub>s) FP"
       using SolveValueVar.prems(1-3) unfolding \<theta>_def by simp
     then obtain t where t: "t \<in> set FP" "timpls_transformable_to TI t \<langle>\<delta> y\<rangle>\<^sub>a\<^sub>b\<^sub>s"
       unfolding list_ex_iff by blast
 
     obtain a where a: "t = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s" "a = \<delta> y \<or> (a, \<delta> y) \<in> set TI"
     proof -
       obtain ft tst where ft: "t = Fun ft tst"
         using t(2) timpls_transformable_to_inv_Var(1)[of TI _ "\<langle>\<delta> y\<rangle>\<^sub>a\<^sub>b\<^sub>s"]
         by (cases t) auto
       
       have "tst = []" "is_Abs ft" "the_Abs ft = \<delta> y \<or> (the_Abs ft, \<delta> y) \<in> set TI"
         using timpls_transformable_to_inv'(2,4,5)[OF t(2)[unfolded ft]]
         by (simp, force, force)
       thus thesis using that[of "the_Abs ft"] ft by force 
     qed
 
     have "a \<in> set OCC"
       using t(1)[unfolded a(1)] OCC by auto
     thus ?case
       using \<delta>x0(1) t(1)[unfolded a(1)] a(2)
       unfolding SolveValueVar.hyps(1) ticl_abss_def ticl_abs_def
       by force
   next
     case (SolveComposed g us \<Delta> \<theta>1 \<theta>2) show ?case
     proof (cases "\<forall>t \<in> set us. intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)")
       case True
       hence "\<delta> x \<in> \<theta>2 x"
         using SolveComposed.IH SolveComposed.prems(2,3)
               distinct_fv_list_Fun_param[of g us] 
         by auto
       thus ?thesis unfolding fun_point_union_def by simp
     next
       case False
       hence "list_ex (\<lambda>t. timpls_transformable_to TI t (Fun g us \<cdot> \<theta> \<delta>)) FP"
         using SolveComposed.prems(1) intruder_synth_mod_timpls.simps(2)[of FP TI g "us \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta> \<delta>"]
         unfolding list_all_iff by auto
       then obtain t where t: "t \<in> set FP" "timpls_transformable_to TI t (Fun g us \<cdot> \<theta> \<delta>)"
         unfolding list_ex_iff by blast
 
       have t_ground: "fv t = {}"
         using t(1) FP_ground by simp
 
       have g_no_abs: "\<not>is_Abs f" when f: "f \<in> funs_term (Fun g us)" for f
       proof -
         obtain fts where "Fun f fts \<sqsubseteq> Fun g us" using funs_term_Fun_subterm[OF f] by blast
         thus ?thesis using SolveComposed.prems(2)[of _ fts] by (cases f) auto
       qed
 
       have g_\<theta>_abs: "\<exists>a. \<theta> \<delta> y = \<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s" when y: "y \<in> fv (Fun g us)" for y
         using y SolveComposed.prems(3) unfolding \<theta>_def by fastforce
       
       obtain \<delta>' where \<delta>': "match_abss OCC TI (Fun g us) t = Some \<delta>'"
         using g_no_abs g_\<theta>_abs timpls_transformable_to_match_abss_case[OF TI t(2) t_ground ]
         by blast
 
       let ?h1 = "\<lambda>\<delta> x. if x \<in> fv (Fun g us) then \<delta> x else set OCC"
       let ?h2 = "\<lambda>\<delta> x. \<Inter>(ticl_abs TI ` \<delta> x)"
 
       obtain \<delta>'' where \<delta>'':
           "match_abss' (Fun g us) t = Some \<delta>''" "\<delta>' = ?h1 (?h2 \<delta>'')"
           "\<forall>x \<in> fv (Fun g us). \<delta>' x \<noteq> {} \<and> \<delta>' x \<noteq> {}"
         using match_abssD[OF \<delta>'] by blast
 
       have \<delta>'_\<Delta>: "\<delta>' \<in> \<Delta>"
         using t(1) \<delta>' SolveComposed.hyps(3) by metis
 
       have "\<delta> x \<in> ticl_abs TI a" when a: "a \<in> \<delta>'' x" and x_in_g: "x \<in> fv (Fun g us)" for a
       proof -
         have "fst x = TAtom Value" using x_in_g SolveComposed.prems(3) by auto
         hence "\<theta> \<delta> x = \<langle>\<delta> x\<rangle>\<^sub>a\<^sub>b\<^sub>s" unfolding \<theta>_def by simp
         hence "(a, \<delta> x) \<in> (set TI)\<^sup>*"
           using timpls_transformable_to_match_abss'_nonempty_disj'[
                   OF TI t(2) \<delta>''(1) x_in_g t_ground]
                 g_no_abs g_\<theta>_abs a
           by fastforce
         thus "\<delta> x \<in> ticl_abs TI a" unfolding ticl_abs_iff[OF TI] by force
       qed
       hence "\<delta> x \<in> \<delta>' x" when x_in_g: "x \<in> fv (Fun g us)"
         using \<delta>''(2,3) x_in_g unfolding \<delta>''(1) by simp
       hence "\<delta> x \<in> \<delta>' x" using match_abss_OCC_if_not_fv[OF \<delta>'] \<delta>x0(1) by blast
       hence "\<delta> x \<in> \<theta>1 x"
         using \<delta>'_\<Delta> \<delta>x0(1) unfolding SolveComposed.hyps(4,5) fun_point_Union_def by auto
       thus ?thesis unfolding fun_point_union_def by simp
     qed
   qed (auto simp add: \<delta>x0 fun_point_Inter_def)
 qed
 
 private lemma transaction_check_variant_soundness_aux4:
   fixes T FP S C xs OCC negs poss as
   defines "\<theta> \<equiv> \<lambda>\<delta> x. if fst x = TAtom Value then (absc \<circ> \<delta>) x else Var x"
     and "C \<equiv> unlabel (transaction_checks T)"
     and "S \<equiv> unlabel (transaction_strand T)"
     and "xas \<equiv> (the_Abs \<circ> the_Fun) ` set (filter (\<lambda>t. is_Fun t \<and> is_Abs (the_Fun t)) FP)"
     and "ts \<equiv> trms_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_receive T))"
     and "xs \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S)"
     and "poss \<equiv> transaction_poschecks_comp C"
     and "negs \<equiv> transaction_negchecks_comp C"
     and "as \<equiv> map (\<lambda>x. (x, set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC))) xs"
     and "f \<equiv> \<lambda>x. case List.find (\<lambda>p. fst p = x) as of Some p \<Rightarrow> snd p | None \<Rightarrow> {}"
   assumes T_adm: "admissible_transaction' T"
     and TI0: "\<forall>(a,b) \<in> set TI. \<forall>(c,d) \<in> set TI. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> set TI"
              "\<forall>(a,b) \<in> set TI. a \<noteq> b"
     and OCC: "\<forall>t \<in> set FP. \<forall>a. Abs a \<in> funs_term t \<longrightarrow> a \<in> set OCC"
     and FP_ground: "ground (set FP)"
     and FP_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
     and "x \<in> set xs"
     and "\<forall>x. x \<in> set xs \<longrightarrow> \<delta> x \<in> set OCC"
     and "\<forall>x. x \<in> set xs \<longrightarrow> poss x \<subseteq> \<delta> x"
     and "\<forall>x. x \<in> set xs \<longrightarrow> \<delta> x \<inter> negs x = {}"
     and "\<forall>x. x \<notin> set xs \<longrightarrow> \<delta> x = {}"
     and "\<forall>t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T). intruder_synth_mod_timpls FP TI (t \<cdot> \<theta> \<delta>)"
     and "\<forall>a x s. \<langle>a: Var x \<in> Fun (Set s) []\<rangle> \<in> set C \<longrightarrow> s \<in> \<delta> x"
     and "\<forall>x s. \<langle>Var x not in Fun (Set s) []\<rangle> \<in> set C \<longrightarrow> s \<notin> \<delta> x"
   shows "\<delta> x \<in> synth_abs_substs_constrs (FP,OCC,TI) T x"
 proof -
   let ?FPT = "(FP,OCC,TI)"
   let ?P = "\<lambda>s u. let \<delta> = mgu s u
                    in \<delta> \<noteq> None \<longrightarrow> (\<forall>x \<in> fv s. is_Fun (the \<delta> x) \<longrightarrow> is_Abs (the_Fun (the \<delta> x)))"
 
   define \<theta>0 where "\<theta>0 \<equiv> \<lambda>x.
     if fst x = TAtom Value \<and> x \<in> fv_transaction T \<and> x \<notin> set (transaction_fresh T)
     then {ab \<in> set OCC. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}} else {}"
 
   define g where "g \<equiv> \<lambda>x. set (filter (\<lambda>ab. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}) OCC)"
   define gs where "gs \<equiv> map (\<lambda>x. (x, g x)) xs"
 
   note defs = assms(3-10) \<theta>0_def
   note assm = assms(11-)[unfolded defs]
 
   have ts0: "\<forall>t \<in> set ts. wf\<^sub>t\<^sub>r\<^sub>m t"
     using admissible_transaction_is_wellformed_transaction(4)[OF T_adm]
     unfolding admissible_transaction_terms_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric]
               ts_def trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t[symmetric]
               trms_transaction_unfold
     by fast
 
   have ts1: "\<forall>t \<in> set ts. \<forall>f \<in> funs_term t. \<not>is_Abs f"
     using protocol_transactions_no_abss[OF T_adm] funs_term_Fun_subterm
           trms\<^sub>s\<^sub>s\<^sub>t_unlabel_prefix_subset(1)
     unfolding ts_def trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t[symmetric] is_Abs_def transaction_strand_def
     by (metis (no_types, opaque_lifting) in_subterms_Union in_subterms_subset_Union subset_iff)
   
   have ts2: "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts). fst x = TAtom Value"
     using admissible_transaction_Value_vars[OF T_adm]
           wellformed_transaction_send_receive_fv_subset(1)[
             OF admissible_transaction_is_wellformed_transaction(1)[OF T_adm]]
     unfolding ts_def trms_transaction_unfold trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t[symmetric] \<Gamma>\<^sub>v_TAtom''(2)
     by fastforce
 
   have "f x = \<theta>0 x" for x
   proof (cases "fst x = Var Value \<and> x \<in> fv_transaction T \<and> x \<notin> set (transaction_fresh T)")
     case True
     hence "\<theta>0 x = {ab \<in> set OCC. poss x \<subseteq> ab \<and> negs x \<inter> ab = {}}" unfolding \<theta>0_def by argo
     thus ?thesis
       using True transaction_check_variant_soundness_aux0[OF S_def xs_def, of x]
             transaction_check_variant_soundness_aux1[
               OF C_def S_def xs_def poss_def negs_def as_def f_def, of x]
       by simp
   next
     case False
     hence 0: "\<theta>0 x = {}" unfolding \<theta>0_def by argo
 
     have "x \<notin> set xs"
       using False fv_list\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"]
       unfolding xs_def S_def by fastforce
     hence "List.find (\<lambda>p. fst p = x) gs = None"
       using find_None_iff[of "\<lambda>p. fst p = x" gs] unfolding gs_def by simp
     hence "f x = {}"
       unfolding f_def as_def gs_def g_def by force
     thus ?thesis using 0 by simp
   qed
   thus ?thesis
     using synth_abs_substs_constrs_rel_if_synth_abs_substs_constrs[
             OF _ FP_ground FP_wf, of T, unfolded trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t ts_def[symmetric], OF ts0]
           transaction_check_variant_soundness_aux3[
             OF TI0 OCC FP_ground assm(7-11),
             of "synth_abs_substs_constrs ?FPT T",
             unfolded trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t ts_def[symmetric],
             OF assm(12)[unfolded \<theta>_def trms_list\<^sub>s\<^sub>s\<^sub>t_is_trms\<^sub>s\<^sub>s\<^sub>t ts_def[symmetric]]
                ts1 ts2 assm(13-)[unfolded C_def]]
     unfolding defs synth_abs_substs_constrs_def Let_def by blast
 qed
 
 private lemma transaction_check_variant_soundness_aux5:
   fixes FP OCC TI T S C
   defines "msgcs \<equiv> \<lambda>x a. a \<in> synth_abs_substs_constrs (FP,OCC,TI) T x"
     and "S \<equiv> unlabel (transaction_strand T)"
     and "C \<equiv> unlabel (transaction_checks T)"
     and "xs \<equiv> filter (\<lambda>x. x \<notin> set (transaction_fresh T) \<and> fst x = TAtom Value) (fv_list\<^sub>s\<^sub>s\<^sub>t S)"
     and "poss \<equiv> transaction_poschecks_comp C"
     and "negs \<equiv> transaction_negchecks_comp C"
   assumes T_adm: "admissible_transaction' T"
     and TI: "\<forall>(a,b) \<in> set TI. \<forall>(c,d) \<in> set TI. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> set TI"
             "\<forall>(a,b) \<in> set TI. a \<noteq> b"
     and OCC: "\<forall>t \<in> set FP. \<forall>a. Abs a \<in> funs_term t \<longrightarrow> a \<in> set OCC"
     and FP: "ground (set FP)"
             "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
     and \<delta>: "\<delta> \<in> abs_substs_fun ` set (abs_substs_set xs OCC poss negs (\<lambda>_ _. True))"
            "transaction_check_pre (FP,OCC,TI) T \<delta>"
   shows "\<delta> \<in> abs_substs_fun ` set (abs_substs_set xs OCC poss negs msgcs)"
 proof -
   have 0: "\<delta> x \<in> set OCC" "poss x \<subseteq> \<delta> x" "\<delta> x \<inter> negs x = {}" when x: "x \<in> set xs" for x
     using abs_substs_abss_bounded[OF \<delta>(1) x] by simp_all
 
   have 1: "\<delta> x = {}" when x: "x \<notin> set xs" for x
     by (rule abs_substs_abss_bounded'[OF \<delta>(1) x])
 
   have 2: "msgcs x (\<delta> x)" when x: "x \<in> set xs" for x
     using 0 1 x transaction_check_variant_soundness_aux4[OF T_adm TI OCC FP, of x \<delta>]
           transaction_check_pre_ReceiveE[OF \<delta>(2)] transaction_check_pre_InSetE[OF \<delta>(2)]
           transaction_check_pre_NotInSetE[OF \<delta>(2)]
     unfolding msgcs_def xs_def C_def S_def negs_def poss_def by fast
 
   show ?thesis
     using abs_substs_has_abs[of xs \<delta> OCC poss negs msgcs] 0 1 2 by blast
 qed
 
 theorem transaction_check_variant_soundness:
   assumes P_adm: "\<forall>T \<in> set P. admissible_transaction' T"
     and TI: "\<forall>(a,b) \<in> set TI. \<forall>(c,d) \<in> set TI. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> set TI"
             "\<forall>(a,b) \<in> set TI. a \<noteq> b"
     and OCC: "\<forall>t \<in> set FP. \<forall>a. Abs a \<in> funs_term t \<longrightarrow> a \<in> set OCC"
     and FP: "ground (set FP)"
             "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
     and T_in: "T \<in> set P"
     and T_check: "transaction_check_coverage_rcv (FP,OCC,TI) T"
   shows "transaction_check (FP,OCC,TI) T"
 proof -
   have 0: "admissible_transaction' T"
     using P_adm T_in by blast
 
   show ?thesis
     using T_check transaction_check_variant_soundness_aux5[OF 0 TI OCC FP]
     unfolding transaction_check_def transaction_check'_def transaction_check_coverage_rcv_def
               transaction_check_comp_def list_all_iff Let_def
     by force
 qed
 
 end
 
 end
 
 
 subsection \<open>Automatic Fixed-Point Computation\<close>
 context stateful_protocol_model
 begin
 
 fun reduce_fixpoint' where
   "reduce_fixpoint' FP _ [] = FP"
 | "reduce_fixpoint' FP TI (t#M) = (
   let FP' = List.removeAll t FP
   in if intruder_synth_mod_timpls FP' TI t then FP' else reduce_fixpoint' FP TI M)"
 
 definition reduce_fixpoint where
   "reduce_fixpoint FP TI \<equiv>
     let f = \<lambda>FP. reduce_fixpoint' FP TI FP
     in while (\<lambda>M. set (f M) \<noteq> set M) f FP"
 
 definition compute_fixpoint_fun' where
   "compute_fixpoint_fun' P (n::nat option) enable_traces \<Delta> S0 \<equiv>
     let P' = map add_occurs_msgs P;
 
         sy = intruder_synth_mod_timpls;
 
         FP' = \<lambda>S. fst (fst S);
         TI' = \<lambda>S. snd (fst S);
         OCC' = \<lambda>S. remdups (
           (map (\<lambda>t. the_Abs (the_Fun (args t ! 1)))
                (filter (\<lambda>t. is_Fun t \<and> the_Fun t = OccursFact) (FP' S)))@
           (map snd (TI' S)));
 
         equal_states = \<lambda>S S'. set (FP' S) = set (FP' S') \<and> set (TI' S) = set (TI' S');
 
         trace' = \<lambda>S. snd S;
 
         close = \<lambda>M f. let g = remdups \<circ> f in while (\<lambda>A. set (g A) \<noteq> set A) g M;
         close' = \<lambda>M f. let g = remdups \<circ> f in while (\<lambda>A. set (g A) \<noteq> set A) g M;
         trancl_minus_refl = \<lambda>TI.
           let aux = \<lambda>ts p. map (\<lambda>q. (fst p,snd q)) (filter ((=) (snd p) \<circ> fst) ts)
           in filter (\<lambda>p. fst p \<noteq> snd p) (close' TI (\<lambda>ts. concat (map (aux ts) ts)@ts));
         snd_Ana = \<lambda>N M TI. let N' = filter (\<lambda>t. \<forall>k \<in> set (fst (Ana t)). sy M TI k) N in
           filter (\<lambda>t. \<not>sy M TI t)
                  (concat (map (\<lambda>t. filter (\<lambda>s. s \<in> set (snd (Ana t))) (args t)) N'));
         Ana_cl = \<lambda>FP TI.
           close FP (\<lambda>M. (M@snd_Ana M M TI));
         TI_cl = \<lambda>FP TI.
           close FP (\<lambda>M. (M@filter (\<lambda>t. \<not>sy M TI t)
                                   (concat (map (\<lambda>m. concat (map (\<lambda>(a,b). \<langle>a --\<guillemotright> b\<rangle>\<langle>m\<rangle>) TI)) M))));
         Ana_cl' = \<lambda>FP TI.
           let K = \<lambda>t. set (fst (Ana t));
               flt = \<lambda>M t. (\<exists>k \<in> K t. \<not>sy M TI k) \<and> (\<exists>k \<in> K t. \<exists>f \<in> funs_term k. is_Abs f);
               N = \<lambda>M. comp_timpl_closure_list (filter (flt M) M) TI
           in close FP (\<lambda>M. M@snd_Ana (N M) M TI);
 
         \<Delta>' = \<lambda>S. \<Delta> (FP' S, OCC' S, TI' S);
         result = \<lambda>S T \<delta>.
           let not_fresh = \<lambda>x. x \<notin> set (transaction_fresh T);
               xs = filter not_fresh (fv_list\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T)));
               u = \<lambda>\<delta> x. absdbupd (unlabel (transaction_strand T)) x (\<delta> x)
           in (remdups (filter (\<lambda>t. \<not>sy (FP' S) (TI' S) t)
                               (concat (map (\<lambda>ts. the_msgs ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (absc \<circ> u \<delta>))
                                            (filter is_Send (unlabel (transaction_send T)))))),
               remdups (filter (\<lambda>s. fst s \<noteq> snd s) (map (\<lambda>x. (\<delta> x, u \<delta> x)) xs)));
         result_tuple = \<lambda>S T \<delta>. (result S T (abs_substs_fun \<delta>), if enable_traces then \<delta> else []);
         update_state = \<lambda>S. if list_ex (\<lambda>t. is_Fun t \<and> is_Attack (the_Fun t)) (FP' S) then S
           else let results = map (\<lambda>T. map (result_tuple S T) (\<Delta>' S T)) P';
                    newtrace_flt = (\<lambda>n. let x = map fst (results ! n); y = map fst x; z = map snd x
                     in set (concat y) - set (FP' S) \<noteq> {} \<or> set (concat z) - set (TI' S) \<noteq> {});
                    trace =
                     if enable_traces
                     then trace' S@[concat (map (\<lambda>i. map (\<lambda>a. (i,snd a)) (results ! i))
                                                (filter newtrace_flt [0..<length results]))]
                     else [];
                    U = map fst (concat results);
                    V = ((remdups (concat (map fst U)@FP' S),
                          remdups (filter (\<lambda>x. fst x \<noteq> snd x) (concat (map snd U)@TI' S))),
                         trace);
                    W = ((Ana_cl (TI_cl (FP' V) (TI' V)) (TI' V),
                          trancl_minus_refl (TI' V)),
                         trace' V)
           in if \<not>equal_states W S then W
           else ((Ana_cl' (FP' W) (TI' W), TI' W), trace' W);
 
         S = ((\<lambda>h. case n of None \<Rightarrow> while (\<lambda>S. \<not>equal_states S (h S)) h | Some m \<Rightarrow> h ^^ m)
              update_state S0)
     in ((reduce_fixpoint (FP' S) (TI' S), OCC' S, TI' S), trace' S)"
 
 definition compute_fixpoint_fun where
   "compute_fixpoint_fun P \<equiv>
     let P' = remdups (filter (\<lambda>T. transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> []) P);
         f = (\<lambda>FPT T. let msgcs = synth_abs_substs_constrs FPT T
                     in transaction_check_comp (\<lambda>x a. a \<in> msgcs x) FPT T)
     in fst (compute_fixpoint_fun' P' None False f (([],[]),[]))"
 
 definition compute_fixpoint_with_trace where
   "compute_fixpoint_with_trace P \<equiv>
     compute_fixpoint_fun' P None True (transaction_check_comp (\<lambda>_ _. True)) (([],[]),[])"
 
 definition compute_fixpoint_from_trace where
   "compute_fixpoint_from_trace P trace \<equiv>
     let P' = map add_occurs_msgs P;
         \<Delta> = \<lambda>FPT T.
           let pre_check = transaction_check_pre FPT T;
               \<delta>s = map snd (filter (\<lambda>(i,as). P' ! i = T) (concat trace))
           in filter (\<lambda>\<delta>. pre_check (abs_substs_fun \<delta>)) \<delta>s;
         f = compute_fixpoint_fun' \<circ> map (nth P);
         g = \<lambda>L FPT. fst ((f L (Some 1) False \<Delta> ((fst FPT,snd (snd FPT)),[])))
     in fold g (map (map fst) trace) ([],[],[])"
 
 definition compute_reduced_attack_trace where
   "compute_reduced_attack_trace P trace \<equiv>
     let attack_in_fixpoint = list_ex (\<lambda>t. \<exists>f \<in> funs_term t. is_Attack f) \<circ> fst;
         is_attack_trace = attack_in_fixpoint \<circ> compute_fixpoint_from_trace P;
   
         trace' =
           let is_attack_transaction =
                 list_ex is_Fun_Attack \<circ> concat \<circ> map the_msgs \<circ>
                 filter is_Send \<circ> unlabel \<circ> transaction_send;
               trace' =
                 if trace = [] then []
                 else butlast trace@[filter (is_attack_transaction \<circ> nth P \<circ> fst) (last trace)]
            in trace';
     
         iter = \<lambda>trace_prev trace_rest elem (prev,rest).
           let next =
             if is_attack_trace (trace_prev@(prev@rest)#trace_rest)
             then prev
             else prev@[elem]
           in (next, tl rest);
         iter' = \<lambda>trace_part (trace_prev,trace_rest).
           let updated = foldr (iter trace_prev (tl trace_rest)) trace_part ([],tl (rev trace_part))
           in (trace_prev@[rev (fst updated)], tl trace_rest);
     
         reduced_trace = fst (fold iter' trace' ([],trace'))
     in concat reduced_trace"
 
 end
 
 
 subsection \<open>Locales for Protocols Proven Secure through Fixed-Point Coverage\<close>
 type_synonym ('f,'a,'s,'l) fixpoint_triple =
   "('f,'a,'s,'l) prot_term list \<times> 's set list \<times> ('s set \<times> 's set) list"
 
 context stateful_protocol_model
 begin
 
 definition "attack_notin_fixpoint (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) \<equiv>
   list_all (\<lambda>t. \<forall>f \<in> funs_term t. \<not>is_Attack f) (fst FPT)"
 
 definition "protocol_covered_by_fixpoint (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) P \<equiv>
   list_all (transaction_check FPT)
            (filter (\<lambda>T. transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> [])
                    (map add_occurs_msgs P))"
 
 definition "protocol_covered_by_fixpoint_coverage_rcv (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) P \<equiv>
   list_all (transaction_check_coverage_rcv FPT)
            (filter (\<lambda>T. transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> [])
                    (map add_occurs_msgs P))"
 
 definition "analyzed_fixpoint (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) \<equiv>
   let (FP, _, TI) = FPT
   in analyzed_closed_mod_timpls FP TI"
 
 definition "wellformed_protocol_SMP_set (P::('fun,'atom,'sets,'lbl) prot) N \<equiv>
   has_all_wt_instances_of \<Gamma> (\<Union>T \<in> set P. trms_transaction T) (set N) \<and>
   comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \<Gamma> (set N) \<and>
   list_all (\<lambda>T. list_all (comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<Gamma> Pair) (unlabel (transaction_strand T))) P"
 
 (* TODO: try to avoid checking the "list_all is_*" conditions here... *)
 definition "wellformed_protocol'' (P::('fun,'atom,'sets,'lbl) prot) N \<equiv>
   let f = \<lambda>T. transaction_fresh T = [] \<longrightarrow> transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> []
   in list_all (\<lambda>T. list_all is_Receive (unlabel (transaction_receive T)) \<and>
                    list_all is_Check_or_Assignment (unlabel (transaction_checks T)) \<and>
                    list_all is_Update (unlabel (transaction_updates T)) \<and>
                    list_all is_Send (unlabel (transaction_send T)))
               P \<and>
      list_all admissible_transaction (filter f P) \<and>
      wellformed_protocol_SMP_set P N"
 
 definition "wellformed_protocol' (P::('fun,'atom,'sets,'lbl) prot) N \<equiv>
   wellformed_protocol'' P N \<and>
   has_initial_value_producing_transaction P"
 
 definition "wellformed_protocol (P::('fun,'atom,'sets,'lbl) prot) \<equiv>
   let f = \<lambda>M. remdups (concat (map subterms_list M@map (fst \<circ> Ana) M));
       N0 = remdups (concat (map (trms_list\<^sub>s\<^sub>s\<^sub>t \<circ> unlabel \<circ> transaction_strand) P));
       N = while (\<lambda>A. set (f A) \<noteq> set A) f N0
   in wellformed_protocol' P N"
 
 definition "wellformed_fixpoint' (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) \<equiv>
   let (FP, OCC, TI) = FPT; OCC' = set OCC
   in list_all (\<lambda>t. wf\<^sub>t\<^sub>r\<^sub>m' arity t \<and> fv t = {}) FP \<and>
      list_all (\<lambda>a. a \<in> OCC') (map snd TI) \<and>
      list_all (\<lambda>t. \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> OCC') FP"
 
 definition "wellformed_term_implication_graph (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) \<equiv>
   let (_, _, TI) = FPT
   in list_all (\<lambda>(a,b). list_all (\<lambda>(c,d). b = c \<and> a \<noteq> d \<longrightarrow> List.member TI (a,d)) TI) TI \<and>
      list_all (\<lambda>p. fst p \<noteq> snd p) TI"
 
 definition "wellformed_fixpoint (FPT::('fun,'atom,'sets,'lbl) fixpoint_triple) \<equiv>
   wellformed_fixpoint' FPT \<and> wellformed_term_implication_graph FPT"
 
 lemma wellformed_protocol_SMP_set_mono:
   assumes "wellformed_protocol_SMP_set P S"
     and "set P' \<subseteq> set P"
   shows "wellformed_protocol_SMP_set P' S"
 using assms 
 unfolding wellformed_protocol_SMP_set_def comp_tfr\<^sub>s\<^sub>e\<^sub>t_def has_all_wt_instances_of_def
           wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s'_def list_all_iff
 by fast
 
 lemma wellformed_protocol''_mono:
   assumes "wellformed_protocol'' P S"
     and "set P' \<subseteq> set P"
   shows "wellformed_protocol'' P' S"
 using assms wellformed_protocol_SMP_set_mono[of P S P']
 unfolding wellformed_protocol''_def list_all_iff by auto
 
 lemma wellformed_protocol'_mono:
   assumes "wellformed_protocol' P S"
     and "set P' \<subseteq> set P"
     and "has_initial_value_producing_transaction P'"
   shows "wellformed_protocol' P' S"
 using assms wellformed_protocol_SMP_set_mono[of P S P'] wellformed_protocol''_mono
 unfolding wellformed_protocol'_def by blast
 
 lemma protocol_covered_by_fixpoint_if_protocol_covered_by_fixpoint_coverage_rcv:
   assumes P: "wellformed_protocol'' P P_SMP"
     and FPT: "wellformed_fixpoint FPT"
     and covered: "protocol_covered_by_fixpoint_coverage_rcv FPT P"
   shows "protocol_covered_by_fixpoint FPT P"
 proof -
   obtain FP OCC TI where FPT': "FPT = (FP,OCC,TI)" by (metis surj_pair)
 
   note defs = FPT' wellformed_protocol''_def wellformed_fixpoint_def wellformed_fixpoint'_def
               wellformed_term_implication_graph_def Let_def
               wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric] wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric] 
               member_def case_prod_unfold list_all_iff
 
   let ?f = "\<lambda>T. transaction_fresh T = [] \<longrightarrow> transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> []"
 
   have TI: "\<forall>(a,b) \<in> set TI. \<forall>(c,d) \<in> set TI. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> set TI"
               "\<forall>(a,b) \<in> set TI. a \<noteq> b"
       and OCC: "\<forall>t \<in> set FP. \<forall>a. Abs a \<in> funs_term t \<longrightarrow> a \<in> set OCC"
       and FP: "ground (set FP)"
               "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
     using FPT unfolding defs by (simp, simp, fastforce, simp, simp)
 
   have P_adm: "\<forall>T \<in> set (filter ?f (map add_occurs_msgs P)). admissible_transaction' T"
     using P add_occurs_msgs_admissible_occurs_checks(1)[OF admissible_transactionE'(1)]
     unfolding defs add_occurs_msgs_updates_send_filter_iff'[of P, symmetric] by auto
 
   show ?thesis
     using covered transaction_check_variant_soundness[OF P_adm TI OCC FP]
     unfolding protocol_covered_by_fixpoint_def protocol_covered_by_fixpoint_coverage_rcv_def
               FPT' list_all_iff
     by fastforce
 qed
 
 lemma protocol_covered_by_fixpoint_if_protocol_covered_by_fixpoint_coverage_rcv':
   assumes P: "wellformed_protocol'' P P_SMP"
     and P': "set P' \<subseteq> set P"
     and FPT: "wellformed_fixpoint FPT"
     and covered: "protocol_covered_by_fixpoint_coverage_rcv FPT P'"
   shows "protocol_covered_by_fixpoint FPT P'"
 using protocol_covered_by_fixpoint_if_protocol_covered_by_fixpoint_coverage_rcv[OF _ FPT covered]
       wellformed_protocol''_mono[OF P P']
 by simp
 
 lemma protocol_covered_by_fixpoint_trivial_case:
   assumes "list_all (\<lambda>T. transaction_updates T = [] \<and> transaction_send T = [])
                     (map add_occurs_msgs P)"
   shows "protocol_covered_by_fixpoint FPT P"
 using assms
 by (simp add: list_all_iff transaction_check_trivial_case protocol_covered_by_fixpoint_def)
 
 lemma protocol_covered_by_fixpoint_empty[simp]:
   "protocol_covered_by_fixpoint FPT []"
 by (simp add: protocol_covered_by_fixpoint_def)
 
 lemma protocol_covered_by_fixpoint_Cons[simp]:
   "protocol_covered_by_fixpoint FPT (T#P) \<longleftrightarrow>
     transaction_check FPT (add_occurs_msgs T) \<and> protocol_covered_by_fixpoint FPT P"
 using transaction_check_trivial_case[of "add_occurs_msgs T"]
 unfolding protocol_covered_by_fixpoint_def case_prod_unfold by simp
 
 lemma protocol_covered_by_fixpoint_append[simp]:
   "protocol_covered_by_fixpoint FPT (P1@P2) \<longleftrightarrow>
    protocol_covered_by_fixpoint FPT P1 \<and> protocol_covered_by_fixpoint FPT P2"
 by (simp add: protocol_covered_by_fixpoint_def case_prod_unfold)
 
 lemma protocol_covered_by_fixpoint_I1[intro]:
   assumes "list_all (protocol_covered_by_fixpoint FPT) P"
   shows "protocol_covered_by_fixpoint FPT (concat P)"
 using assms by (auto simp add: protocol_covered_by_fixpoint_def list_all_iff)
 
 lemma protocol_covered_by_fixpoint_I2[intro]:
   assumes "protocol_covered_by_fixpoint FPT P1"
     and "protocol_covered_by_fixpoint FPT P2"
   shows "protocol_covered_by_fixpoint FPT (P1@P2)"
 using assms by (auto simp add: protocol_covered_by_fixpoint_def)
 
 lemma protocol_covered_by_fixpoint_I3:
   assumes "\<forall>T \<in> set P. \<forall>\<delta>::('fun,'atom,'sets,'lbl) prot_var \<Rightarrow> 'sets set.
     transaction_check_pre FPT (add_occurs_msgs T) \<delta> \<longrightarrow>
     transaction_check_post FPT (add_occurs_msgs T) \<delta>"
   shows "protocol_covered_by_fixpoint FPT P"
 using assms
 unfolding protocol_covered_by_fixpoint_def transaction_check_def transaction_check'_def
           transaction_check_comp_def list_all_iff Let_def case_prod_unfold
           Product_Type.fst_conv Product_Type.snd_conv
 by fastforce
 
 lemmas protocol_covered_by_fixpoint_intros =
   protocol_covered_by_fixpoint_I1
   protocol_covered_by_fixpoint_I2
   protocol_covered_by_fixpoint_I3
 
 lemma prot_secure_if_prot_checks:
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
   assumes attack_notin_fixpoint: "attack_notin_fixpoint FP_OCC_TI"
     and transactions_covered: "protocol_covered_by_fixpoint FP_OCC_TI P"
     and analyzed_fixpoint: "analyzed_fixpoint FP_OCC_TI"
     and wellformed_protocol: "wellformed_protocol' P N"
     and wellformed_fixpoint: "wellformed_fixpoint FP_OCC_TI"
   shows "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>. constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
     (is "?secure P")
 proof -
   define FP where "FP \<equiv> let (FP,_,_) = FP_OCC_TI in FP"
   define OCC where "OCC \<equiv> let (_,OCC,_) = FP_OCC_TI in OCC"
   define TI where "TI \<equiv> let (_,_,TI) = FP_OCC_TI in TI"
 
   define f where "f \<equiv> \<lambda>T::('fun,'atom,'sets,'lbl) prot_transaction.
     transaction_fresh T = [] \<longrightarrow> transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> []"
 
   define g where "g \<equiv> \<lambda>T::('fun,'atom,'sets,'lbl) prot_transaction.
     transaction_fresh T = [] \<longrightarrow>
       list_ex (\<lambda>a. is_Update (snd a) \<or> is_Send (snd a)) (transaction_strand T)"
 
   note wellformed_prot_defs =
     wellformed_protocol'_def wellformed_protocol''_def wellformed_protocol_SMP_set_def
 
   have attack_notin_FP: "attack\<langle>n\<rangle> \<notin> set FP"
     using attack_notin_fixpoint[unfolded attack_notin_fixpoint_def]
     unfolding list_all_iff FP_def by force
 
   have 1: "\<forall>(a,b) \<in> set TI. \<forall>(c,d) \<in> set TI. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> set TI"
     using wellformed_fixpoint
     unfolding wellformed_fixpoint_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric] Let_def TI_def
               list_all_iff member_def case_prod_unfold
               wellformed_term_implication_graph_def
     by auto
 
   have 0: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set FP)"
     and 2: "\<forall>(a,b) \<in> set TI. a \<noteq> b"
     and 3: "snd ` set TI \<subseteq> set OCC"
     and 4: "\<forall>t \<in> set FP. \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` set OCC"
     and 5: "ground (set FP)"
     using wellformed_fixpoint
     unfolding wellformed_fixpoint_def wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric] is_Abs_def the_Abs_def
               list_all_iff Let_def case_prod_unfold set_map FP_def OCC_def TI_def
               wellformed_fixpoint'_def wellformed_term_implication_graph_def
     by (fast, fast, blast, fastforce, simp)
 
   have 8: "finite (set N)"
     and 9: "has_all_wt_instances_of \<Gamma> (\<Union>T \<in> set (filter g P). trms_transaction T) (set N)"
     and 10: "tfr\<^sub>s\<^sub>e\<^sub>t (set N)"
     and 11: "\<forall>T \<in> set (filter f P). list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and 12: "\<forall>T \<in> set (filter f P). admissible_transaction T"
     using wellformed_protocol[unfolded wellformed_prot_defs]
           tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t[of "set N"]
     unfolding Let_def list_all_iff wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric] tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p[symmetric]
               has_all_wt_instances_of_def f_def[symmetric]
     by (fast, fastforce, fast, fastforce, fast)
 
   have 13: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set N)"
     using wellformed_protocol[unfolded wellformed_prot_defs]
           finite_SMP_representationD
     unfolding wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric] wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s'_def comp_tfr\<^sub>s\<^sub>e\<^sub>t_def list_all_iff Let_def by fast
 
   have 14: "has_initial_value_producing_transaction (filter g P)"
     using wellformed_protocol has_initial_value_producing_transaction_update_send_ex_filter
     unfolding wellformed_protocol'_def Let_def g_def by blast
 
   note TI0 = trancl_eqI'[OF 1 2]
 
   have "analyzed (timpl_closure_set (set FP) (set TI))"
     using analyzed_fixpoint[unfolded analyzed_fixpoint_def]
           analyzed_closed_mod_timpls_is_analyzed_timpl_closure_set[OF TI0 0]
     unfolding FP_def TI_def
     by force
   note FP0 = this 0 5
 
   note OCC0 = funs_term_OCC_TI_subset(1)[OF 4 3]
               timpl_closure_set_supset'[OF funs_term_OCC_TI_subset(2)[OF 4 3]]
 
   note M0 = 9 8 10 13
 
   have "f T \<longleftrightarrow> g T" when T: "T \<in> set P" for T
   proof -
     have *: "list_all stateful_strand_step.is_Receive (unlabel (transaction_receive T))"
             "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
             "list_all is_Update (unlabel (transaction_updates T))"
             "list_all stateful_strand_step.is_Send (unlabel (transaction_send T))"
       using T wellformed_protocol
       unfolding wellformed_protocol_def wellformed_prot_defs Let_def list_all_iff
       by (fast, fast, fast, fast)
 
     show ?thesis
       using transaction_updates_send_ex_iff[OF *]
       unfolding f_def g_def by (metis (no_types, lifting) list_ex_cong)
   qed
   hence 15: "\<forall>T \<in> set (filter g P). list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     and 16: "\<forall>T \<in> set (filter g P). admissible_transaction T"
     using 11 12 by auto
 
   have "list_all (transaction_check (FP, OCC, TI)) (map add_occurs_msgs (filter g P))"
     using transactions_covered[unfolded protocol_covered_by_fixpoint_def]
           transaction_check_trivial_case[of _ FP_OCC_TI]
     unfolding FP_def OCC_def TI_def list_all_iff Let_def case_prod_unfold
     by auto
   note P0 = 16 15 14 this attack_notin_FP
 
   show ?thesis
     using prot_secure_if_fixpoint_covered[OF FP0 OCC0 TI0 M0 P0]
           reachable_constraints_secure_if_filter_secure_case[unfolded g_def[symmetric]]
     by fast
 qed
 
 lemma prot_secure_if_prot_checks_coverage_rcv:
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
   assumes attack_notin_fixpoint: "attack_notin_fixpoint FP_OCC_TI"
     and transactions_covered: "protocol_covered_by_fixpoint_coverage_rcv FP_OCC_TI P"
     and analyzed_fixpoint: "analyzed_fixpoint FP_OCC_TI"
     and wellformed_protocol: "wellformed_protocol' P N"
     and wellformed_fixpoint: "wellformed_fixpoint FP_OCC_TI"
   shows "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>. constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 using prot_secure_if_prot_checks[
         OF attack_notin_fixpoint _
            analyzed_fixpoint wellformed_protocol wellformed_fixpoint]
       protocol_covered_by_fixpoint_if_protocol_covered_by_fixpoint_coverage_rcv[
         OF _ wellformed_fixpoint transactions_covered]
       wellformed_protocol[unfolded wellformed_protocol'_def]
 by blast
 
 end
 
 locale secure_stateful_protocol =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
     and P_SMP::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes attack_notin_fixpoint: "pm.attack_notin_fixpoint FP_OCC_TI"
     and transactions_covered: "pm.protocol_covered_by_fixpoint FP_OCC_TI P"
     and analyzed_fixpoint: "pm.analyzed_fixpoint FP_OCC_TI"
     and wellformed_protocol: "pm.wellformed_protocol' P P_SMP"
     and wellformed_fixpoint: "pm.wellformed_fixpoint FP_OCC_TI"
 begin
 
 theorem protocol_secure:
   "\<forall>\<A> \<in> pm.reachable_constraints P. \<nexists>\<I>. pm.constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 by (rule pm.prot_secure_if_prot_checks[OF
             attack_notin_fixpoint transactions_covered
             analyzed_fixpoint wellformed_protocol wellformed_fixpoint])
 
 corollary protocol_welltyped_secure:
   "\<forall>\<A> \<in> pm.reachable_constraints P. \<nexists>\<I>. pm.welltyped_constraint_model \<I> (\<A>@[(l, send\<langle>[attack\<langle>n\<rangle>]\<rangle>)])"
 using protocol_secure unfolding pm.welltyped_constraint_model_def by fast
 
 end
 
 locale secure_stateful_protocol' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
   assumes attack_notin_fixpoint': "pm.attack_notin_fixpoint FP_OCC_TI"
     and transactions_covered': "pm.protocol_covered_by_fixpoint FP_OCC_TI P"
     and analyzed_fixpoint': "pm.analyzed_fixpoint FP_OCC_TI"
     and wellformed_protocol': "pm.wellformed_protocol P"
     and wellformed_fixpoint': "pm.wellformed_fixpoint FP_OCC_TI"
 begin
 
 sublocale secure_stateful_protocol
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P
   FP_OCC_TI
   "let f = \<lambda>M. remdups (concat (map subterms_list M@map (fst \<circ> pm.Ana) M));
        N0 = remdups (concat (map (trms_list\<^sub>s\<^sub>s\<^sub>t \<circ> unlabel \<circ> transaction_strand) P))
    in while (\<lambda>A. set (f A) \<noteq> set A) f N0"
 apply unfold_locales
 using attack_notin_fixpoint' transactions_covered' analyzed_fixpoint'
       wellformed_protocol'[unfolded pm.wellformed_protocol_def Let_def] wellformed_fixpoint'
 unfolding Let_def by blast+
 
 end
 
 locale secure_stateful_protocol'' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
   assumes checks: "let FPT = pm.compute_fixpoint_fun P
     in pm.attack_notin_fixpoint FPT \<and> pm.protocol_covered_by_fixpoint FPT P \<and>
        pm.analyzed_fixpoint FPT \<and> pm.wellformed_protocol P \<and> pm.wellformed_fixpoint FPT"
 begin
 
 sublocale secure_stateful_protocol'
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P "pm.compute_fixpoint_fun P"
 using checks[unfolded Let_def case_prod_unfold] by unfold_locales meson+
 
 end
 
 locale secure_stateful_protocol''' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
     and P_SMP::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes checks': "let P' = P; FPT = FP_OCC_TI; P'_SMP = P_SMP
                     in pm.attack_notin_fixpoint FPT \<and>
                        pm.protocol_covered_by_fixpoint FPT P' \<and>
                        pm.analyzed_fixpoint FPT \<and>
                        pm.wellformed_protocol' P' P'_SMP \<and>
                        pm.wellformed_fixpoint FPT"
 begin
 
 sublocale secure_stateful_protocol
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P FP_OCC_TI P_SMP
 using checks'[unfolded Let_def case_prod_unfold] by unfold_locales meson+
 
 end
 
 locale secure_stateful_protocol'''' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
   assumes checks'': "let P' = P; FPT = FP_OCC_TI
                      in pm.attack_notin_fixpoint FPT \<and>
                         pm.protocol_covered_by_fixpoint FPT P' \<and>
                         pm.analyzed_fixpoint FPT \<and>
                         pm.wellformed_protocol P' \<and>
                         pm.wellformed_fixpoint FPT"
 begin
 
 sublocale secure_stateful_protocol'
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P FP_OCC_TI
 using checks''[unfolded Let_def case_prod_unfold] by unfold_locales meson+
 
 end
 
 locale secure_stateful_protocol_coverage_rcv =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
     and P_SMP::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes attack_notin_fixpoint_coverage_rcv: "pm.attack_notin_fixpoint FP_OCC_TI"
     and transactions_covered_coverage_rcv: "pm.protocol_covered_by_fixpoint_coverage_rcv FP_OCC_TI P"
     and analyzed_fixpoint_coverage_rcv: "pm.analyzed_fixpoint FP_OCC_TI"
     and wellformed_protocol_coverage_rcv: "pm.wellformed_protocol' P P_SMP"
     and wellformed_fixpoint_coverage_rcv: "pm.wellformed_fixpoint FP_OCC_TI"
 begin
 
 sublocale secure_stateful_protocol
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P
   FP_OCC_TI P_SMP
 using pm.protocol_covered_by_fixpoint_if_protocol_covered_by_fixpoint_coverage_rcv[
         OF _ wellformed_fixpoint_coverage_rcv transactions_covered_coverage_rcv]
       attack_notin_fixpoint_coverage_rcv analyzed_fixpoint_coverage_rcv
       wellformed_protocol_coverage_rcv wellformed_fixpoint_coverage_rcv
       wellformed_protocol_coverage_rcv[unfolded pm.wellformed_protocol'_def]
 by unfold_locales meson+
 
 end
 
 locale secure_stateful_protocol_coverage_rcv' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
   assumes attack_notin_fixpoint_coverage_rcv': "pm.attack_notin_fixpoint FP_OCC_TI"
     and transactions_covered_coverage_rcv': "pm.protocol_covered_by_fixpoint_coverage_rcv FP_OCC_TI P"
     and analyzed_fixpoint_coverage_rcv': "pm.analyzed_fixpoint FP_OCC_TI"
     and wellformed_protocol_coverage_rcv': "pm.wellformed_protocol P"
     and wellformed_fixpoint_coverage_rcv': "pm.wellformed_fixpoint FP_OCC_TI"
 begin
 
 sublocale secure_stateful_protocol_coverage_rcv
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P
   FP_OCC_TI
   "let f = \<lambda>M. remdups (concat (map subterms_list M@map (fst \<circ> pm.Ana) M));
        N0 = remdups (concat (map (trms_list\<^sub>s\<^sub>s\<^sub>t \<circ> unlabel \<circ> transaction_strand) P))
    in while (\<lambda>A. set (f A) \<noteq> set A) f N0"
 apply unfold_locales
 using attack_notin_fixpoint_coverage_rcv' transactions_covered_coverage_rcv' analyzed_fixpoint_coverage_rcv'
       wellformed_protocol_coverage_rcv'[unfolded pm.wellformed_protocol_def Let_def] wellformed_fixpoint_coverage_rcv'
 unfolding Let_def by blast+
 
 end
 
 locale secure_stateful_protocol_coverage_rcv'' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
   assumes checks_coverage_rcv: "let FPT = pm.compute_fixpoint_fun P
     in pm.attack_notin_fixpoint FPT \<and> pm.protocol_covered_by_fixpoint_coverage_rcv FPT P \<and>
        pm.analyzed_fixpoint FPT \<and> pm.wellformed_protocol P \<and> pm.wellformed_fixpoint FPT"
 begin
 
 sublocale secure_stateful_protocol_coverage_rcv'
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P "pm.compute_fixpoint_fun P"
 using checks_coverage_rcv[unfolded Let_def case_prod_unfold] by unfold_locales meson+
 
 end
 
 locale secure_stateful_protocol_coverage_rcv''' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
     and P_SMP::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes checks_coverage_rcv': "let P' = P; FPT = FP_OCC_TI; P'_SMP = P_SMP
                          in pm.attack_notin_fixpoint FPT \<and>
                             pm.protocol_covered_by_fixpoint_coverage_rcv FPT P' \<and>
                             pm.analyzed_fixpoint FPT \<and>
                             pm.wellformed_protocol' P' P'_SMP \<and>
                             pm.wellformed_fixpoint FPT"
 begin
 
 sublocale secure_stateful_protocol_coverage_rcv
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P FP_OCC_TI P_SMP
 using checks_coverage_rcv'[unfolded Let_def case_prod_unfold] by unfold_locales meson+
 
 end
 
 locale secure_stateful_protocol_coverage_rcv'''' =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,'lbl) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"'lbl"
     and label_witness2::"'lbl"
   +
   fixes P::"('fun,'atom,'sets,'lbl) prot_transaction list"
     and FP_OCC_TI:: "('fun,'atom,'sets,'lbl) fixpoint_triple"
   assumes checks_coverage_rcv'': "let P' = P; FPT = FP_OCC_TI
                           in pm.attack_notin_fixpoint FPT \<and>
                              pm.protocol_covered_by_fixpoint_coverage_rcv FPT P' \<and>
                              pm.analyzed_fixpoint FPT \<and>
                              pm.wellformed_protocol P' \<and>
                              pm.wellformed_fixpoint FPT"
 begin
 
 sublocale secure_stateful_protocol_coverage_rcv'
   arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2 P FP_OCC_TI
 using checks_coverage_rcv''[unfolded Let_def case_prod_unfold] by unfold_locales meson+
 
 end
 
 
 subsection \<open>Automatic Protocol Composition\<close>
 context stateful_protocol_model
 begin
 
 definition welltyped_leakage_free_protocol where
   "welltyped_leakage_free_protocol S P \<equiv>
     let f = \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}};
         Sec = (f (set S)) - {m. {} \<turnstile>\<^sub>c m}
     in \<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau> s.
       (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>) \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
 
 definition wellformed_composable_protocols where
   "wellformed_composable_protocols (P::('fun,'atom,'sets,'lbl) prot list) N \<equiv>
     let
       Ts = concat P;
       steps = remdups (concat (map transaction_strand Ts));
       MP0 = \<Union>T \<in> set Ts. trms_transaction T \<union> pair' Pair ` setops_transaction T
     in
       list_all (wf\<^sub>t\<^sub>r\<^sub>m' arity) N \<and>
       has_all_wt_instances_of \<Gamma> MP0 (set N) \<and>
       comp_tfr\<^sub>s\<^sub>e\<^sub>t arity Ana \<Gamma> (set N) \<and>
       list_all (comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<Gamma> Pair \<circ> snd) steps \<and>
       list_all admissible_transaction_terms Ts \<and>
       list_all (list_all (\<lambda>x. \<Gamma>\<^sub>v x = TAtom Value \<or> (is_Var (\<Gamma>\<^sub>v x) \<and> is_Atom (the_Var (\<Gamma>\<^sub>v x)))) \<circ>
                 transaction_fresh)
                Ts \<and>
       list_all (\<lambda>T. \<forall>x \<in> vars_transaction T. \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x) Ts \<and>
       list_all (\<lambda>T. \<forall>x \<in> vars_transaction T. \<forall>f \<in> funs_term (\<Gamma>\<^sub>v x). f \<noteq> Pair \<and> f \<noteq> OccursFact)
                Ts \<and>
       list_all (list_all (\<lambda>s. is_Send (snd s) \<and> length (the_msgs (snd s)) = 1 \<and>
                               is_Fun_Attack (hd (the_msgs (snd s))) \<longrightarrow>
                                 the_Attack_label (the_Fun (hd (the_msgs (snd s)))) = fst s) \<circ>
                 transaction_strand)
                Ts \<and>
       list_all (\<lambda>r. (\<exists>f \<in> \<Union>(funs_term ` (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd r))). f = OccursFact \<or> f = OccursSec) \<longrightarrow>
                       (is_Receive (snd r) \<or> is_Send (snd r)) \<and> fst r = \<star> \<and>
                       (\<forall>t \<in> set (the_msgs (snd r)).
                         (OccursFact \<in> funs_term t \<or> OccursSec \<in> funs_term t) \<longrightarrow>
                           is_Fun t \<and> length (args t) = 2 \<and> t = occurs (args t ! 1) \<and>
                           is_Var (args t ! 1) \<and> (\<Gamma> (args t ! 1) = TAtom Value)))
                steps"
 
 definition wellformed_composable_protocols' where
   "wellformed_composable_protocols' (P::('fun,'atom,'sets,'lbl) prot list) \<equiv>
     let
       Ts = concat P
     in
       list_all wellformed_transaction Ts \<and>
       list_all (list_all
                   (\<lambda>p. let (x,cs) = p in
                         is_Var (\<Gamma>\<^sub>v x) \<and> is_Atom (the_Var (\<Gamma>\<^sub>v x)) \<and>
                         (\<forall>c \<in> cs. \<Gamma>\<^sub>v x = \<Gamma> (Fun (Fu c) []::('fun,'atom,'sets,'lbl) prot_term))) \<circ>
                 (\<lambda>T. transaction_decl T ()))
                Ts"
 
 definition composable_protocols where
   "composable_protocols (P::('fun,'atom,'sets,'lbl) prot list) Ms S \<equiv>
     let
       steps = concat (map transaction_strand (concat P));
       M_fun = (\<lambda>l. case find ((=) l \<circ> fst) Ms of Some M \<Rightarrow> set (snd M) | None \<Rightarrow> {})
     in comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \<Gamma> Pair steps M_fun (set S)"
 
 lemma composable_protocols_par_comp_constr:
   fixes S f
   defines "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}}"
     and "Sec \<equiv> (f (set S)) - {m. intruder_synth {} m}"
   assumes Ps_pc: "wellformed_composable_protocols Ps N"
                  "wellformed_composable_protocols' Ps"
                  "composable_protocols Ps Ms S"
   shows "\<forall>\<A> \<in> reachable_constraints (concat Ps). \<forall>\<I>. constraint_model \<I> \<A> \<longrightarrow>
             (\<exists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> \<A> \<and>
                   ((\<forall>n. welltyped_constraint_model \<I>\<^sub>\<tau> (proj n \<A>)) \<or>
                    (\<exists>\<A>' l t. prefix \<A>' \<A> \<and> suffix [(l, receive\<langle>t\<rangle>)] \<A>' \<and>
                               strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' Sec \<I>\<^sub>\<tau>)))"
     (is "\<forall>\<A> \<in> _. \<forall>_. _ \<longrightarrow> ?Q \<A> \<I>")
 proof (intro allI ballI impI)
   fix \<A> \<I>
   assume \<A>: "\<A> \<in> reachable_constraints (concat Ps)" and \<I>: "constraint_model \<I> \<A>"
 
   let ?Ts = "concat Ps"
   let ?steps = "concat (map transaction_strand ?Ts)"
   let ?MP0 = "\<Union>T \<in> set ?Ts. trms_transaction T \<union> pair' Pair ` setops_transaction T"
   let ?M_fun = "\<lambda>l. case find ((=) l \<circ> fst) Ms of Some M \<Rightarrow> set (snd M) | None \<Rightarrow> {}"
 
   have M:
       "has_all_wt_instances_of \<Gamma> ?MP0 (set N)"
       "finite (set N)" "tfr\<^sub>s\<^sub>e\<^sub>t (set N)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set N)"
     using Ps_pc tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t[of "set N"]
     unfolding composable_protocols_def wellformed_composable_protocols_def
               Let_def list_all_iff wf\<^sub>t\<^sub>r\<^sub>m_code[symmetric]
     by fast+
 
   have P:
       "\<forall>T \<in> set ?Ts. wellformed_transaction T"
       "\<forall>T \<in> set ?Ts. wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
       "\<forall>T \<in> set ?Ts. list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
       "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \<Gamma> Pair ?steps ?M_fun (set S)"
     using Ps_pc tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p
     unfolding wellformed_composable_protocols_def wellformed_composable_protocols'_def
               composable_protocols_def Let_def list_all_iff unlabel_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code[symmetric]
               admissible_transaction_terms_def
     by (meson, meson, fastforce, blast)
 
   show "?Q \<A> \<I>"
     using reachable_constraints_par_comp_constr[OF M P \<A> \<I>]
     unfolding Sec_def f_def by fast
 qed
 
 context
 begin
 private lemma reachable_constraints_no_leakage_alt_aux:
   fixes P lbls L
   defines "lbls \<equiv> \<lambda>T. map (the_LabelN o fst) (filter (Not o has_LabelS) (transaction_strand T))"
     and "L \<equiv> set (remdups (concat (map lbls P)))"
   assumes l: "l \<notin> L"
   shows "map (transaction_proj l) P = map transaction_star_proj P"
 proof -
   have 0: "\<not>list_ex (has_LabelN l) (transaction_strand T)" when "T \<in> set P" for T
     using that l unfolding L_def lbls_def list_ex_iff by force
 
   have 1: "\<not>list_ex (has_LabelN l) (transaction_strand T)"
     when T: "T \<in> set (map (transaction_proj l) P)" for T
   proof -
     obtain T' where T': "T' \<in> set P" "T = transaction_proj l T'" using T by auto
     show ?thesis
       using T'(2) 0[OF T'(1)] proj_set_subset[of l "transaction_strand T'"]
             transaction_strand_proj[of l T'] 
       unfolding list_ex_iff by fastforce
   qed
 
   have "list_all has_LabelS (transaction_strand T)"
     when "T \<in> set (map (transaction_proj l) P)" for T
     using that 1[OF that] transaction_proj_idem[of l]
           transaction_strand_proj[of l "transaction_proj l T"]
           has_LabelS_proj_iff_not_has_LabelN[of l "transaction_strand (transaction_proj l T)"]
     by (metis (no_types) ex_map_conv)
   thus ?thesis
     using transaction_star_proj_ident_iff transaction_proj_member
           transaction_star_proj_negates_transaction_proj(1)
     by (metis (mono_tags, lifting) map_eq_conv) 
 qed
 
 private lemma reachable_constraints_star_no_leakage:
   fixes Sec P lbls k
   defines "no_leakage \<equiv> \<lambda>\<A>. \<nexists>\<I>\<^sub>\<tau> \<A>' s.
       prefix \<A>' \<A> \<and> (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>') \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>'@[(k,send\<langle>[s]\<rangle>)])"
   assumes Sec: "\<forall>s \<in> Sec. \<not>{} \<turnstile>\<^sub>c s" "ground Sec"
   shows "\<forall>\<A> \<in> reachable_constraints (map transaction_star_proj P). no_leakage \<A>"
 proof
   fix A assume A: "A \<in> reachable_constraints (map transaction_star_proj P)"
 
   have A': "\<forall>(l,a) \<in> set A. l = \<star>"
     using reachable_constraints_preserves_labels[OF A] transaction_star_proj_has_star_labels
     unfolding list_all_iff by fastforce
 
   show "no_leakage A"
     using constr_sem_stateful_star_proj_no_leakage[OF Sec(2) A']
           unlabel_append[of A] singleton_lst_proj(4)[of k]
     unfolding no_leakage_def welltyped_constraint_model_def constraint_model_def by fastforce
 qed
 
 private lemma reachable_constraints_no_leakage_alt:
   fixes Sec P lbls k
   defines "no_leakage \<equiv> \<lambda>\<A>. \<nexists>\<I>\<^sub>\<tau> \<A>' s.
       prefix \<A>' \<A> \<and> (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>') \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>'@[(k,send\<langle>[s]\<rangle>)])"
     and "lbls \<equiv> \<lambda>T. map (the_LabelN o fst) (filter (Not o has_LabelS) (transaction_strand T))"
     and "L \<equiv> set (remdups (concat (map lbls P)))"
   assumes Sec: "\<forall>s \<in> Sec. \<not>{} \<turnstile>\<^sub>c s" "ground Sec"
     and lbl: "\<forall>l \<in> L. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) P). no_leakage \<A>"
   shows "\<forall>l. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) P). \<nexists>\<I>\<^sub>\<tau> \<A>'.
               interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>) \<and>
               prefix \<A>' \<A> \<and> (\<exists>l' ts. suffix [(l', receive\<langle>ts\<rangle>)] \<A>') \<and> strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' Sec \<I>\<^sub>\<tau>"
 proof (intro allI ballI)
   fix l \<A>
   assume \<A>: "\<A> \<in> reachable_constraints (map (transaction_proj l) P)"
 
   let ?Q = "\<lambda>\<I>\<^sub>\<tau> \<A>'.
     interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>) \<and>
     prefix \<A>' \<A> \<and> (\<exists>l' t. suffix [(l', receive\<langle>t\<rangle>)] \<A>') \<and> strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' Sec \<I>\<^sub>\<tau>"
 
   show "\<nexists>\<I>\<^sub>\<tau> \<A>'. ?Q \<I>\<^sub>\<tau> \<A>'"
   proof
     assume "\<exists>\<I>\<^sub>\<tau> \<A>'. ?Q \<I>\<^sub>\<tau> \<A>'"
     then obtain \<I>\<^sub>\<tau> \<A>' t n l' ts' where
         \<I>\<^sub>\<tau>: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau>" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>)" and
         \<A>': "prefix \<A>' \<A>" "suffix [(l', receive\<langle>ts'\<rangle>)] \<A>'" and
         t: "t \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau>" and
         n: "constr_sem_stateful \<I>\<^sub>\<tau> (proj_unl n \<A>'@[send\<langle>[t]\<rangle>])"
       unfolding strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by blast
     hence 0: "welltyped_constraint_model \<I>\<^sub>\<tau> (proj n \<A>'@[(m,send\<langle>[t]\<rangle>)])" for m
       unfolding welltyped_constraint_model_def constraint_model_def by fastforce
 
     have t_Sec: "\<not>{} \<turnstile>\<^sub>c t" "t \<cdot> \<I>\<^sub>\<tau> = t"
       using t Sec subst_ground_ident[of t \<I>\<^sub>\<tau>] by auto
 
     obtain B k' s where B:
         "constr_sem_stateful \<I>\<^sub>\<tau> (proj_unl n B@[send\<langle>[t]\<rangle>])"
         "prefix (proj n B) (proj n \<A>)" "suffix [(k', receive\<langle>s\<rangle>)] (proj n B)"
         "t \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj n B) \<I>\<^sub>\<tau>"
       using constr_sem_stateful_proj_priv_term_prefix_obtain[OF \<A>'(1) n t t_Sec]
       by metis
     hence 1: "welltyped_constraint_model \<I>\<^sub>\<tau> (proj n B@[(m,send\<langle>[t]\<rangle>)])" for m
       using 0 unfolding welltyped_constraint_model_def constraint_model_def by fastforce
 
     note 2 = reachable_constraints_transaction_proj_proj_eq
     note 3 = reachable_constraints_transaction_proj_star_proj
     note 4 = reachable_constraints_no_leakage_alt_aux
 
     note star_case = 0 t t_Sec(1) reachable_constraints_star_no_leakage[OF Sec]
                      \<A>'(2) 3[OF \<A>] prefix_proj(1)[OF \<A>'(1)]
                      suffix_proj(1)[OF \<A>'(2)] declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_proj_eq
 
     note lbl_case = 0 t(1) \<A> \<A>' lbl 2(2)[OF \<A> \<A>'(1)]
 
     show False
     proof (cases "l = n")
       case True thus ?thesis
       proof (cases "l \<in> L")
         case False
         hence "map (transaction_proj l) P = map transaction_star_proj P"
           using 4 unfolding L_def lbls_def by fast
         thus ?thesis
           using lbl_case(1-4,7) star_case(4,5) True by metis
       qed (metis lbl_case no_leakage_def)
     next
       case False
       hence "no_leakage (proj n \<A>)" using star_case(4,6) unfolding no_leakage_def by fast
       thus ?thesis by (metis B(2-4) 1 no_leakage_def)
     qed
   qed
 qed
 
 private lemma reachable_constraints_no_leakage_alt'_aux1:
   fixes P::"('a,'b,'c,'d) prot_transaction list"
   defines "f \<equiv> list_all ((list_all (Not \<circ> has_LabelS)) \<circ> tl \<circ> transaction_send)"
   assumes P: "f P"
   shows "f (map (transaction_proj l) P)"
     and "f (map transaction_star_proj P)"
 proof -
   let ?g = "\<lambda>T. tl (transaction_send T)"
   have "set (?g (transaction_proj l T)) \<subseteq> set (?g T)" (is "?A \<subseteq> ?C")
     and "set (?g (transaction_star_proj T)) \<subseteq> set (?g T)" (is "?B \<subseteq> ?C")
     for T::"('a,'b,'c,'d) prot_transaction"
   proof -
     obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T) simp
     have "transaction_send (transaction_proj l T) = proj l (transaction_send T)"
          "transaction_send (transaction_star_proj T) = filter has_LabelS (transaction_send T)"
       using transaction_proj.simps[of l T1 T2 T3 T4 T5 T6]
             transaction_star_proj.simps[of T1 T2 T3 T4 T5 T6]
       unfolding T proj_def Let_def by auto
     hence "set (?g (transaction_proj l T)) \<subseteq> set (proj l (?g T))"
           "set (?g (transaction_star_proj T)) \<subseteq> set (filter has_LabelS (?g T))"
       unfolding proj_def
       by (metis (no_types, lifting) filter.simps(2) list.collapse list.sel(2,3)
                                     list.set_sel(2) subsetI)+
     thus "?A \<subseteq> ?C" "?B \<subseteq> ?C" using T unfolding proj_def by auto
   qed
   thus "f (map (transaction_proj l) P)" "f (map transaction_star_proj P)"
     using P unfolding f_def list_all_iff by fastforce+
 qed
 
 private lemma reachable_constraints_no_leakage_alt'_aux2:
   fixes P
   defines "f \<equiv> \<lambda>T.
     list_all is_Receive (unlabel (transaction_receive T)) \<and>
     list_all is_Check_or_Assignment (unlabel (transaction_checks T)) \<and>
     list_all is_Update (unlabel (transaction_updates T)) \<and>
     list_all is_Send (unlabel (transaction_send T))"
   assumes P: "list_all f P"
   shows "list_all f (map (transaction_proj l) P)" (is ?A)
     and "list_all f (map transaction_star_proj P)" (is ?B)
 proof -
   have "f (transaction_proj l T)" (is ?A')
     and "f (transaction_star_proj T)" (is ?B')
     when T_in: "T \<in> set P" for T
   proof -
     obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T)
     have "f T" using P T_in unfolding list_all_iff by simp
     thus ?A' ?B'
       unfolding f_def T unlabel_def proj_def Let_def list_all_iff
                 transaction_proj.simps[of l T1 T2 T3 T4 T5 T6]
                 transaction_star_proj.simps[of T1 T2 T3 T4 T5 T6]
       by auto
   qed
   thus ?A ?B unfolding list_all_iff by auto
 qed
 
 private lemma reachable_constraints_no_leakage_alt':
   fixes Sec P lbls k
   defines "no_leakage \<equiv> \<lambda>\<A>. \<nexists>\<I>\<^sub>\<tau> \<A>' s.
       prefix \<A>' \<A> \<and> (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>') \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>'@[(k,send\<langle>[s]\<rangle>)])"
     and "no_leakage' \<equiv> \<lambda>\<A>. \<nexists>\<I>\<^sub>\<tau> s.
       (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>) \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[(k,send\<langle>[s]\<rangle>)])"
   assumes P: "list_all wellformed_transaction P"
              "list_all ((list_all (Not \<circ> has_LabelS)) \<circ> tl \<circ> transaction_send) P"
     and Sec: "\<forall>s \<in> Sec. \<not>{} \<turnstile>\<^sub>c s" "ground Sec"
     and lbl: "\<forall>l \<in> L. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) P). no_leakage' \<A>"
   shows "\<forall>l \<in> L. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) P). no_leakage \<A>" (is ?A)
     and "\<forall>\<A> \<in> reachable_constraints (map transaction_star_proj P). no_leakage \<A>" (is ?B)
 proof -
   define f where "f \<equiv> \<lambda>T::('fun,'atom,'sets,'lbl) prot_transaction.
     list_all is_Receive (unlabel (transaction_receive T)) \<and>
     list_all is_Check_or_Assignment (unlabel (transaction_checks T)) \<and>
     list_all is_Update (unlabel (transaction_updates T)) \<and>
     list_all is_Send (unlabel (transaction_send T))"
 
   define g where "(g::('fun,'atom,'sets,'lbl) prot_transaction \<Rightarrow> bool) \<equiv> 
     list_all (Not \<circ> has_LabelS) \<circ> tl \<circ> transaction_send"
 
   have P': "list_all f P"
     using P(1) unfolding wellformed_transaction_def f_def list_all_iff by fastforce
 
   note 0 = reachable_constraints_no_leakage_alt'_aux1[OF P(2), unfolded g_def[symmetric]]
 
   note 1 = reachable_constraints_no_leakage_alt'_aux2[
             OF P'[unfolded f_def], unfolded f_def[symmetric]]
 
   note 2 = reachable_constraints_aligned_prefix_ex[unfolded f_def[symmetric] g_def[symmetric]]
 
   have 3: "\<forall>\<A> \<in> reachable_constraints (map transaction_star_proj P). no_leakage' \<A>"
     using reachable_constraints_star_no_leakage[OF Sec] unfolding no_leakage'_def by blast
 
   show ?A
   proof (intro ballI)
     fix l \<A> assume l: "l \<in> L" and \<A>: "\<A> \<in> reachable_constraints (map (transaction_proj l) P)"
     show "no_leakage \<A>"
     proof (rule ccontr)
       assume "\<not>no_leakage \<A>"
       then obtain \<I>\<^sub>\<tau> \<A>' s where \<A>':
           "prefix \<A>' \<A>" "\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>'" "s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau>"
           "welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>'@[(k, send\<langle>[s]\<rangle>)])"
         unfolding no_leakage_def by blast
 
       have s: "\<not>{} \<turnstile>\<^sub>c s" "fv s = {}" using \<A>'(3) Sec by auto
 
       have \<I>\<^sub>\<tau>: "constr_sem_stateful \<I>\<^sub>\<tau> (unlabel \<A>'@[send\<langle>[s]\<rangle>])"
               "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau>" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>)"
         using \<A>'(4) unfolding welltyped_constraint_model_def constraint_model_def by auto
 
       show False
         using 2[OF 1(1) 0(1) s \<A> \<A>'(1,2) \<I>\<^sub>\<tau>(1)] l lbl \<A>'(3) \<I>\<^sub>\<tau>(2,3,4)
               singleton_lst_proj(4)[of k "send\<langle>[s]\<rangle>"] unlabel_append[of _ "[(k, send\<langle>[s]\<rangle>)]"]
         unfolding no_leakage'_def welltyped_constraint_model_def constraint_model_def by metis
     qed
   qed
 
   show ?B
   proof (intro ballI)
     fix \<A> assume \<A>: "\<A> \<in> reachable_constraints (map transaction_star_proj P)"
     show "no_leakage \<A>"
     proof (rule ccontr)
       assume "\<not>no_leakage \<A>"
       then obtain \<I>\<^sub>\<tau> \<A>' s where \<A>':
           "prefix \<A>' \<A>" "\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>'" "s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau>"
           "welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>'@[(k, send\<langle>[s]\<rangle>)])"
         unfolding no_leakage_def by blast
 
       have s: "\<not>{} \<turnstile>\<^sub>c s" "fv s = {}" using \<A>'(3) Sec by auto
 
       have \<I>\<^sub>\<tau>: "constr_sem_stateful \<I>\<^sub>\<tau> (unlabel \<A>'@[send\<langle>[s]\<rangle>])"
               "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau>" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>)"
         using \<A>'(4) unfolding welltyped_constraint_model_def constraint_model_def by auto
 
       show False
         using 2[OF 1(2) 0(2) s \<A> \<A>'(1,2) \<I>\<^sub>\<tau>(1)] 3 \<A>'(3) \<I>\<^sub>\<tau>(2,3,4)
               singleton_lst_proj(4)[of k "send\<langle>[s]\<rangle>"] unlabel_append[of _ "[(k, send\<langle>[s]\<rangle>)]"]
         unfolding no_leakage'_def welltyped_constraint_model_def constraint_model_def by metis
     qed
   qed
 qed
 
 lemma composable_protocols_par_comp_prot_alt:
   fixes S f Sec lbls Ps
   defines "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}}"
     and "Sec \<equiv> (f (set S)) - {m. {} \<turnstile>\<^sub>c m}"
     and "lbls \<equiv> \<lambda>T. map (the_LabelN o fst) (filter (Not o has_LabelS) (transaction_strand T))"
     and "L \<equiv> set (remdups (concat (map lbls (concat Ps))))"
     and "no_leakage \<equiv> \<lambda>\<A>. \<nexists>\<I>\<^sub>\<tau> \<A>' s.
       prefix \<A>' \<A> \<and> (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>') \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>'@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
   assumes Ps_pc: "wellformed_composable_protocols Ps N"
                  "wellformed_composable_protocols' Ps"
                  "composable_protocols Ps Ms S"
     and component_secure:
           "\<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) (concat Ps)). \<nexists>\<I>.
               welltyped_constraint_model \<I> (\<A>@[\<langle>l, send\<langle>[attack\<langle>ln l\<rangle>]\<rangle>\<rangle>])"
     and no_leakage:
           "\<forall>l \<in> L. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) (concat Ps)). no_leakage \<A>"
   shows "\<forall>\<A> \<in> reachable_constraints (concat Ps). \<nexists>\<I>.
             constraint_model \<I> (\<A>@[\<langle>l, send\<langle>[attack\<langle>ln l\<rangle>]\<rangle>\<rangle>])"
 proof
   fix \<A>
   assume \<A>: "\<A> \<in> reachable_constraints (concat Ps)"
   let ?att = "[\<langle>l, send\<langle>[attack\<langle>ln l\<rangle>]\<rangle>\<rangle>]"
 
   define Q where "Q \<equiv> \<lambda>\<I>\<^sub>\<tau>. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>)"
 
   define R where "R \<equiv> \<lambda>\<A> \<I>\<^sub>\<tau>.
     \<exists>\<A>' l t. prefix \<A>' \<A> \<and> suffix [(l, receive\<langle>t\<rangle>)] \<A>' \<and> strand_leaks\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A>' Sec \<I>\<^sub>\<tau>"
 
   define M where "M \<equiv> \<Union>T\<in>set (concat Ps). trms_transaction T \<union> pair' Pair ` setops_transaction T"
 
   have Sec: "\<forall>s \<in> Sec. \<not>{} \<turnstile>\<^sub>c s" "ground Sec" unfolding Sec_def f_def by auto
 
   have par_comp':
       "\<forall>\<A> \<in> reachable_constraints (concat Ps). \<forall>\<I>. constraint_model \<I> \<A> \<longrightarrow>
          (\<exists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> \<A> \<and>
               ((\<forall>n. welltyped_constraint_model \<I>\<^sub>\<tau> (proj n \<A>)) \<or> R \<A> \<I>\<^sub>\<tau>))"
     using \<A> composable_protocols_par_comp_constr[OF Ps_pc] unfolding Sec_def f_def R_def by fast
 
   have "\<forall>l. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) (concat Ps)). \<nexists>\<I>\<^sub>\<tau>. Q \<I>\<^sub>\<tau> \<and> R \<A> \<I>\<^sub>\<tau>"
     using reachable_constraints_no_leakage_alt[OF
             Sec no_leakage[unfolded no_leakage_def L_def lbls_def]]
     unfolding Q_def R_def by blast
   hence no_leakage':
       "\<forall>\<A> \<in> reachable_constraints (concat Ps). \<nexists>\<I>\<^sub>\<tau>. Q \<I>\<^sub>\<tau> \<and> R \<A> \<I>\<^sub>\<tau>"
     using reachable_constraints_component_leaks_if_composed_leaks[OF Sec, of "concat Ps"
             "\<lambda>\<I>\<^sub>\<tau>. interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<I>\<^sub>\<tau> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<I>\<^sub>\<tau>)"]
     unfolding Q_def R_def by blast
 
   have M: "has_all_wt_instances_of \<Gamma> M (set N)" "finite (set N)" "tfr\<^sub>s\<^sub>e\<^sub>t (set N)" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set N)"
    and P: "\<forall>T \<in> set (concat Ps). wellformed_transaction T"
           "\<forall>T \<in> set (concat Ps). admissible_transaction_terms T"
           "\<forall>T \<in> set (concat Ps). \<forall>x \<in> vars_transaction T. \<not>TAtom AttackType \<sqsubseteq> \<Gamma>\<^sub>v x"
           "\<forall>T \<in> set (concat Ps). \<forall>s \<in> set (transaction_strand T).
               is_Send (snd s) \<and> length (the_msgs (snd s)) = 1 \<and>
               is_Fun_Attack (hd (the_msgs (snd s))) \<longrightarrow>
                 the_Attack_label (the_Fun (hd (the_msgs (snd s)))) = fst s"
           "\<forall>T \<in> set (concat Ps). list_all tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p (unlabel (transaction_strand T))"
     using Ps_pc(1,2) tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p_is_comp_tfr\<^sub>s\<^sub>s\<^sub>t\<^sub>p
     unfolding wellformed_composable_protocols_def wellformed_composable_protocols'_def
               list_all_iff Let_def M_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s'_def wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s_code unlabel_def \<Gamma>\<^sub>v_TAtom''(1,2)
     by (force, force, fast, fast, fast, fast, fast, simp, simp)
 
   have P_fresh: "\<forall>T \<in> set (concat Ps). \<forall>x \<in> set (transaction_fresh T).
                   \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a))"
       (is "\<forall>T \<in> ?P. \<forall>x \<in> ?frsh T. ?Q x")
   proof (intro ballI)
     fix T x assume T: "T \<in> ?P" "x \<in> ?frsh T"
     hence "\<Gamma>\<^sub>v x = TAtom Value \<or> (is_Var (\<Gamma>\<^sub>v x) \<and> is_Atom (the_Var (\<Gamma>\<^sub>v x)))"
       using Ps_pc(1) unfolding wellformed_composable_protocols_def list_all_iff Let_def by fastforce
     thus "?Q x" by (metis prot_atom.is_Atom_def term.collapse(1))
   qed
 
   have P': "\<forall>T \<in> set (concat Ps). wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s' arity (trms_transaction T)"
     using P(2) admissible_transaction_terms_def by fast
 
   have "\<not>welltyped_constraint_model \<I> (\<A>@?att)" for \<I>
   proof
     assume "welltyped_constraint_model \<I> (\<A>@?att)"
     hence \<I>: "welltyped_constraint_model \<I> \<A>" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I> \<turnstile> attack\<langle>ln l\<rangle>"
       using strand_sem_append_stateful[of "{}" "{}" "unlabel \<A>" "unlabel ?att"]
             unlabel_append[of \<A> ?att]
       unfolding welltyped_constraint_model_def constraint_model_def by auto
 
     obtain \<I>\<^sub>\<tau> where \<I>\<^sub>\<tau>:
         "welltyped_constraint_model \<I>\<^sub>\<tau> \<A>"
         "welltyped_constraint_model \<I>\<^sub>\<tau> (proj l \<A>)"
       using \<A> \<I> no_leakage' par_comp'
       unfolding Q_def welltyped_constraint_model_def constraint_model_def by metis
 
     have "\<langle>l, receive\<langle>[attack\<langle>ln l\<rangle>]\<rangle>\<rangle> \<in> set \<A>"
       using reachable_constraints_receive_attack_if_attack(3)[OF \<A> P(1-2) P_fresh P(3) \<I> P(4)]
       by auto
     hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>\<^sub>\<tau> \<turnstile> attack\<langle>ln l\<rangle>"
       using in_proj_set[of l "receive\<langle>[attack\<langle>ln l\<rangle>]\<rangle>" \<A>] in_ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t_iff[of "attack\<langle>ln l\<rangle>" "proj l \<A>"]
             intruder_deduct.Axiom[of "attack\<langle>ln l\<rangle>" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (proj l \<A>) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<I>\<^sub>\<tau>"]
       by fastforce
     hence "welltyped_constraint_model \<I>\<^sub>\<tau> (proj l \<A>@?att)"
       using \<I>\<^sub>\<tau> strand_sem_append_stateful[of "{}" "{}" "unlabel (proj l \<A>)" "unlabel ?att" \<I>\<^sub>\<tau>]
       unfolding welltyped_constraint_model_def constraint_model_def by auto
     thus False
       using component_secure reachable_constraints_transaction_proj[OF \<A>, of l] by simp
   qed
   thus "\<nexists>\<I>. constraint_model \<I> (\<A>@?att)"
     using reachable_constraints_typing_result'[OF M_def M P(1) P' P(5) \<A>] by blast
 qed
 
 lemma composable_protocols_par_comp_prot:
   fixes S f Sec lbls Ps
   defines "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}}"
     and "Sec \<equiv> (f (set S)) - {m. {} \<turnstile>\<^sub>c m}"
     and "lbls \<equiv> \<lambda>T. map (the_LabelN o fst) (filter (Not o has_LabelS) (transaction_strand T))"
     and "L \<equiv> set (remdups (concat (map lbls (concat Ps))))"
     and "no_leakage \<equiv> \<lambda>\<A>. \<nexists>\<I>\<^sub>\<tau> s.
       (\<exists>l ts. suffix [(l, receive\<langle>ts\<rangle>)] \<A>) \<and> s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<A> \<I>\<^sub>\<tau> \<and>
       welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
   assumes Ps_pc: "wellformed_composable_protocols Ps N"
                  "wellformed_composable_protocols' Ps"
                  "composable_protocols Ps Ms S"
                  "list_all ((list_all (Not \<circ> has_LabelS)) \<circ> tl \<circ> transaction_send) (concat Ps)"
     and component_secure:
           "\<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) (concat Ps)). \<nexists>\<I>.
               welltyped_constraint_model \<I> (\<A>@[\<langle>l, send\<langle>[attack\<langle>ln l\<rangle>]\<rangle>\<rangle>])"
     and no_leakage:
           "\<forall>l \<in> L. \<forall>\<A> \<in> reachable_constraints (map (transaction_proj l) (concat Ps)). no_leakage \<A>"
   shows "\<forall>\<A> \<in> reachable_constraints (concat Ps). \<nexists>\<I>.
             constraint_model \<I> (\<A>@[\<langle>l, send\<langle>[attack\<langle>ln l\<rangle>]\<rangle>\<rangle>])"
 proof -
   have P': "list_all wellformed_transaction (concat Ps)"
     using Ps_pc(2) unfolding wellformed_composable_protocols'_def by meson
 
   have Sec: "\<forall>s \<in> Sec. \<not>{} \<turnstile>\<^sub>c s" "ground Sec" unfolding Sec_def f_def by auto
 
   note 0 = composable_protocols_par_comp_prot_alt[
             OF Ps_pc(1-3) component_secure, unfolded lbls_def[symmetric] L_def[symmetric]]
 
   note 1 = reachable_constraints_no_leakage_alt'[
             OF P' Ps_pc(4) Sec no_leakage[unfolded no_leakage_def]]
 
   show ?thesis using 0 1 unfolding f_def Sec_def by argo
 qed
 
 lemma composable_protocols_par_comp_prot':
   assumes P_defs:
       "Pc = concat Ps"
       "set Ps_with_stars =
         (\<lambda>n. map (transaction_proj n) Pc) `
           set (remdups (concat
                 (map (\<lambda>T. map (the_LabelN \<circ> fst) (filter (Not \<circ> has_LabelS) (transaction_strand T)))
                   Pc)))"
     and Ps_wellformed:
       "list_all (list_all (Not \<circ> has_LabelS) \<circ> tl \<circ> transaction_send) Pc"
       "wellformed_composable_protocols Ps N"
       "wellformed_composable_protocols' Ps"
       "composable_protocols Ps Ms S"
     and Ps_no_leakage:
       "list_all (welltyped_leakage_free_protocol S) Ps_with_stars"
     and P_def:
       "P = map (transaction_proj n) Pc"
     and P_wt_secure:
       "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>.
         welltyped_constraint_model \<I> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
   shows "\<forall>\<A> \<in> reachable_constraints Pc. \<nexists>\<I>.
           constraint_model \<I> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
 by (rule composable_protocols_par_comp_prot[
           OF Ps_wellformed(2,3,4,1)[unfolded P_defs(1)]
              P_wt_secure[unfolded P_def[unfolded P_defs(1)]]
              transaction_proj_ball_subst[
                OF P_defs(2)[unfolded P_defs(1)]
                   Ps_no_leakage(1)[
                     unfolded list_all_iff welltyped_leakage_free_protocol_def Let_def]],
           unfolded P_defs(1)[symmetric]])
 
 end
 
 context
 begin
 
 lemma welltyped_constraint_model_leakage_model_swap:
   fixes I \<alpha> \<delta>::"('fun,'atom,'sets,'lbl) prot_subst" and s
   assumes A: "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>])"
     and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     and \<delta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "subst_domain \<delta> = fv s" "ground (subst_range \<delta>)"
   obtains J
     where "welltyped_constraint_model J (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>])"
     and "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> s \<cdot> \<alpha> \<cdot> J"
 proof
   note defs = welltyped_constraint_model_def constraint_model_def
   note \<delta>_s = subst_fv_dom_ground_if_ground_img[OF equalityD2[OF \<delta>(3)] \<delta>(4)]
   note \<alpha>' = transaction_renaming_subst_is_renaming(2)[OF \<alpha>]
             inj_on_subset[OF transaction_renaming_subst_is_injective[OF \<alpha>]
                              subset_UNIV[of "fv s"]]
             transaction_renaming_subst_var_obtain(2)[OF \<alpha>, of _ s]
             transaction_renaming_subst_is_renaming(6)[OF \<alpha>, of s]
             transaction_renaming_subst_vars_disj(8)[OF \<alpha>]
             transaction_renaming_subst_wt[OF \<alpha>]
 
   define \<alpha>inv where "\<alpha>inv \<equiv> subst_var_inv \<alpha> (fv s)"
   define \<delta>' where "\<delta>' \<equiv> rm_vars (UNIV - fv (s \<cdot> \<alpha>)) (\<alpha>inv \<circ>\<^sub>s \<delta>)"
   define J where "J \<equiv> \<lambda>x. if x \<in> fv (s \<cdot> \<alpha>) then \<delta>' x else I x"
 
   have \<alpha>_invertible: "s = s \<cdot> \<alpha> \<circ>\<^sub>s \<alpha>inv"
     using \<alpha>'(1) inj_var_ran_subst_is_invertible'[of \<alpha> s] inj_on_subset[OF \<alpha>'(2)]
     unfolding \<alpha>inv_def by blast
 
   have \<delta>'_domain: "subst_domain \<delta>' = fv (s \<cdot> \<alpha>)"
   proof -
     have "x \<in> subst_domain (\<alpha>inv \<circ>\<^sub>s \<delta>)" when x: "x \<in> fv (s \<cdot> \<alpha>)" for x
     proof -
       obtain y where y: "y \<in> fv s" "\<alpha> y = Var x"
         using \<alpha>'(3)[OF x] by blast
   
       have "y \<in> subst_domain \<delta>" using y(1) \<delta>(3) by blast
       moreover have "(\<alpha>inv \<circ>\<^sub>s \<delta>) x = \<delta> y"
         using y \<alpha>'(3)[OF x] \<alpha>_invertible
               vars_term_subset_subst_eq[of "Var y" s "\<alpha> \<circ>\<^sub>s \<alpha>inv" Var]
         unfolding \<delta>'_def \<alpha>inv_def
         by (metis (no_types, lifting) fv_subst_subset eval_term.simps(1)
                   subst_apply_term_empty subst_compose) 
       ultimately show ?thesis using \<delta>(4) by fastforce
     qed
     thus ?thesis using rm_vars_dom[of "UNIV - fv (s \<cdot> \<alpha>)" "\<alpha>inv \<circ>\<^sub>s \<delta>"] unfolding \<delta>'_def by blast
   qed
 
   have \<delta>'_range: "fv t = {}" when t: "t \<in> (subst_range \<delta>')" for t
   proof -
     obtain x where "x \<in> fv (s \<cdot> \<alpha>)" "\<delta>' x = t" using t \<delta>'_domain by auto
     thus ?thesis
       by (metis (no_types, lifting) \<delta>'_def subst_compose_def \<delta>(3,4) \<alpha>_invertible fv_subst_subset
             subst_fv_dom_ground_if_ground_img subst_subst_compose Diff_iff)
   qed
 
   have J0: "x \<in> fv (s \<cdot> \<alpha>) \<Longrightarrow> J x = \<delta>' x"
            "x \<notin> fv (s \<cdot> \<alpha>) \<Longrightarrow> J x = I x" for x
     unfolding J_def by (cases "x \<in> fv (s \<cdot> \<alpha>)") (simp_all add: subst_compose)
 
   have J1: "subst_range J \<subseteq> subst_range \<delta>' \<union> subst_range I"
   proof
     fix t assume "t \<in> subst_range J"
     then obtain x where x: "x \<in> subst_domain J" "J x = t" by auto
     hence "t = \<delta>' x \<Longrightarrow> x \<in> subst_domain \<delta>'" "t = I x \<Longrightarrow> x \<in> subst_domain I"
       by (metis subst_domI subst_dom_vars_in_subst)+
     thus "t \<in> subst_range \<delta>' \<union> subst_range I" using x(2) J0[of x] by auto
   qed
   
   have "x \<notin> fv (s \<cdot> \<alpha>)" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>])" for x
     using x \<delta>_s \<alpha>'(4) \<alpha>'(5) by auto
   hence "I x = J x" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>])" for x
     using x unfolding J_def \<delta>'_def by auto
   hence "constr_sem_stateful J (unlabel (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>]))"
     using A strand_sem_model_swap[of "unlabel (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>])" I J "{}" "{}"]
     unfolding defs by blast
   moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t J"
     using A subst_var_inv_wt[OF \<alpha>'(6), of "fv s"]
           wt_subst_trm''[OF \<delta>(1)] subst_compose[of "subst_var_inv \<alpha> (fv s)" \<delta>]
     unfolding defs J_def \<delta>'_def \<alpha>inv_def wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by presburger
   moreover have "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t J"
   proof -
     have "fv t = {}" when t: "t \<in> (subst_range J)" for t
       using t A J1 \<delta>'_range unfolding defs by auto
     moreover have "x \<in> subst_domain J" for x
     proof (cases "x \<in> fv (s \<cdot> \<alpha>)")
       case True thus ?thesis using J0(1)[of x] \<delta>'_domain unfolding subst_domain_def by auto
     next
       case False
       have "subst_domain I = UNIV" using A unfolding defs by fast
       thus ?thesis using J0(2)[OF False] unfolding subst_domain_def by auto
     qed
     ultimately show ?thesis by auto
   qed
   moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>')"
     using wf_trms_subst_compose[OF subst_var_inv_wf_trms[of \<alpha> "fv s"] \<delta>(2)]
     unfolding \<delta>'_def \<alpha>inv_def by force
   hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range J)" using A J1 unfolding defs by fast
   ultimately show "welltyped_constraint_model J (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<delta>]\<rangle>\<rangle>])" unfolding defs by blast
   hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> s \<cdot> \<delta>"
     using \<delta>_s strand_sem_append_stateful[of "{}" "{}" "unlabel A" "[send\<langle>[s \<cdot> \<delta>]\<rangle>]" J]
     unfolding defs by (simp add: subst_ground_ident)
   moreover have "s \<cdot> \<alpha> \<cdot> J = s \<cdot> \<delta>"
   proof -
     have "J x = \<delta>' x" when x: "x \<in> fv (s \<cdot> \<alpha>)" for x using x unfolding J_def by argo
     hence "s \<cdot> \<alpha> \<cdot> J = s \<cdot> \<alpha> \<cdot> \<delta>'" using subst_agreement[of "s \<cdot> \<alpha>" J \<delta>'] by force
     thus ?thesis
       using \<alpha>_invertible unfolding \<delta>'_def rm_vars_subst_eq'[symmetric] by (metis subst_subst_compose)
   qed
   hence "s \<cdot> \<alpha> \<cdot> J = s \<cdot> \<delta>" by auto
   ultimately show "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> s \<cdot> \<alpha> \<cdot> J" by argo
 qed
 
 lemma welltyped_leakage_free_protocol_pointwise:
   "welltyped_leakage_free_protocol S P \<longleftrightarrow> list_all (\<lambda>s. welltyped_leakage_free_protocol [s] P) S"
 unfolding welltyped_leakage_free_protocol_def list_all_iff Let_def by fastforce
 
 lemma welltyped_leakage_free_no_deduct_constI:
   fixes c
   defines "s \<equiv> Fun c []::('fun,'atom,'sets,'lbl) prot_term"
   assumes s: "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
   shows "welltyped_leakage_free_protocol [s] P"
 using s unfolding welltyped_leakage_free_protocol_def s_def by auto
 
 lemma welltyped_leakage_free_pub_termI:
   assumes s: "{} \<turnstile>\<^sub>c s"
   shows "welltyped_leakage_free_protocol [s] P"
 proof -
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define f where "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. Q M t \<delta>}"
   define Sec where "Sec \<equiv> f (set [s]) - {m. {} \<turnstile>\<^sub>c m}"
 
   have 0: "fv s = {}" using s pgwt_ground pgwt_is_empty_synth by blast 
   have 1: "s \<cdot> \<delta> = s" for \<delta> by (rule subst_ground_ident[OF 0])
   have 2: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range Var)"
     using wt_subst_Var wf_trm_subst_range_Var by (blast,blast)
   
   have "f (set [s]) = {s}"
   proof
     show "f (set [s]) \<subseteq> {s}" using 0 1 unfolding f_def Q_def by auto 
 
     have "Q {s} s Var" using 0 2 unfolding Q_def by auto
     thus "{s} \<subseteq> f (set [s])" using 1[of Var] unfolding f_def by force
   qed
   hence "Sec = {}" using s unfolding Sec_def by simp
   thus ?thesis unfolding welltyped_leakage_free_protocol_def Let_def Sec_def f_def Q_def by blast
 qed
 
 lemma welltyped_leakage_free_pub_constI:
   assumes c: "public\<^sub>f c" "arity\<^sub>f c = 0"
   shows "welltyped_leakage_free_protocol [\<langle>c\<rangle>\<^sub>c] P"
 using c welltyped_leakage_free_pub_termI[OF intruder_synth.ComposeC[of "[]" "Fu c" "{}"]] by simp
 
 lemma welltyped_leakage_free_long_term_secretI:
   fixes n
   defines
       "Tatt \<equiv> \<lambda>s'. Transaction (\<lambda>(). []) [] [\<langle>n, receive\<langle>[s']\<rangle>\<rangle>] [] [] [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
   assumes P_wt_secure:
       "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>.
         welltyped_constraint_model \<I> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
     and s_long_term_secret:
       "\<exists>\<theta>. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta> \<and> inj_on \<theta> (fv s) \<and> \<theta> ` fv s \<subseteq> range Var \<and> Tatt (s \<cdot> \<theta>) \<in> set P"
   shows "welltyped_leakage_free_protocol [s] P"
 proof (rule ccontr)
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define f where "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. Q M t \<delta>}"
   define Sec where "Sec \<equiv> f (set [s]) - {m. {} \<turnstile>\<^sub>c m}"
 
   note defs = Sec_def f_def Q_def
   note defs' = welltyped_constraint_model_def constraint_model_def
 
   assume "\<not>welltyped_leakage_free_protocol [s] P"
   then obtain A I s' where A:
       "A \<in> reachable_constraints P" "s' \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
       "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[s']\<rangle>\<rangle>])"
     unfolding welltyped_leakage_free_protocol_def defs by fastforce
 
   obtain \<theta> where \<theta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta>" "\<theta> ` fv s \<subseteq> range Var" "inj_on \<theta> (fv s)" "Tatt (s \<cdot> \<theta>) \<in> set P"
     using s_long_term_secret by blast
 
   obtain \<delta> where \<delta>:
     "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "subst_domain \<delta> = fv (s \<cdot> \<theta>)" "ground (subst_range \<delta>)"
     "s' = s \<cdot> \<theta> \<cdot> \<delta>"
   proof -
     obtain \<delta> where *: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "fv s' = {}" "s' = s \<cdot> \<delta>"
       using A(2) unfolding defs by auto
 
     define \<sigma> where "\<sigma> \<equiv> subst_var_inv \<theta> (fv s) \<circ>\<^sub>s \<delta>"
     define \<delta>' where "\<delta>' \<equiv> rm_vars (UNIV - fv (s \<cdot> \<theta>)) \<sigma>"
 
     have **: "s' = s \<cdot> \<theta> \<cdot> \<sigma>"
       using *(4) inj_var_ran_subst_is_invertible[OF \<theta>(3,2)]
       unfolding \<sigma>_def by simp
     
     have "s' = s \<cdot> \<theta> \<cdot> \<delta>'"
       using ** rm_vars_subst_eq'[of "s \<cdot> \<theta>" \<sigma>]
       unfolding \<delta>'_def by simp
     moreover have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<sigma>"
       using \<theta>(1) *(1) subst_var_inv_wt wt_subst_compose
       unfolding \<sigma>_def by presburger
     hence "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>'" using wt_subst_rm_vars unfolding \<delta>'_def by blast
     moreover have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<sigma>)"
       using wf_trms_subst_compose[OF subst_var_inv_wf_trms *(2)] unfolding \<sigma>_def by blast
     hence "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>')" using wf_trms_subst_rm_vars'[of \<sigma>] unfolding \<delta>'_def by blast
     moreover have "fv (s \<cdot> \<theta>) \<subseteq> subst_domain \<sigma>"
       using *(3) ** ground_term_subst_domain_fv_subset unfolding \<sigma>_def by blast
     hence "subst_domain \<delta>' = fv (s \<cdot> \<theta>)"
       using rm_vars_dom[of "UNIV - fv (s \<cdot> \<theta>)" \<sigma>] unfolding \<delta>'_def by blast
     moreover have "ground (subst_range \<delta>')"
     proof -
       { fix t assume "t \<in> subst_range \<delta>'"
         then obtain x where "x \<in> fv (s \<cdot> \<theta>)" "\<delta>' x = t"
           using \<open>subst_domain \<delta>' = fv (s \<cdot> \<theta>)\<close> by auto
         hence "t \<sqsubseteq> s \<cdot> \<theta> \<cdot> \<delta>'" by (meson subst_mono_fv)
         hence "fv t = {}" using \<open>s' = s \<cdot> \<theta> \<cdot> \<delta>'\<close> *(3) ground_subterm by blast
       } thus ?thesis by force
     qed
     ultimately show thesis using that[of \<delta>'] by fast
   qed
 
   have \<xi>: "transaction_decl_subst Var (Tatt t)"
     and \<sigma>: "transaction_fresh_subst Var (Tatt t) (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     for t
     unfolding transaction_decl_subst_def transaction_fresh_subst_def Tatt_def by simp_all
 
   obtain \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
     where \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
     unfolding transaction_renaming_subst_def by blast
 
   obtain J where J:
       "welltyped_constraint_model J (A@[\<langle>\<star>, send\<langle>[s \<cdot> \<theta> \<cdot> \<delta>]\<rangle>\<rangle>])" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> s \<cdot> \<theta> \<cdot> \<alpha> \<cdot> J"
     using welltyped_constraint_model_leakage_model_swap[OF A(3)[unfolded \<delta>(5)] \<alpha> \<delta>(1-4)] by blast
 
   define T where "T = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand (Tatt (s \<cdot> \<theta>)) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>)"
   define B where "B \<equiv> A@T"
 
   have "transaction_receive (Tatt t) = [\<langle>n, receive\<langle>[t]\<rangle>\<rangle>]"
        "transaction_checks (Tatt t) = []"
        "transaction_updates (Tatt t) = []"
        "transaction_send (Tatt t) = [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
     for t
     unfolding Tatt_def by simp_all
   hence T_def': "T = [\<langle>n, send\<langle>[s \<cdot> \<theta> \<cdot> \<alpha>]\<rangle>\<rangle>, \<langle>n, receive\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
     using subst_lsst_append[of "transaction_receive (Tatt (s \<cdot> \<theta>))" _ \<alpha>]
           subst_lsst_singleton[of "ln n" "receive\<langle>[s \<cdot> \<theta>]\<rangle>" \<alpha>]
           subst_lsst_singleton[of "ln n" "send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>" \<alpha>]
     unfolding transaction_strand_def T_def by fastforce
   
   have B0: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t B \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> attack\<langle>ln n\<rangle>"
     using in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of "attack\<langle>ln n\<rangle>" "unlabel T"]
     unfolding B_def T_def' by (force intro!: intruder_deduct.Axiom)
 
   have B1: "B \<in> reachable_constraints P"
     using reachable_constraints.step[OF A(1) \<theta>(4) \<xi> \<sigma> \<alpha>]
     unfolding B_def T_def by simp
 
   have "welltyped_constraint_model J B"
     using J strand_sem_append_stateful[of "{}" "{}" "unlabel A" _ J]
     unfolding defs' B_def T_def' by fastforce
   hence B2: "welltyped_constraint_model J (B@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
     using B0 strand_sem_append_stateful[of "{}" "{}" "unlabel B" "[send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>]" J]
     unfolding defs' B_def by auto
 
   show False using P_wt_secure B1 B2 by blast
 qed
 
 lemma welltyped_leakage_free_value_constI:
   assumes P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. admissible_transaction_terms T"
       "\<forall>T \<in> set P. transaction_decl T () = []"
       "\<forall>T \<in> set P. bvars_transaction T = {}"
     and P_fresh_declass:
       "\<forall>T \<in> set P. transaction_fresh T \<noteq> [] \<longrightarrow>
         (transaction_send T \<noteq> [] \<and> (let (l,a) = hd (transaction_send T)
           in l = \<star> \<and> is_Send a \<and> Var ` set (transaction_fresh T) \<subseteq> set (the_msgs a)))"
   shows "welltyped_leakage_free_protocol [\<langle>m: value\<rangle>\<^sub>v] P"
 proof (rule ccontr)
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define f where "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. Q M t \<delta>}"
   define Sec where "Sec \<equiv> f (set [\<langle>m: value\<rangle>\<^sub>v]) - {m. {} \<turnstile>\<^sub>c m}"
 
   note defs = Sec_def f_def Q_def
   note defs' = welltyped_constraint_model_def constraint_model_def
 
   assume "\<not>welltyped_leakage_free_protocol [\<langle>m: value\<rangle>\<^sub>v] P"
   then obtain A I s where A:
       "A \<in> reachable_constraints P" "s \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
       "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
     unfolding welltyped_leakage_free_protocol_def defs by fastforce
 
   have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> s \<cdot> I" using welltyped_constraint_model_deduct_split[OF A(3)] by simp
   moreover have "s \<cdot> I = s" using A(2) unfolding defs by fast
   ultimately have s_deduct: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I) \<turnstile> s" by (metis ik\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst)
 
   note I0 = welltyped_constraint_model_prefix[OF A(3)]
 
   have I1: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" using A(3) unfolding defs' by blast
 
   obtain f ts \<delta> where f: "s = Fun f ts" "s = \<langle>m: value\<rangle>\<^sub>v \<cdot> \<delta>" "\<not>{} \<turnstile>\<^sub>c s" "s \<notin> declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
       and \<delta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "fv s = {}"
     using A(2) unfolding defs by (cases s) auto
 
   have s1: "\<Gamma> s = TAtom Value"
     by (metis \<Gamma>.simps(1) \<Gamma>\<^sub>v_TAtom f(2) wt_subst_trm''[OF \<delta>(1)]) 
 
   have s2: "wf\<^sub>t\<^sub>r\<^sub>m s"
     using f(2) \<delta>(2) by force
   
   have s3: "ts = []"
     using f(1) s1 s2 const_type_inv_wf by blast
 
   obtain sn where sn: "s = Fun (Val sn) []"
     using s1 f(3) \<Gamma>_Fu_simps(4) \<Gamma>_Set_simps(3) unfolding f(1) s3 by (cases f) auto
 
   have "s \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
     using private_fun_deduct_in_ik'[OF s_deduct[unfolded sn]]
     by (metis sn public.simps(3) ik\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst)
   hence s4: "s \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
     using constraint_model_Val_const_in_constr_prefix[OF A(1) I0 P(1,2)]
     unfolding sn by presburger
 
   obtain B T \<xi> \<sigma> \<alpha> where B:
       "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
       "B \<in> reachable_constraints P" "T \<in> set P" "transaction_decl_subst \<xi> T"
       "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)" "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
       "s \<in> subst_range \<sigma>"
     using constraint_model_Value_in_constr_prefix_fresh_action'[OF A(1) P(2-) s4[unfolded sn]] sn
     by blast
 
   obtain Tts Tsnds sx
     where T: "transaction_send T = \<langle>\<star>, send\<langle>Tts\<rangle>\<rangle>#Tsnds" "Var ` set (transaction_fresh T) \<subseteq> set Tts"
       and sx: "Var sx \<in> set Tts" "\<sigma> sx = s"
     using P_fresh_declass B(3,5,7)
     unfolding transaction_fresh_subst_def is_Send_def
     by (cases "transaction_send T") (fastforce,fastforce)
 
   have \<xi>_elim: "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> = \<sigma> \<circ>\<^sub>s \<alpha>"
     using admissible_transaction_decl_subst_empty'[OF bspec[OF P(3) B(3)] B(4)]
     by simp
 
   have s5: "s \<in> set (Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s I)"
     using sx unfolding \<xi>_elim sn by force
 
   have s6: "\<langle>\<star>, receive\<langle>Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha> \<circ>\<^sub>s I\<rangle>\<rangle> \<in> set (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)"
   proof -
     have "\<langle>\<star>, send\<langle>Tts\<rangle>\<rangle> \<in> set (transaction_send T)"
       using T(1) by simp
     hence "\<langle>\<star>, send\<langle>Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>\<rangle>\<rangle> \<in> set (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)" for \<delta>
       unfolding subst_apply_labeled_stateful_strand_def by force
     hence "\<langle>\<star>, send\<langle>Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>\<rangle>\<rangle> \<in> set (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)" for \<delta>
       using transaction_strand_subst_subsets(4)[of T \<delta>] by fast
     hence *: "\<langle>\<star>, receive\<langle>Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>\<rangle>\<rangle> \<in> set (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>))" for \<delta>
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(1)[of \<star> "Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>"] by blast
 
     have "\<langle>\<star>, receive\<langle>Tts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>\<rangle>\<rangle> \<in> set A"
       using B(1) *[of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] unfolding prefix_def by force
     thus ?thesis
       unfolding subst_apply_labeled_stateful_strand_def by force
   qed
 
   show False
     using s6 f(4) ideduct_mono[OF Axiom[OF s5], of "\<Union>{set ts|ts. \<langle>\<star>,receive\<langle>ts\<rangle>\<rangle> \<in> set (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)}"]
     unfolding declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by blast
 qed
 
 lemma welltyped_leakage_free_priv_constI:
   fixes c
   defines "s \<equiv> Fun c []::('fun,'atom,'sets,'lbl) prot_term"
   assumes c: "\<not>public c" "arity c = 0" "\<Gamma> s = TAtom ca" "ca \<noteq> Value"
     and P: "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. is_Var (\<Gamma>\<^sub>v x)"
            "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma> s \<noteq> \<Gamma>\<^sub>v x"
            "\<forall>T \<in> set P. \<forall>t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). s \<notin> set (snd (Ana t))"
            "\<forall>T \<in> set P. s \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
            "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
            "\<forall>T \<in> set P. wellformed_transaction T"
    shows "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
           (is "\<forall>\<A> \<in> ?R. ?P \<A>")
      and "welltyped_leakage_free_protocol [s] P"
 proof -
   show "\<forall>\<A> \<in> ?R. ?P \<A>"
   proof
     fix A assume A: "A \<in> reachable_constraints P"
   
     define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
     define f where "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. Q M t \<delta>}"
     define Sec where "Sec \<equiv> f (set [s]) - {m. {} \<turnstile>\<^sub>c m}"
     
     define f' where "f' \<equiv> \<lambda>(T,\<xi>,\<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>).
                               dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
     define g' where "g' \<equiv> concat \<circ> map f'"
 
     let ?P_s_cases = "\<lambda>M. s \<in> M \<or> (\<exists>m \<in> subterms\<^sub>s\<^sub>e\<^sub>t M. s \<in> set (snd (Ana m)))"
     let ?P_s_cases' = "\<lambda>M \<delta>. s \<in> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta> \<or> (\<exists>m \<in> subterms\<^sub>s\<^sub>e\<^sub>t M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>. s \<in> set (snd (Ana m)))"
 
     note defs = Sec_def f_def Q_def
     note defs' = welltyped_constraint_model_def constraint_model_def
   
     show "?P A"
     proof (rule ccontr)
       assume "\<not>?P A"
       then obtain I where I: "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])" by blast
   
       obtain Ts where Ts:
           "A = g' Ts" "\<forall>B. prefix B Ts \<longrightarrow> g' B \<in> reachable_constraints P"
           "\<forall>B T \<xi> \<sigma> \<alpha>. prefix (B@[(T,\<xi>,\<sigma>,\<alpha>)]) Ts \<longrightarrow>
                 T \<in> set P \<and> transaction_decl_subst \<xi> T \<and>
                 transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g' B)) \<and>
                 transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (g' B))"
         using reachable_constraints_as_transaction_lists[OF A(1)] unfolding g'_def f'_def by blast
     
       have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> s \<cdot> I" and I_s: "s \<cdot> I = s"
         using welltyped_constraint_model_deduct_split[OF I]
         unfolding s_def by simp_all
       hence s_deduct: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I) \<turnstile> s" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> s"
         by (metis ik\<^sub>s\<^sub>s\<^sub>t_subst unlabel_subst, metis)
     
       have I_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
           and I_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
           and I_grounds: "ground (subst_range I)"
           and I_interp: "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I"
         using I unfolding defs' by (blast,blast,blast,blast)
     
       have Sec_unfold: "Sec = {s}"
       proof
         have "\<not>{} \<turnstile>\<^sub>c s" using ideduct_synth_priv_const_in_ik[OF _ c(1)] unfolding s_def by blast
         thus "{s} \<subseteq> Sec" unfolding defs s_def by fastforce
       qed (auto simp add: defs s_def)
     
       have s2: "wf\<^sub>t\<^sub>r\<^sub>m s"
         using c(1,2) unfolding s_def by fastforce
     
       have A_ik_fv: "\<exists>a. \<Gamma>\<^sub>v x = TAtom a \<and> a \<noteq> ca" when x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" for x
       proof -
         obtain T where T: "T \<in> set P" "\<Gamma>\<^sub>v x \<in> \<Gamma>\<^sub>v ` fv_transaction T"
           using fv_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t[OF x] reachable_constraints_var_types_in_transactions(1)[OF A P(5)]
           by fast
         then obtain y where y: "y \<in> vars_transaction T" "\<Gamma>\<^sub>v y = \<Gamma>\<^sub>v x"
           using vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel (transaction_strand T)"] by fastforce
         then obtain a where a: "\<Gamma>\<^sub>v y = TAtom a" using P(1) T(1) by blast
         hence "\<Gamma>\<^sub>v x = TAtom a" "\<Gamma> s \<noteq> \<Gamma>\<^sub>v x" "\<Gamma> s = TAtom ca" using y P(2) T(1) c(3) by auto
         thus ?thesis by force
       qed
     
       have I_s_x: "\<not>s \<sqsubseteq> I x" when x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" for x
       proof -
         obtain a where a: "\<Gamma>\<^sub>v x = TAtom a" "a \<noteq> ca" using A_ik_fv[OF x] by blast
         hence a': "\<Gamma> (I x) = TAtom a" using wt_subst_trm''[OF I_wt, of "Var x"] by simp
         
         obtain f ts where f: "I x = Fun f ts"
           by (meson empty_fv_exists_fun interpretation_grounds_all[OF I_interp])
         hence ts: "ts = []"
           using I_wf const_type_inv_wf[OF a'[unfolded f]] by fastforce
     
         have "c \<noteq> f" using f[unfolded ts] a a' c(3)[unfolded s_def] by force
         thus ?thesis using f ts unfolding s_def by simp
       qed
     
       have A_ik_I_const: "\<exists>f. arity f = 0 \<and> I x = Fun f []" when x: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" for x
         using x A_ik_fv I_wt empty_fv_exists_fun[OF interpretation_grounds_all[OF I_interp, of x]]
               wf_trm_subst_rangeD[OF I_wf, of x] const_type_inv const_type_inv_wf
         by (metis (no_types, lifting) \<Gamma>.simps(1) wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def)
       hence A_ik_subst: "subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) = subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
         using subterms_subst''[of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" I] by blast
     
       have sublmm1: "s \<in> set (snd (Ana m))"
         when m: "m \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t M" "s \<in> set (snd (Ana (m \<cdot> \<delta>)))"
           and M: "\<And>y. y \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<Longrightarrow> \<not>s \<sqsubseteq> \<delta> y"
         for m M \<delta>
       proof -
         have m_fun: "is_Fun m"
           using m M Ana_subterm' vars_iff_subtermeq_set
           unfolding s_def is_Var_def by (metis eval_term.simps(1))
         
         obtain f K R ts i where f:
             "m = \<langle>f ts\<rangle>\<^sub>t" "arity\<^sub>f f = length ts" "arity\<^sub>f f > 0" "Ana\<^sub>f f = (K, R)"
           and i: "i < length R" "s = ts ! (R ! i) \<cdot> \<delta>"
           and R_i: "\<forall>i < length R. map ((!) ts) R ! i = ts ! (R ! i) \<and> R ! i < length ts"
         proof -
           obtain f ts K R where f:
               "m \<cdot> \<delta> = \<langle>f ts\<rangle>\<^sub>t" "arity\<^sub>f f = length ts" "arity\<^sub>f f > 0"
               "Ana\<^sub>f f = (K, R)" "Ana (m \<cdot> \<delta>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) ts, map ((!) ts) R)"
             using m(2) Ana_nonempty_inv[of "m \<cdot> \<delta>"] by force
       
           obtain ts' where m': "m = \<langle>f ts'\<rangle>\<^sub>t" "ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>"
             using f(1) m_fun by auto
       
           have R_i: "map ((!) ts) R ! i = ts ! (R ! i)" "R ! i < length ts"
             when i: "i < length R" for i
             using i Ana\<^sub>f_assm2_alt[OF f(4), of "R ! i"] f(2) by simp_all
           then obtain i where i: "s = ts ! (R ! i)" "i < length R"
             by (metis (no_types, lifting) m(2) f(5) in_set_conv_nth length_map snd_conv)
       
           have ts': "arity\<^sub>f f = length ts'" "length ts = length ts'" using m'(2) f(2) by simp_all
       
           have s': "s = ts' ! (R ! i) \<cdot> \<delta>" using R_i(2)[OF i(2)] i(1) unfolding ts'(2) m'(2) by simp
       
           show thesis using that f m' R_i ts' s' i by auto
         qed
     
         have "s = ts ! (R ! i)"
         proof (cases "ts ! (R ! i)")
           case (Var x)
           hence "Var x \<in> set ts" using R_i i nth_mem by fastforce
           hence "x \<in> fv\<^sub>s\<^sub>e\<^sub>t M" using m(1) f(1) fv_subterms_set by fastforce
           thus ?thesis using i M Var by fastforce
         qed (use i s_def in fastforce)
         thus "s \<in> set (snd (Ana m))" using f(1) Ana_Fu_intro[OF f(2-4)] i(1) by simp
       qed
     
       have "\<not>s \<sqsubseteq> \<delta> y"
         when m: "m \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "s \<in> set (snd (Ana (m \<cdot> \<delta>)))"
           and T: "T \<in> set P" and \<delta>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>"
           and \<delta>_ran: "\<And>t. t \<in> subst_range \<delta> \<Longrightarrow> (\<exists>c. t = Fun c [] \<and> arity c = 0) \<or> (\<exists>x. t = Var x)"
           and y: "y \<in> fv\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))"
         for m T \<delta> y
       proof
         assume "s \<sqsubseteq> \<delta> y"
         hence "\<Gamma>\<^sub>v y = \<Gamma> s" using wt_subst_trm''[OF \<delta>_wt, of "Var y"] \<delta>_ran[of "\<delta> y"] by fastforce
         moreover have "y \<in> vars_transaction T"
           using y trms\<^sub>s\<^sub>s\<^sub>t_fv_vars\<^sub>s\<^sub>s\<^sub>t_subset unfolding vars_transaction_unfold[of T] by fastforce
         ultimately show False using P(2) T by force
       qed
       hence sublmm2: "s \<in> set (snd (Ana m))"
         when m: "m \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "s \<in> set (snd (Ana (m \<cdot> \<delta>)))"
           and T: "T \<in> set P" and \<delta>_wt: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>"
           and \<delta>_ran: "\<And>t. t \<in> subst_range \<delta> \<Longrightarrow> (\<exists>c. t = Fun c [] \<and> arity c = 0) \<or> (\<exists>x. t = Var x)"
         for m T \<delta>
         using sublmm1[OF m] m T \<delta>_wt \<delta>_ran by blast
 
       have "s \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<or> (\<exists>m \<in> subterms\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<cdot>\<^sub>s\<^sub>e\<^sub>t I. s \<in> set (snd (Ana m)))"
         using private_const_deduct[OF c(1) s_deduct(2)[unfolded s_def]]
               I_s_x const_mem_subst_cases[of c] A_ik_subst
         unfolding s_def by blast
       hence "?P_s_cases (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" using sublmm1[of _ "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"] I_s_x by blast
       then obtain T \<xi> \<sigma> \<alpha> where T: "(T,\<xi>,\<sigma>,\<alpha>) \<in> set Ts" "?P_s_cases (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t (f' (T,\<xi>,\<sigma>,\<alpha>)))"
         using ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t_concat[of "map f' Ts"] Ts(1)[unfolded g'_def] by fastforce
     
       obtain B where "prefix (B@[(T, \<xi>, \<sigma>, \<alpha>)]) Ts" by (metis T(1) prefix_snoc_in_iff)
       hence T_in_P: "T \<in> set P"
           and T_wf: "wellformed_transaction T"
           and \<xi>: "transaction_decl_subst \<xi> T"
           and \<sigma>: "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (concat (map f' B)))"
           and \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (concat (map f' B)))"
         using P(6) Ts(3)[unfolded g'_def] unfolding comp_def by (metis,metis,metis,metis,metis)
     
       note \<xi>\<sigma>\<alpha>_wt = transaction_decl_fresh_renaming_substs_wt[OF \<xi> \<sigma> \<alpha>]
       note \<xi>\<sigma>\<alpha>_ran = transaction_decl_fresh_renaming_substs_range'(1)[OF \<xi> \<sigma> \<alpha>]
     
       have "subterms\<^sub>s\<^sub>e\<^sub>t (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>) = subterms\<^sub>s\<^sub>e\<^sub>t M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" for M
         using \<xi>\<sigma>\<alpha>_ran subterms_subst''[of _ "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"] by (meson subst_imgI)
       hence s_cases: "?P_s_cases' (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) (\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
         using T(2) dual_transaction_ik_is_transaction_send'[OF T_wf, of "\<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"]
         unfolding f'_def by auto
     
       from s_cases show False
       proof
         assume "s \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
-        then obtain t where t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "s = t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" by moura
+        then obtain t where t: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "s = t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>" by force
         have "s \<noteq> t" using P(4) T_in_P t(1) by blast
         then obtain x where x: "t = Var x" using t(2) unfolding s_def by (cases t) auto
         
         have "\<Gamma>\<^sub>v x = \<Gamma> s" using x t(2) wt_subst_trm''[OF \<xi>\<sigma>\<alpha>_wt, of "Var x"] by simp
         moreover have "x \<in> vars_transaction T"
           using t(1) trms\<^sub>s\<^sub>s\<^sub>t_fv_vars\<^sub>s\<^sub>s\<^sub>t_subset unfolding x vars_transaction_unfold[of T] by fastforce
         ultimately show False using P(2) T_in_P by force
       qed (use sublmm2[OF _ _ T_in_P \<xi>\<sigma>\<alpha>_wt \<xi>\<sigma>\<alpha>_ran] P(3) T_in_P in blast)
     qed
   qed
   thus "welltyped_leakage_free_protocol [s] P"
     using welltyped_leakage_free_no_deduct_constI[of P c]
     unfolding s_def by blast
 qed
 
 lemma welltyped_leakage_free_priv_constI':
   assumes c: "\<not>public\<^sub>f c" "arity\<^sub>f c = 0" "\<Gamma>\<^sub>f c = Some ca"
     and P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma> \<langle>c\<rangle>\<^sub>c \<noteq> \<Gamma>\<^sub>v x"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. is_Var (\<Gamma>\<^sub>v x)"
       "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
       "\<forall>T \<in> set P. \<forall>t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<langle>c\<rangle>\<^sub>c \<notin> set (snd (Ana t))"
       "\<forall>T \<in> set P. \<langle>c\<rangle>\<^sub>c \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
    shows "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>c]\<rangle>\<rangle>])"
      and "welltyped_leakage_free_protocol [\<langle>c\<rangle>\<^sub>c] P"
 using c welltyped_leakage_free_priv_constI[OF _ _ _ _ P(3,2,5,6,4,1), of "Atom ca"]
 by (force, force)
 
 lemma welltyped_leakage_free_set_constI:
   assumes P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. \<forall>f \<in> \<Union>(funs_term ` (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))). \<not>is_Set f"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma>\<^sub>v x \<noteq> TAtom SetType"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. is_Var (\<Gamma>\<^sub>v x)"
       "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
     and c: "arity\<^sub>s c = 0"
   shows "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>s]\<rangle>\<rangle>])"
     and "welltyped_leakage_free_protocol [\<langle>c\<rangle>\<^sub>s] P"
 proof -
   have c'': "\<langle>c\<rangle>\<^sub>s \<notin> subterms t"
     when T: "T \<in> set P" and t: "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" for T t
     using t bspec[OF P(2) T] subtermeq_imp_funs_term_subset[of t]
           funs_term_Fun_subterm'[of "Set c" "[]::('fun,'atom,'sets,'lbl) prot_term list"]
     by fastforce
 
   have P':
       "\<forall>T \<in> set P. \<forall>t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<langle>c\<rangle>\<^sub>s \<notin> set (snd (Ana t))"
       "\<forall>T \<in> set P. \<langle>c\<rangle>\<^sub>s \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
     subgoal using Ana_subterm' c'' by fast
     subgoal using c'' by fast
     done
 
   have P'':
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma> \<langle>c\<rangle>\<^sub>s \<noteq> \<Gamma>\<^sub>v x"
     using P(3) \<Gamma>_consts_simps(4)[OF c] by fastforce
 
   show "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>s]\<rangle>\<rangle>])"
        "welltyped_leakage_free_protocol [\<langle>c\<rangle>\<^sub>s] P"
     using c welltyped_leakage_free_priv_constI[OF _ _ _ _ P(4) P'' P' P(5,1), of SetType]
     by (force, force)
 qed
 
 lemma welltyped_leakage_free_occurssec_constI:
   defines "s \<equiv> Fun OccursSec []"
   assumes P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma>\<^sub>v x \<noteq> TAtom OccursSecType"
       "\<forall>T \<in> set P. \<forall>t \<in> subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). Fun OccursSec [] \<notin> set (snd (Ana t))"
       "\<forall>T \<in> set P. Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. is_Var (\<Gamma>\<^sub>v x)"
       "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
   shows "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
     and "welltyped_leakage_free_protocol [s] P"
 proof -
   have P':
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma> (Fun OccursSec []) \<noteq> \<Gamma>\<^sub>v x"
     using P(2) by auto
 
   show "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[s]\<rangle>\<rangle>])"
        "welltyped_leakage_free_protocol [s] P"
     using welltyped_leakage_free_priv_constI[OF _ _ _ _ P(5) P' P(3,4,6,1), of OccursSecType]
     unfolding s_def by auto
 qed
 
 lemma welltyped_leakage_free_occurs_factI:
   assumes P: "\<forall>T \<in> set P. admissible_transaction' T"
     and P_occ: "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
     and P_occ_star:
       "\<forall>T \<in> set P. \<forall>r \<in> set (transaction_send T).
         OccursFact \<in> \<Union>(funs_term ` (trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd r))) \<longrightarrow> fst r = \<star>"
   shows "welltyped_leakage_free_protocol [occurs x] P"
 proof -
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define f where "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. Q M t \<delta>}"
   define Sec where "Sec \<equiv> f (set [occurs x]) - {m. {} \<turnstile>\<^sub>c m}"
 
   define f' where "f' \<equiv> \<lambda>(T,\<xi>,\<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>).
                             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define g' where "g' \<equiv> concat \<circ> map f'"
 
   note defs = Sec_def f_def Q_def
   note defs' = welltyped_constraint_model_def constraint_model_def
 
   show ?thesis
   proof (rule ccontr)
     assume "\<not>welltyped_leakage_free_protocol [occurs x] P"
     then obtain A I k where A:
         "A \<in> reachable_constraints P" "occurs k \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
         "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[occurs k]\<rangle>\<rangle>])"
       unfolding welltyped_leakage_free_protocol_def defs by fastforce
 
     note A' = welltyped_constraint_model_prefix[OF A(3)]
 
     have occ_I: "occurs k \<cdot> I = occurs k" using A(2) unfolding defs by auto
     hence occ_in_ik: "occurs k \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" "occurs k \<in> ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       using welltyped_constraint_model_deduct_split(2)[OF A(3)]
             reachable_constraints_occurs_fact_deduct_in_ik[OF A(1) A' P P_occ, of k]
       by (argo, argo)
     then obtain l ts where ts: "(l,receive\<langle>ts\<rangle>) \<in> set A" "occurs k \<in> set ts"
-      using in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of "occurs k" "unlabel A"] unfolding unlabel_def by moura
+      using in_ik\<^sub>s\<^sub>s\<^sub>t_iff[of "occurs k" "unlabel A"] unfolding unlabel_def by force
 
     obtain T a B \<alpha> \<sigma> \<xi>
       where B: "prefix (B@f' (T,\<xi>,\<sigma>,\<alpha>)) A"
         and T: "T \<in> set P" "transaction_decl_subst \<xi> T"
                "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
                "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
         and a: "a \<in> set (transaction_strand T)" "fst (l,receive\<langle>ts\<rangle>) = fst a"
                "(l,receive\<langle>ts\<rangle>) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p a \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       using reachable_constraints_transaction_action_obtain[OF A(1) ts(1), of thesis]
       unfolding f'_def by simp
 
     obtain ts' where ts': "a = (l,send\<langle>ts'\<rangle>)" "ts = ts' \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       using surj_pair[of a] a(2,3) by (cases "snd a") force+
 
     obtain t where t: "t \<in> set ts'" "occurs k = t \<cdot> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
       using ts(2) unfolding ts'(2) by force
 
     have occ_t: "OccursFact \<in> funs_term t"
     proof (cases t)
       case (Var y) thus ?thesis
         using t(2) transaction_decl_fresh_renaming_substs_range'(1)[OF T(2-), of "occurs k"]
         by fastforce
     qed (use t(2) in simp)
 
     have P_wf: "\<forall>T \<in> set P. wellformed_transaction T"
       using P admissible_transaction_is_wellformed_transaction(1) by blast
 
     have l: "l = \<star>"
       using wellformed_transaction_strand_memberD(8)[OF bspec[OF P_wf T(1)] a(1)[unfolded ts'(1)]]
             t(1) T(1) P_occ_star occ_t
       unfolding ts'(1) by fastforce
 
     have "occurs k \<in> \<Union>{set ts |ts. \<langle>\<star>, receive\<langle>ts\<rangle>\<rangle> \<in> set (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)}"
       using subst_lsst_memI[OF ts(1), of I] subst_set_map[OF ts(2), of I]
       unfolding occ_I l by auto
     thus False using A(2) unfolding declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by simp
   qed
 qed
 
 lemma welltyped_leakage_free_setop_pairI:
   assumes P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
       "\<forall>T \<in> set P. \<forall>f \<in> \<Union>(funs_term ` (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T))). \<not>is_Set f"
       "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
       "\<forall>T \<in> set P. transaction_decl T () = []"
       "\<forall>T \<in> set P. admissible_transaction_terms T"
     and c: "arity\<^sub>s c = 0"
   shows "welltyped_leakage_free_protocol [pair (x, \<langle>c\<rangle>\<^sub>s)] P"
 proof -
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define f where "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. Q M t \<delta>}"
   define Sec where "Sec \<equiv> f (set [pair (x, \<langle>c\<rangle>\<^sub>s)]) - {m. {} \<turnstile>\<^sub>c m}"
 
   define f' where "f' \<equiv> \<lambda>(T,\<xi>,\<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>).
                             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define g' where "g' \<equiv> concat \<circ> map f'"
 
   note defs = Sec_def f_def Q_def
   note defs' = welltyped_constraint_model_def constraint_model_def
 
   have P':
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T \<union> set (transaction_fresh T). \<Gamma>\<^sub>v x \<noteq> TAtom SetType"
       "\<forall>T \<in> set P. \<forall>x \<in> vars_transaction T. is_Var (\<Gamma>\<^sub>v x)"
       "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
     subgoal using P(2,4) by fastforce
     subgoal using P(2) by fastforce
     subgoal using P(4) by fast
     done
 
   note 0 = welltyped_leakage_free_set_constI(1)[OF P(1,3) P' c]
 
   show ?thesis
   proof (rule ccontr)
     assume "\<not>welltyped_leakage_free_protocol [pair (x, \<langle>c\<rangle>\<^sub>s)] P"
     then obtain A I k where A:
         "A \<in> reachable_constraints P" "pair (k, \<langle>c\<rangle>\<^sub>s) \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
         "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[pair (k, \<langle>c\<rangle>\<^sub>s)]\<rangle>\<rangle>])"
       unfolding welltyped_leakage_free_protocol_def defs pair_def by fastforce
 
     note A' = welltyped_constraint_model_prefix[OF A(3)]
 
     have "pair (k, \<langle>c\<rangle>\<^sub>s) \<cdot> I = pair (k, \<langle>c\<rangle>\<^sub>s)" using A(2) unfolding defs by auto
     hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> pair (k, \<langle>c\<rangle>\<^sub>s)"
       using welltyped_constraint_model_deduct_split(2)[OF A(3)] by argo
     then obtain n where n: "intruder_deduct_num (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) n (pair (k, \<langle>c\<rangle>\<^sub>s))"
       using deduct_num_if_deduct by fast
 
     have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<subseteq> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       using A(3) ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset unfolding defs' by simp_all
     hence "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<subseteq> SMP (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)" by blast
     hence "Pair \<notin> \<Union>(funs_term ` (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I))"
       using reachable_constraints_no_Pair_fun'[OF A(1) P(4-6)] P by blast
     hence 1: "\<not>pair (k, \<langle>c\<rangle>\<^sub>s) \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       using funs_term_Fun_subterm'[of Pair] unfolding pair_def by auto
     
     have 2: "pair (k, \<langle>c\<rangle>\<^sub>s) \<notin> set (snd (Ana m))" when m: "m \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I" for m
       using m 1 term.dual_order.trans Ana_subterm'[of "pair (k, \<langle>c\<rangle>\<^sub>s)" m] by auto
 
     have "\<not>ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> \<langle>c\<rangle>\<^sub>s"
       using 0 A(1) A' welltyped_constraint_model_deduct_iff[of I A \<star> "\<langle>c\<rangle>\<^sub>s"] by force
     moreover have "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> \<langle>c\<rangle>\<^sub>s"
       using 1 2 deduct_inv[OF n] deduct_if_deduct_num[of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I" _ "\<langle>c\<rangle>\<^sub>s"]
       unfolding pair_def by auto
     ultimately show False by blast
   qed
 qed
 
 lemma welltyped_leakage_free_short_term_secretI:
   fixes c x y f n d l l'
   defines "s \<equiv> \<langle>f [\<langle>c\<rangle>\<^sub>c, \<langle>x: value\<rangle>\<^sub>v]\<rangle>\<^sub>t"
     and "Tatt \<equiv> Transaction (\<lambda>(). []) []
           [\<langle>\<star>, receive\<langle>[occurs \<langle>y: value\<rangle>\<^sub>v]\<rangle>\<rangle>,
            (l, receive\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, \<langle>y: value\<rangle>\<^sub>v]\<rangle>\<^sub>t]\<rangle>)]
           [(l', \<langle>\<langle>y: value\<rangle>\<^sub>v not in \<langle>d\<rangle>\<^sub>s\<rangle>)]
           []
           [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
   assumes P:
       "\<forall>T \<in> set P. admissible_transaction' T"
       "\<forall>T \<in> set P. admissible_transaction_occurs_checks T"
       "\<forall>T \<in> set P. \<forall>x \<in> set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
     and subterms_sec:
       "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>c]\<rangle>\<rangle>])"
     and P_sec:
       "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>.
         welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
     and P_Tatt: "Tatt \<in> set P"
     and P_d:
       "\<forall>T \<in> set P. \<forall>a \<in> set (transaction_updates T).
         is_Insert (snd a) \<and> the_set_term (snd a) = \<langle>d\<rangle>\<^sub>s \<longrightarrow>
           transaction_send T \<noteq> [] \<and> (let (l,b) = hd (transaction_send T)
             in l = \<star> \<and> is_Send b \<and> \<langle>f [\<langle>c\<rangle>\<^sub>c, the_elem_term (snd a)]\<rangle>\<^sub>t \<in> set (the_msgs b))"
   shows "welltyped_leakage_free_protocol [s] P"
 proof -
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define Sec where "Sec \<equiv> {t \<cdot> \<delta> | t \<delta>. Q (set [s]) t \<delta>} - {m. {} \<turnstile>\<^sub>c m}"
 
   define f' where "f' \<equiv> \<lambda>(T,\<xi>,\<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>).
                             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define g' where "g' \<equiv> concat \<circ> map f'"
 
   note defs = Sec_def Q_def
   note defs' = welltyped_constraint_model_def constraint_model_def
 
   show ?thesis
   proof (rule ccontr)
     assume "\<not>welltyped_leakage_free_protocol [s] P"
     then obtain A I k where A:
         "A \<in> reachable_constraints P" "\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
         "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t]\<rangle>\<rangle>])"
       unfolding welltyped_leakage_free_protocol_def defs s_def by fastforce
 
     have I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
       using A(3) unfolding defs' by (blast,blast,blast)
 
     note A' = welltyped_constraint_model_prefix[OF A(3)]
 
     have "strand_sem_stateful {} {} (unlabel A) I"
       using A' unfolding defs' by simp
     hence A'': "strand_sem_stateful {} {} (unlabel A) (I(z := k))"
       when z: "z \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" for z
       using z strand_sem_model_swap[of "unlabel A" I "I(z := k)" "{}" "{}"] by auto
 
     obtain \<delta> where \<delta>:
         "\<delta> (the_Var \<langle>x: value\<rangle>\<^sub>v) = k" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)"
         "fv (\<delta> (the_Var \<langle>x: value\<rangle>\<^sub>v)) = {}"
       using A(2) unfolding defs s_def by auto
     
     have k: "\<Gamma> k = TAtom Value" "fv k = {}" "wf\<^sub>t\<^sub>r\<^sub>m k"
       subgoal using \<delta>(1) wt_subst_trm''[OF \<delta>(2), of "\<langle>x: value\<rangle>\<^sub>v"] by simp
       subgoal using \<delta>(1,4) by blast
       subgoal using \<delta>(1,3) by force
       done
     then obtain fk where fk: "k = Fun fk []"
       using const_type_inv_wf by (cases k) auto
 
     have fk': "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> \<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t"
       using fk welltyped_constraint_model_deduct_split(2)[OF A(3)] by auto
 
     have "\<not>welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>c]\<rangle>\<rangle>])"
       using subterms_sec(1) A(1) by blast
     hence "\<not>ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> \<langle>c\<rangle>\<^sub>c"
       using A' strand_sem_append_stateful[of "{}" "{}" "unlabel A" "unlabel [\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>c]\<rangle>\<rangle>]" I]
       unfolding defs' by auto
     hence "\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       using fk' deduct_inv'[OF fk'] by force
     moreover have "k \<sqsubseteq> \<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t" by simp
     ultimately have k_in_ik: "k \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I"
       using in_subterms_subset_Union by blast
     hence "k \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<or> (\<exists>x \<in> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A). k \<sqsubseteq> I x)"
       using const_subterms_subst_cases[of fk I "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"]
       unfolding fk by fast
     hence "fk \<in> \<Union>(funs_term ` ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<or> (\<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. k \<sqsubseteq> I x)"
       unfolding fk by (meson UN_iff funs_term_Fun_subterm' fv_ik\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t )
     hence "fk \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<or> (\<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. k \<sqsubseteq> I x)"
       using ik\<^sub>s\<^sub>s\<^sub>t_trms\<^sub>s\<^sub>s\<^sub>t_subset by blast
     moreover have "\<Gamma>\<^sub>v x = TAtom Value" when x: "x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" for x
       using x reachable_constraints_var_types_in_transactions(1)[OF A(1) P(3)]
             P(1,2) admissible_transaction_Value_vars
       by force
     ultimately have "fk \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<or> (\<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \<Gamma>\<^sub>v x = TAtom Value \<and> k \<sqsubseteq> I x)"
       by blast
     hence "fk \<in> \<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t A) \<or> (\<exists>x \<in> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A. \<Gamma>\<^sub>v x = TAtom Value \<and> I x = k)"
       using I(1,3) wf_trm_TComp_subterm wf_trm_subst_rangeD
       unfolding fk wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t_def by (metis \<Gamma>.simps(1) term.distinct(1))
     then obtain kn where kn: "fk = Val kn"
       using reachable_constraints_val_funs_private[OF A(1) P(1), of fk]
             constraint_model_Value_term_is_Val[OF A(1) A' P(1,2)]
             Fun_Value_type_inv[OF k(1)[unfolded fk]]
       unfolding fk is_PubConstValue_def by (cases fk) force+
 
     obtain \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
       where \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       unfolding transaction_renaming_subst_def by blast
 
     obtain y' yn' where y':
         "\<alpha> (the_Var \<langle>y: value\<rangle>\<^sub>v) = Var y'" "y \<noteq> yn'" "Var y' = \<langle>yn': value\<rangle>\<^sub>v"
       using transaction_renaming_subst_is_renaming(1,2)[OF \<alpha>] by force
 
     define B where "B \<equiv> A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand Tatt \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>)"
     define J where "J \<equiv> I(y' := k)"
 
     have "y' \<in> range_vars \<alpha>"
       using y'(1) transaction_renaming_subst_is_renaming(3)[OF \<alpha>]
       by (metis (no_types, lifting) in_mono subst_fv_imgI term.set_intros(3))
     hence y'': "y' \<notin> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       using transaction_renaming_subst_vars_disj(6)[OF \<alpha>] by blast
 
     have 0: "(k,\<langle>d\<rangle>\<^sub>s) \<notin> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I)"
     proof
       assume a: "(k,\<langle>d\<rangle>\<^sub>s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I)"
       obtain l t t' where t: "(l,insert\<langle>t,t'\<rangle>) \<in> set A" "t \<cdot> I = k" "t' \<cdot> I = \<langle>d\<rangle>\<^sub>s"
         using db\<^sub>s\<^sub>s\<^sub>t_in_cases[OF a[unfolded db\<^sub>s\<^sub>s\<^sub>t_def]] unfolding unlabel_def by auto
 
       obtain T b B \<alpha> \<sigma> \<xi> where T:
           "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
           "T \<in> set P" "transaction_decl_subst \<xi> T"
           "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)" "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
           "b \<in> set (transaction_strand T)" "(l, insert\<langle>t,t'\<rangle>) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
           "fst (l, insert\<langle>t,t'\<rangle>) = fst b"
         using reachable_constraints_transaction_action_obtain[OF A(1) t(1)] by metis
 
       define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
       obtain b' where "b = (l,b')"
         using T(8) by (cases b) simp
       then obtain tb tb'
           where b': "b = (l,insert\<langle>tb,tb'\<rangle>)"
             and tb: "t = tb \<cdot> \<theta>"
             and tb': "t' = tb' \<cdot> \<theta>"
         using T(7) unfolding \<theta>_def by (cases b') auto
 
       note T_adm = bspec[OF P(1) T(2)]
       note T_wf = admissible_transaction_is_wellformed_transaction(1,3)[OF T_adm]
 
       have b: "b \<in> set (transaction_updates T)"
         using transaction_strand_memberD[OF T(6)[unfolded b']]
               wellformed_transaction_cases[OF T_wf(1)]
         unfolding b' by blast
 
       have "\<exists>n. tb = \<langle>n: value\<rangle>\<^sub>v" and *: "tb' = \<langle>d\<rangle>\<^sub>s"
         using tb tb' T(6) t(3) transaction_inserts_are_Value_vars[OF T_wf, of tb tb']
         unfolding b' unlabel_def by (force,force)
 
       have "is_Insert (snd b)" "the_set_term (snd b) = \<langle>d\<rangle>\<^sub>s" "the_elem_term (snd b) = tb"
         unfolding b' * by simp_all
       hence "transaction_send T \<noteq> []"
             "let (l, a) = hd (transaction_send T)
              in l = \<star> \<and> is_Send a \<and> \<langle>f [\<langle>c\<rangle>\<^sub>c, tb]\<rangle>\<^sub>t \<in> set (the_msgs a)"
         using P_d T(2) b by (fast,fast)
       hence "\<exists>ts. \<langle>\<star>,send\<langle>ts\<rangle>\<rangle> \<in> set (transaction_send T) \<and> \<langle>f [\<langle>c\<rangle>\<^sub>c, tb]\<rangle>\<^sub>t \<in> set ts"
         unfolding is_Send_def by (cases "transaction_send T") auto
       then obtain ts where ts: "\<langle>\<star>,send\<langle>ts\<rangle>\<rangle> \<in> set (transaction_strand T)" "\<langle>f [\<langle>c\<rangle>\<^sub>c, tb]\<rangle>\<^sub>t \<in> set ts"
         unfolding transaction_strand_def by auto
       
       have "\<langle>\<star>,receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle> \<in> set A" "\<langle>f [\<langle>c\<rangle>\<^sub>c, t]\<rangle>\<^sub>t \<in> set (ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)"
         using subst_lsst_memI[OF ts(1), of \<theta>] subst_set_map[OF ts(2), of \<theta>]
               dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(1)[of \<star> "ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
               set_mono_prefix[OF T(1)[unfolded \<theta>_def[symmetric]]]
         unfolding tb by auto
       hence "\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t \<in> \<Union>{set ts |ts. \<langle>\<star>, receive\<langle>ts\<rangle>\<rangle> \<in> set (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)}"
         using t(2) subst_lsst_memI[of "\<langle>\<star>,receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>" A I] by force
       thus False
         using A(2) unfolding declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto
     qed
 
     have "y' \<notin> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       using y'' fv_ik_subset_vars_sst'[of "unlabel A"] by blast 
     hence 1: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J"
       unfolding J_def by (metis (no_types, lifting) fv_subset image_cong in_mono repl_invariance)
 
     have "(k,\<langle>d\<rangle>\<^sub>s) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}"
       using 0 db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel A" I "[]"]
       unfolding db\<^sub>s\<^sub>s\<^sub>t_def by force
     hence "(k,\<langle>d\<rangle>\<^sub>s) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {}"
       using y'' vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel A"]
             db\<^sub>s\<^sub>s\<^sub>t_subst_swap[of "unlabel A" I J "[]"]
             db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel A" _ "[]"]
       unfolding db\<^sub>s\<^sub>s\<^sub>t_def J_def by (metis (no_types, lifting) Un_iff empty_set fun_upd_other)
     hence "((Var y' \<cdot> J, \<langle>d\<rangle>\<^sub>s \<cdot> J) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {})"
       unfolding J_def fk by simp
     hence "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J) (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {})
             (unlabel [\<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>]) J"
       using stateful_strand_sem_NegChecks_no_bvars(1)[
               of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J" "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {}" "Var y'" "\<langle>d\<rangle>\<^sub>s" J]
       by simp
     hence 2: "strand_sem_stateful {} {} (unlabel (A@[\<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>])) J"
       using A'' y' y'' vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel A"]
             strand_sem_append_stateful[
               of "{}" "{}" "unlabel A" "unlabel [\<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>]" J]
       unfolding J_def by simp
 
     have B: "B \<in> reachable_constraints P"
       using reachable_constraints.step[OF A(1) P_Tatt _ _ \<alpha>, of Var Var]
       unfolding B_def Tatt_def transaction_decl_subst_def transaction_fresh_subst_def by simp
 
     have Tatt': "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand Tatt \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>) =
                   [\<langle>\<star>, send\<langle>[occurs (Var y')]\<rangle>\<rangle>,
                    (l, send\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, Var y']\<rangle>\<^sub>t]\<rangle>),
                    (l', \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>),
                    \<langle>n, receive\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
       using y'
       unfolding Tatt_def transaction_strand_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def
       by auto
 
     have J: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t J" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t J" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range J)"
       unfolding J_def
       subgoal using wt_subst_subst_upd[OF I(1)] k(1) y'(3) by simp 
       subgoal by (metis I(2) k(2) fun_upd_apply interpretation_grounds_all interpretation_substI)
       subgoal using I(3) k(3) by fastforce
       done
 
     have 3: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> \<langle>f [\<langle>c\<rangle>\<^sub>c, Var y']\<rangle>\<^sub>t \<cdot> J"
       using 1 fk fk' unfolding J_def by auto
 
     have 4: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> occurs (Var y') \<cdot> J"
       using reachable_constraints_occurs_fact_ik_case'[
                 OF A(1) P(1,2) constraint_model_Val_const_in_constr_prefix'[
                                 OF A(1) A' P(1) k_in_ik[unfolded fk kn]]]
             intruder_deduct.Axiom[of "occurs k" "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J"]
       unfolding J_def fk kn by fastforce
 
     have "strand_sem_stateful {} {} (unlabel A) J"
       using 2 strand_sem_append_stateful by force
     hence "strand_sem_stateful {} {}
             (unlabel (A@[\<langle>\<star>, send\<langle>[occurs (Var y')]\<rangle>\<rangle>,
                          \<langle>n, send\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, Var y']\<rangle>\<^sub>t]\<rangle>\<rangle>,
                          \<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>])) J"
       using 2 3 4 strand_sem_append_stateful[of "{}" "{}" _ _ J]
       unfolding unlabel_def ik\<^sub>s\<^sub>s\<^sub>t_def by force
     hence "strand_sem_stateful {} {} (unlabel (B@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])) J"
       using strand_sem_receive_send_append[of "{}" "{}" _ J "attack\<langle>ln n\<rangle>"]
             strand_sem_append_stateful[of "{}" "{}" _ _ J]
       unfolding B_def Tatt' by simp
     hence "welltyped_constraint_model J (B@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
       using B J unfolding defs' by blast
     thus False using B(1) P_sec by blast
   qed
 qed
 
 lemma welltyped_leakage_free_short_term_secretI':
   fixes c x y f n d l l' \<tau>
   defines "s \<equiv> \<langle>f [\<langle>c\<rangle>\<^sub>c, Var (TAtom \<tau>,x)]\<rangle>\<^sub>t"
     and "Tatt \<equiv> Transaction (\<lambda>(). []) []
           [(l, receive\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, Var (TAtom \<tau>,y)]\<rangle>\<^sub>t]\<rangle>)]
           [(l', \<langle>Var (TAtom \<tau>,y) not in \<langle>d\<rangle>\<^sub>s\<rangle>)]
           []
           [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
   assumes P:
       "\<forall>T \<in> set P. wellformed_transaction T"
       "\<forall>T \<in> set P. \<forall>x \<in> set (unlabel (transaction_updates T)).
         is_Update x \<longrightarrow> is_Fun (the_set_term x)"
     and subterms_sec:
       "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>. welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>\<star>, send\<langle>[\<langle>c\<rangle>\<^sub>c]\<rangle>\<rangle>])"
     and P_sec:
       "\<forall>\<A> \<in> reachable_constraints P. \<nexists>\<I>\<^sub>\<tau>.
         welltyped_constraint_model \<I>\<^sub>\<tau> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
     and P_Tatt: "Tatt \<in> set P"
     and P_d:
       "\<forall>T \<in> set P. \<forall>a \<in> set (transaction_updates T).
         is_Insert (snd a) \<and> the_set_term (snd a) = \<langle>d\<rangle>\<^sub>s \<longrightarrow>
           transaction_send T \<noteq> [] \<and> (let (l,b) = hd (transaction_send T)
             in l = \<star> \<and> is_Send b \<and> \<langle>f [\<langle>c\<rangle>\<^sub>c, the_elem_term (snd a)]\<rangle>\<^sub>t \<in> set (the_msgs b))"
   shows "welltyped_leakage_free_protocol [s] P"
 proof -
   define Q where "Q \<equiv> \<lambda>M t \<delta>. t \<in> M \<and> wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}"
   define Sec where "Sec \<equiv> {t \<cdot> \<delta> | t \<delta>. Q (set [s]) t \<delta>} - {m. {} \<turnstile>\<^sub>c m}"
 
   define f' where "f' \<equiv> \<lambda>(T,\<xi>,\<sigma>::('fun,'atom,'sets,'lbl) prot_subst,\<alpha>).
                             dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)"
   define g' where "g' \<equiv> concat \<circ> map f'"
 
   note defs = Sec_def Q_def
   note defs' = welltyped_constraint_model_def constraint_model_def
 
   show ?thesis
   proof (rule ccontr)
     assume "\<not>welltyped_leakage_free_protocol [s] P"
     then obtain A I k where A:
         "A \<in> reachable_constraints P" "\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t \<in> Sec - declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I"
         "welltyped_constraint_model I (A@[\<langle>\<star>, send\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t]\<rangle>\<rangle>])"
       unfolding welltyped_leakage_free_protocol_def defs s_def by fastforce
 
     have I: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t I" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range I)"
       using A(3) unfolding defs' by (blast,blast,blast)
 
     note A' = welltyped_constraint_model_prefix[OF A(3)]
 
     have "strand_sem_stateful {} {} (unlabel A) I"
       using A' unfolding defs' by simp
     hence A'': "strand_sem_stateful {} {} (unlabel A) (I(z := k))"
       when z: "z \<notin> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t A" for z
       using z strand_sem_model_swap[of "unlabel A" I "I(z := k)" "{}" "{}"] by auto
 
     obtain \<delta> where \<delta>:
         "\<delta> (TAtom \<tau>,x) = k" "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "fv (\<delta> (TAtom \<tau>,x)) = {}"
       using A(2) unfolding defs s_def by auto
     
     have k: "\<Gamma> k = TAtom \<tau>" "fv k = {}" "wf\<^sub>t\<^sub>r\<^sub>m k"
       subgoal using \<delta>(1) wt_subst_trm''[OF \<delta>(2), of "Var (TAtom \<tau>,x)"] by simp
       subgoal using \<delta>(1,4) by blast
       subgoal using \<delta>(1,3) by force
       done
     then obtain fk where fk: "k = Fun fk []"
       using const_type_inv_wf by (cases k) auto
 
     have fk': "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I \<turnstile> \<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t"
       using fk welltyped_constraint_model_deduct_split(2)[OF A(3)] by auto
 
     obtain \<alpha>::"('fun,'atom,'sets,'lbl) prot_subst"
       where \<alpha>: "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       unfolding transaction_renaming_subst_def by blast
 
     obtain y' yn' where y': "\<alpha> (TAtom \<tau>,y) = Var y'" "y \<noteq> yn'" "y' = (TAtom \<tau>,yn')"
       using transaction_renaming_subst_is_renaming(1,2)[OF \<alpha>] by force
 
     define B where "B \<equiv> A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand Tatt \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>)"
     define J where "J \<equiv> I(y' := k)"
 
     have "y' \<in> range_vars \<alpha>"
       using y'(1) transaction_renaming_subst_is_renaming(3)[OF \<alpha>]
       by (metis (no_types, lifting) in_mono subst_fv_imgI term.set_intros(3))
     hence y'': "y' \<notin> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t A"
       using transaction_renaming_subst_vars_disj(6)[OF \<alpha>] by blast
 
     have 0: "(k,\<langle>d\<rangle>\<^sub>s) \<notin> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I)"
     proof
       assume a: "(k,\<langle>d\<rangle>\<^sub>s) \<in> set (db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A I)"
       obtain l t t' where t: "(l,insert\<langle>t,t'\<rangle>) \<in> set A" "t \<cdot> I = k" "t' \<cdot> I = \<langle>d\<rangle>\<^sub>s"
         using db\<^sub>s\<^sub>s\<^sub>t_in_cases[OF a[unfolded db\<^sub>s\<^sub>s\<^sub>t_def]] unfolding unlabel_def by auto
 
       obtain T b B \<alpha> \<sigma> \<xi> where T:
           "prefix (B@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>)) A"
           "T \<in> set P" "transaction_decl_subst \<xi> T"
           "transaction_fresh_subst \<sigma> T (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)" "transaction_renaming_subst \<alpha> P (vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t B)"
           "b \<in> set (transaction_strand T)" "(l, insert\<langle>t,t'\<rangle>) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p b \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
           "fst (l, insert\<langle>t,t'\<rangle>) = fst b"
         using reachable_constraints_transaction_action_obtain[OF A(1) t(1)] by metis
 
       define \<theta> where "\<theta> \<equiv> \<xi> \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<alpha>"
 
       obtain b' where "b = (l,b')"
         using T(8) by (cases b) simp
       then obtain tb tb'
           where b': "b = (l,insert\<langle>tb,tb'\<rangle>)"
             and tb: "t = tb \<cdot> \<theta>"
             and tb': "t' = tb' \<cdot> \<theta>"
         using T(7) unfolding \<theta>_def by (cases b') auto
 
       note T_wf = bspec[OF P(1) T(2)] bspec[OF P(2) T(2)]
 
       have b: "b \<in> set (transaction_updates T)"
         using transaction_strand_memberD[OF T(6)[unfolded b']]
               wellformed_transaction_cases[OF T_wf(1)]
         unfolding b' by blast
 
       have "is_Fun tb'"
         using bspec[OF P(2) T(2)]
               wellformed_transaction_strand_unlabel_memberD(6)[
                     OF T_wf(1) unlabel_in[OF T(6)[unfolded b']]]
         by fastforce
       hence *: "tb' = \<langle>d\<rangle>\<^sub>s"
         using t(3) unfolding b' tb' by force
 
       have "is_Insert (snd b)" "the_set_term (snd b) = \<langle>d\<rangle>\<^sub>s" "the_elem_term (snd b) = tb"
         unfolding b' * by simp_all
       hence "transaction_send T \<noteq> []"
             "let (l, a) = hd (transaction_send T)
              in l = \<star> \<and> is_Send a \<and> \<langle>f [\<langle>c\<rangle>\<^sub>c, tb]\<rangle>\<^sub>t \<in> set (the_msgs a)"
         using P_d T(2) b by (fast,fast)
       hence "\<exists>ts. \<langle>\<star>,send\<langle>ts\<rangle>\<rangle> \<in> set (transaction_send T) \<and> \<langle>f [\<langle>c\<rangle>\<^sub>c, tb]\<rangle>\<^sub>t \<in> set ts"
         unfolding is_Send_def by (cases "transaction_send T") auto
       then obtain ts where ts: "\<langle>\<star>,send\<langle>ts\<rangle>\<rangle> \<in> set (transaction_strand T)" "\<langle>f [\<langle>c\<rangle>\<^sub>c, tb]\<rangle>\<^sub>t \<in> set ts"
         unfolding transaction_strand_def by auto
       
       have "\<langle>\<star>,receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle> \<in> set A" "\<langle>f [\<langle>c\<rangle>\<^sub>c, t]\<rangle>\<^sub>t \<in> set (ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>)"
         using subst_lsst_memI[OF ts(1), of \<theta>] subst_set_map[OF ts(2), of \<theta>]
               dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_steps_iff(1)[of \<star> "ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>" "transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>"]
               set_mono_prefix[OF T(1)[unfolded \<theta>_def[symmetric]]]
         unfolding tb by auto
       hence "\<langle>f [\<langle>c\<rangle>\<^sub>c, k]\<rangle>\<^sub>t \<in> \<Union>{set ts |ts. \<langle>\<star>, receive\<langle>ts\<rangle>\<rangle> \<in> set (A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t I)}"
         using t(2) subst_lsst_memI[of "\<langle>\<star>,receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>\<rangle>" A I] by force
       thus False
         using A(2) unfolding declassified\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by auto
     qed
 
     have "y' \<notin> fv\<^sub>s\<^sub>e\<^sub>t (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A)"
       using y'' fv_ik_subset_vars_sst'[of "unlabel A"] by blast 
     hence 1: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I = ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J"
       unfolding J_def by (metis (no_types, lifting) fv_subset image_cong in_mono repl_invariance)
 
     have "(k,\<langle>d\<rangle>\<^sub>s) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) I {}"
       using 0 db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel A" I "[]"]
       unfolding db\<^sub>s\<^sub>s\<^sub>t_def by force
     hence "(k,\<langle>d\<rangle>\<^sub>s) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {}"
       using y'' vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel A"]
             db\<^sub>s\<^sub>s\<^sub>t_subst_swap[of "unlabel A" I J "[]"]
             db\<^sub>s\<^sub>s\<^sub>t_set_is_dbupd\<^sub>s\<^sub>s\<^sub>t[of "unlabel A" _ "[]"]
       unfolding db\<^sub>s\<^sub>s\<^sub>t_def J_def by (metis (no_types, lifting) Un_iff empty_set fun_upd_other)
     hence "((Var y' \<cdot> J, \<langle>d\<rangle>\<^sub>s \<cdot> J) \<notin> dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {})"
       unfolding J_def fk by simp
     hence "strand_sem_stateful (ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J) (dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {})
             (unlabel [\<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>]) J"
       using stateful_strand_sem_NegChecks_no_bvars(1)[
               of "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J" "dbupd\<^sub>s\<^sub>s\<^sub>t (unlabel A) J {}" "Var y'" "\<langle>d\<rangle>\<^sub>s" J]
       by simp
     hence 2: "strand_sem_stateful {} {} (unlabel (A@[\<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>])) J"
       using A'' y' y'' vars\<^sub>s\<^sub>s\<^sub>t_is_fv\<^sub>s\<^sub>s\<^sub>t_bvars\<^sub>s\<^sub>s\<^sub>t[of "unlabel A"]
             strand_sem_append_stateful[
               of "{}" "{}" "unlabel A" "unlabel [\<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>]" J]
       unfolding J_def by simp
 
     have B: "B \<in> reachable_constraints P"
       using reachable_constraints.step[OF A(1) P_Tatt _ _ \<alpha>, of Var Var]
       unfolding B_def Tatt_def transaction_decl_subst_def transaction_fresh_subst_def by simp
 
     have Tatt': "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand Tatt \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<alpha>) =
                   [(l, send\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, Var y']\<rangle>\<^sub>t]\<rangle>),
                    (l', \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>),
                    \<langle>n, receive\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]"
       using y'
       unfolding Tatt_def transaction_strand_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def subst_apply_labeled_stateful_strand_def
       by auto
 
     have J: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t J" "interpretation\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t J" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range J)"
       unfolding J_def
       subgoal using wt_subst_subst_upd[OF I(1)] k(1) y'(3) by simp 
       subgoal by (metis I(2) k(2) fun_upd_apply interpretation_grounds_all interpretation_substI)
       subgoal using I(3) k(3) by fastforce
       done
 
     have 3: "ik\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t J \<turnstile> \<langle>f [\<langle>c\<rangle>\<^sub>c, Var y']\<rangle>\<^sub>t \<cdot> J"
       using 1 fk fk' unfolding J_def by auto
 
     have "strand_sem_stateful {} {} (unlabel A) J"
       using 2 strand_sem_append_stateful by force
     hence "strand_sem_stateful {} {}
             (unlabel (A@[\<langle>n, send\<langle>[\<langle>f [\<langle>c\<rangle>\<^sub>c, Var y']\<rangle>\<^sub>t]\<rangle>\<rangle>,
                          \<langle>n, \<langle>Var y' not in \<langle>d\<rangle>\<^sub>s\<rangle>\<rangle>])) J"
       using 2 3 strand_sem_append_stateful[of "{}" "{}" _ _ J]
       unfolding unlabel_def ik\<^sub>s\<^sub>s\<^sub>t_def by force
     hence "strand_sem_stateful {} {} (unlabel (B@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])) J"
       using strand_sem_receive_send_append[of "{}" "{}" _ J "attack\<langle>ln n\<rangle>"]
             strand_sem_append_stateful[of "{}" "{}" _ _ J]
       unfolding B_def Tatt' by simp
     hence "welltyped_constraint_model J (B@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
       using B J unfolding defs' by blast
     thus False using B(1) P_sec by blast
   qed
 qed
 
 definition welltyped_leakage_free_invkey_conditions' where
   "welltyped_leakage_free_invkey_conditions' invfun privfunsec declassifiedset S n P \<equiv>
     let f = \<lambda>s. is_Var s \<and> fst (the_Var s) = TAtom Value;
         g = \<lambda>s. is_Fun s \<and> args s = [] \<and> is_Set (the_Fun s) \<and>
                 arity\<^sub>s (the_Set (the_Fun s)) = 0;
         h = \<lambda>s. is_Fun s \<and> args s = [] \<and> is_Fu (the_Fun s) \<and>
                 public\<^sub>f (the_Fu (the_Fun s)) \<and> arity\<^sub>f (the_Fu (the_Fun s)) = 0
     in (\<forall>s\<in>set S.
           f s \<or>
           (is_Fun s \<and> the_Fun s = Pair \<and> length (args s) = 2 \<and> g (args s ! 1)) \<or>
           g s \<or> h s \<or> s = \<langle>privfunsec\<rangle>\<^sub>c \<or> s = Fun OccursSec [] \<or>
           (is_Fun s \<and> the_Fun s = OccursFact \<and> length (args s) = 2 \<and>
            args s ! 0 = Fun OccursSec []) \<or>
           (is_Fun s \<and> the_Fun s = Fu invfun \<and> length (args s) = 2 \<and>
            args s ! 0 = \<langle>privfunsec\<rangle>\<^sub>c \<and> f (args s ! 1)) \<or>
           (is_Fun s \<and> is_Fu (the_Fun s) \<and> fv s = {} \<and>
            Transaction (\<lambda>(). []) [] [\<langle>n, receive\<langle>[s]\<rangle>\<rangle>] [] [] [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]\<in>set P)) \<and>
        (\<not>public\<^sub>f privfunsec \<and> arity\<^sub>f privfunsec = 0 \<and> \<Gamma>\<^sub>f privfunsec \<noteq> None) \<and>
        (\<forall>T\<in>set P. transaction_fresh T \<noteq> [] \<longrightarrow>
          transaction_send T \<noteq> [] \<and>
          (let (l, a) = hd (transaction_send T)
           in l = \<star> \<and> is_Send a \<and> Var ` set (transaction_fresh T) \<subseteq> set (the_msgs a))) \<and>
        (\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T. is_Var (\<Gamma>\<^sub>v x)) \<and>
        (\<forall>T\<in>set P. \<forall>x\<in>set (transaction_fresh T). \<Gamma>\<^sub>v x = Var Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)) \<and>
        (\<forall>T\<in>set P. \<forall>f\<in>\<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<not>is_Set f) \<and>
        (\<forall>T\<in>set P. \<forall>r\<in>set (transaction_send T).
           OccursFact \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd r)) \<longrightarrow> has_LabelS r) \<and>
        (\<forall>T\<in>set P. \<forall>t\<in>subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)).
           \<langle>privfunsec\<rangle>\<^sub>c \<notin> set (snd (Ana t))) \<and>
        (\<forall>T\<in>set P. \<langle>privfunsec\<rangle>\<^sub>c \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<and>
        (\<forall>T\<in>set P. \<forall>a\<in>set (transaction_updates T).
             is_Insert (snd a) \<and> the_set_term (snd a) = \<langle>declassifiedset\<rangle>\<^sub>s \<longrightarrow>
               transaction_send T \<noteq> [] \<and>
               (let (l, b) = hd (transaction_send T)
                in l = \<star> \<and> is_Send b \<and>
                   \<langle>invfun [\<langle>privfunsec\<rangle>\<^sub>c, the_elem_term (snd a)]\<rangle>\<^sub>t \<in> set (the_msgs b)))"
 
 definition welltyped_leakage_free_invkey_conditions where
   "welltyped_leakage_free_invkey_conditions invfun privfunsec declassifiedset S n P \<equiv>
     let Tatt = \<lambda>R. Transaction (\<lambda>(). []) []
                     (R@[\<langle>n, receive\<langle>[\<langle>invfun [\<langle>privfunsec\<rangle>\<^sub>c, \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<^sub>t]\<rangle>\<rangle>])
                     [\<langle>\<star>, \<langle>\<langle>0: value\<rangle>\<^sub>v not in \<langle>declassifiedset\<rangle>\<^sub>s\<rangle>\<rangle>]
                     []
                     [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]
     in welltyped_leakage_free_invkey_conditions' invfun privfunsec declassifiedset S n P \<and>
        has_initial_value_producing_transaction P \<and>
        (if Tatt [\<langle>\<star>, receive\<langle>[occurs \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<rangle>] \<in> set P
         then \<forall>T\<in>set P. admissible_transaction' T \<and> admissible_transaction_occurs_checks T
         else Tatt [] \<in> set P \<and>
              (\<forall>T\<in>set P. wellformed_transaction T) \<and>
              (\<forall>T\<in>set P. admissible_transaction_terms T) \<and>
              (\<forall>T\<in>set P. bvars_transaction T = {}) \<and>
              (\<forall>T\<in>set P. transaction_decl T () = []) \<and>
              (\<forall>T\<in>set P. \<forall>x\<in>set (transaction_fresh T). let \<tau> = fst x
                 in \<tau> = TAtom Value \<and> \<tau> \<noteq> \<Gamma> \<langle>privfunsec\<rangle>\<^sub>c) \<and>
              (\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T. let \<tau> = fst x
                 in is_Var \<tau> \<and> (the_Var \<tau> = Value \<or> is_Atom (the_Var \<tau>)) \<and> \<tau> \<noteq> \<Gamma> \<langle>privfunsec\<rangle>\<^sub>c) \<and>
              (\<forall>T\<in>set P. \<forall>t\<in>subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)).
                 Fun OccursSec [] \<notin> set (snd (Ana t))) \<and>
              (\<forall>T\<in>set P. Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<and>
              (\<forall>T\<in>set P. \<forall>x\<in>set (unlabel (transaction_updates T)).
                 is_Update x \<longrightarrow> is_Fun (the_set_term x)) \<and>
              (\<forall>s\<in>set S. is_Fun s \<longrightarrow> the_Fun s \<noteq> OccursFact))"
 
 lemma welltyped_leakage_free_invkeyI:
   assumes P_wt_secure: "\<forall>\<A> \<in> reachable_constraints P.
                          \<nexists>\<I>. welltyped_constraint_model \<I> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
     and a: "welltyped_leakage_free_invkey_conditions invfun privsec declassset S n P"
   shows "welltyped_leakage_free_protocol S P"
 proof -
   let ?Tatt' = "\<lambda>R C. Transaction (\<lambda>(). []) [] R C [] [\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>]
                         ::('fun,'atom,'sets,'lbl) prot_transaction"
   let ?Tatt = "\<lambda>R. ?Tatt' (R@[\<langle>n, receive\<langle>[\<langle>invfun [\<langle>privsec\<rangle>\<^sub>c, \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<^sub>t]\<rangle>\<rangle>])
                           [\<langle>\<star>, \<langle>\<langle>0: value\<rangle>\<^sub>v not in \<langle>declassset\<rangle>\<^sub>s\<rangle>\<rangle>]"
   
   define Tatt1 where "Tatt1 \<equiv> ?Tatt [\<langle>\<star>, receive\<langle>[occurs \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<rangle>]"
   define Tatt2 where "Tatt2 \<equiv> ?Tatt []"
   define Tatt_lts where "Tatt_lts \<equiv> \<lambda>s. ?Tatt' [\<langle>n, receive\<langle>[s]\<rangle>\<rangle>] []"
 
   note defs = welltyped_leakage_free_invkey_conditions_def Let_def
 
   note defs' = defs welltyped_leakage_free_invkey_conditions'_def
 
   note Tatts = Tatt1_def Tatt2_def Tatt_lts_def
 
   obtain at where 0: "\<not>public\<^sub>f privsec" "arity\<^sub>f privsec = 0" "\<Gamma>\<^sub>f privsec = Some at"
     using a unfolding defs' by fast
 
   have *: "\<forall>T\<in>set P. admissible_transaction' T" "\<forall>T\<in>set P. admissible_transaction_occurs_checks T"
     when "Tatt1 \<in> set P"
     using a that unfolding defs Tatts by (meson,meson)
 
   have **: "Tatt1 \<in> set P \<or> Tatt2 \<in> set P" using a unfolding defs Tatts by argo
 
   have ***:
     "\<forall>T\<in>set P. \<forall>x\<in>set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<and> \<Gamma>\<^sub>v x \<noteq> \<Gamma> \<langle>privsec\<rangle>\<^sub>c"
     "\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T. \<exists>a. \<Gamma>\<^sub>v x = TAtom a \<and>
           (a = Value \<or> (\<exists>b. a = Atom b)) \<and> TAtom a \<noteq> \<Gamma> \<langle>privsec\<rangle>\<^sub>c"
     when "Tatt1 \<notin> set P"
     subgoal using a that \<Gamma>\<^sub>v_TAtom''(2) unfolding defs Tatts by metis
     subgoal
       using a that \<Gamma>\<^sub>v_TAtom''(1,2)
       unfolding defs Tatts[symmetric] is_Atom_def is_Var_def by fastforce
     done
 
   have ****: "s \<noteq> occurs x"
     when "Tatt1 \<notin> set P" "s \<in> set S" for s x
     using a that ** unfolding defs Tatts the_Fun_def by fastforce
 
   have 1:
       "\<forall>T\<in>set P. transaction_fresh T \<noteq> [] \<longrightarrow>
         transaction_send T \<noteq> [] \<and>
         (let (l, a) = hd (transaction_send T)
          in l = \<star> \<and> is_Send a \<and> Var ` set (transaction_fresh T) \<subseteq> set (the_msgs a))"
       "\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T. is_Var (\<Gamma>\<^sub>v x)"
       "\<forall>T\<in>set P. \<forall>x\<in>set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
       "\<forall>T\<in>set P. \<forall>f\<in>\<Union>(funs_term ` trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<not>is_Set f"
       "\<forall>T\<in>set P. \<forall>r\<in>set (transaction_send T).
         OccursFact \<in> \<Union>(funs_term ` trms\<^sub>s\<^sub>s\<^sub>t\<^sub>p (snd r)) \<longrightarrow> has_LabelS r"
       "\<forall>T\<in>set P. \<forall>t\<in>subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). \<langle>privsec\<rangle>\<^sub>c \<notin> set (snd (Ana t))"
       "\<forall>T\<in>set P. \<langle>privsec\<rangle>\<^sub>c \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       "\<forall>T\<in>set P. \<forall>a\<in>set (transaction_updates T).
         is_Insert (snd a) \<and> the_set_term (snd a) = \<langle>declassset\<rangle>\<^sub>s \<longrightarrow>
         transaction_send T \<noteq> [] \<and>
         (let (l, b) = hd (transaction_send T)
          in l = \<star> \<and> is_Send b \<and>
             \<langle>invfun [\<langle>privsec\<rangle>\<^sub>c, the_elem_term (snd a)]\<rangle>\<^sub>t \<in> set (the_msgs b))"
     using a unfolding defs' by (meson,meson,meson,meson,meson,meson,meson,meson)
 
   have 2:
       "\<forall>T\<in>set P. wellformed_transaction T"
       "\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T \<union> set (transaction_fresh T). \<Gamma> \<langle>privsec\<rangle>\<^sub>c \<noteq> \<Gamma>\<^sub>v x"
       "\<forall>T\<in>set P. admissible_transaction_terms T"
       "\<forall>T\<in>set P. \<forall>x\<in>set (transaction_fresh T). \<Gamma>\<^sub>v x = TAtom Value"
       "\<forall>T\<in>set P. transaction_decl T () = []"
       "\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T. \<Gamma>\<^sub>v x = TAtom Value \<or> (\<exists>a. \<Gamma>\<^sub>v x = \<langle>a\<rangle>\<^sub>\<tau>\<^sub>a)"
       "\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T \<union> set (transaction_fresh T). \<Gamma>\<^sub>v x \<noteq> TAtom SetType"
       "\<forall>T\<in>set P. \<forall>x\<in>vars_transaction T \<union> set (transaction_fresh T). \<Gamma>\<^sub>v x \<noteq> TAtom OccursSecType"
       "\<forall>T\<in>set P. \<forall>t\<in>subterms\<^sub>s\<^sub>e\<^sub>t (trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)). Fun OccursSec [] \<notin> set (snd (Ana t))"
       "\<forall>T\<in>set P. Fun OccursSec [] \<notin> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
       "\<forall>T\<in>set P. bvars_transaction T = {}"
       "\<forall>T\<in>set P. \<forall>x\<in>set (unlabel (transaction_updates T)). is_Update x \<longrightarrow> is_Fun (the_set_term x)"
     subgoal using a * unfolding defs by (metis admissible_transaction_is_wellformed_transaction(1))
     subgoal
       apply (cases "Tatt1 \<in> set P")
       subgoal using a * admissible_transactionE(2,3) \<Gamma>_Fu_simps(4) unfolding defs Tatts by force
       subgoal using a \<Gamma>_Fu_simps(4) unfolding defs Tatts by fastforce
       done
     subgoal using a * admissible_transaction_is_wellformed_transaction(4) unfolding defs by metis
     subgoal using a * admissible_transactionE(2) unfolding defs Tatts[symmetric] by fastforce
     subgoal using a * admissible_transactionE(1) unfolding defs Tatts[symmetric] by metis
     subgoal using * *** admissible_transactionE(3) by fast
     subgoal using * *** admissible_transactionE(2,3) by (cases "Tatt1 \<in> set P") (force, fastforce)
     subgoal using * *** admissible_transactionE(2,3) by (cases "Tatt1 \<in> set P") (force, fastforce)
     subgoal using a * admissible_transaction_occurs_checksE6 unfolding defs by metis
     subgoal using a * admissible_transaction_occurs_checksE5 unfolding defs by metis
     subgoal
       using a * admissible_transaction_no_bvars(2)
       unfolding defs Tatts[symmetric] by fastforce
     subgoal
       using a * admissible_transaction_is_wellformed_transaction(3)
       unfolding defs Tatts[symmetric] admissible_transaction_updates_def by fastforce
     done
 
   have Tatt_lts_case:
       "\<exists>\<theta>. wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<theta> \<and> inj_on \<theta> (fv s) \<and> \<theta> ` fv s \<subseteq> range Var \<and>
            ?Tatt' [\<langle>n, receive\<langle>[s \<cdot> \<theta>]\<rangle>\<rangle>] [] \<in> set P"
     when s: "fv s = {}" "Tatt_lts s \<in> set P" for s
   proof -
     have "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t Var" "inj_on Var (fv s)" "Var ` fv s \<subseteq> range Var" "s \<cdot> Var = s"
       using s(1) by simp_all
     thus ?thesis using s(2) unfolding Tatts by metis
   qed
 
   have Tatt1_case:
       "?Tatt' [\<langle>\<star>, receive\<langle>[occurs \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<rangle>, \<langle>n, receive\<langle>[\<langle>invfun [\<langle>privsec\<rangle>\<^sub>c, \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<^sub>t]\<rangle>\<rangle>] 
               [\<langle>\<star>, \<langle>\<langle>0: value\<rangle>\<^sub>v not in \<langle>declassset\<rangle>\<^sub>s\<rangle>\<rangle>] \<in> set P"
       when "Tatt1 \<in> set P"
     using that unfolding Tatts by auto
 
   have Tatt2_case:
       "?Tatt' [\<langle>n, receive\<langle>[\<langle>invfun [\<langle>privsec\<rangle>\<^sub>c, \<langle>0: value\<rangle>\<^sub>v]\<rangle>\<^sub>t]\<rangle>\<rangle>] 
               [\<langle>\<star>, \<langle>\<langle>0: value\<rangle>\<^sub>v not in \<langle>declassset\<rangle>\<^sub>s\<rangle>\<rangle>] \<in> set P"
     when "Tatt2 \<in> set P"
     using that unfolding Tatts by auto
 
   note 3 = pair_def case_prod_conv
   note 4 = welltyped_leakage_free_priv_constI'[OF 0(1-3) 2(1,2) 1(2,3,6,7)]
   note 5 = welltyped_leakage_free_setop_pairI[OF 2(1,6) 1(4) 2(4,5,3), unfolded 3]
            welltyped_leakage_free_set_constI(2)[OF 2(1) 1(4) 2(7) 1(2,3), unfolded 3]
            welltyped_leakage_free_pub_constI
            4(2)
            welltyped_leakage_free_occurssec_constI(2)[OF 2(1,8-10) 1(2,3)]
            welltyped_leakage_free_value_constI[OF 2(1,3,5,11) 1(1)]
            welltyped_leakage_free_short_term_secretI'[
              OF 2(1,12) 4(1) P_wt_secure Tatt2_case 1(8)]
 
            welltyped_leakage_free_long_term_secretI[OF P_wt_secure Tatt_lts_case]
 
            welltyped_leakage_free_short_term_secretI[
              OF * 1(3) 4(1) P_wt_secure Tatt1_case 1(8)]
            welltyped_leakage_free_occurs_factI[OF * 1(5)]
 
            ** ****
 
   have 6: "is_Fun s \<and> length (args s) = 2 \<longleftrightarrow> (\<exists>f t u. s = Fun f [t, u])"
     for s::"('fun,'atom,'sets,'lbl) prot_term"
     by auto
 
   define pubconst_cond where
     "pubconst_cond \<equiv> \<lambda>s::('fun,'atom,'sets,'lbl) prot_term.
       is_Fun s \<and> args s = [] \<and> is_Fu (the_Fun s) \<and>
       public\<^sub>f (the_Fu (the_Fun s)) \<and> arity\<^sub>f (the_Fu (the_Fun s)) = 0"
 
   define valuevar_cond where
     "valuevar_cond \<equiv> \<lambda>s::('fun,'atom,'sets,'lbl) prot_term.
       is_Var s \<and> fst (the_Var s) = TAtom Value"
 
   define setconst_cond where
     "setconst_cond \<equiv> \<lambda>s::('fun,'atom,'sets,'lbl) prot_term.
       is_Fun s \<and> args s = [] \<and> is_Set (the_Fun s) \<and> arity\<^sub>s (the_Set (the_Fun s)) = 0"
 
   define setop_pair_cond where
     "setop_pair_cond \<equiv> \<lambda>s. 
       is_Fun s \<and> the_Fun s = Pair \<and> length (args s) = 2 \<and> setconst_cond (args s ! 1)"
 
   define occursfact_cond where
     "occursfact_cond \<equiv> \<lambda>s::('fun,'atom,'sets,'lbl) prot_term.
       is_Fun s \<and> the_Fun s = OccursFact \<and> length (args s) = 2 \<and>
       args s ! 0 = Fun OccursSec []"
 
   define invkey_cond where
     "invkey_cond \<equiv> \<lambda>s.
       is_Fun s \<and> the_Fun s = Fu invfun \<and> length (args s) = 2 \<and>
       args s ! 0 = \<langle>privsec\<rangle>\<^sub>c \<and> valuevar_cond (args s ! 1)"
 
   define ground_lts_cond where
     "ground_lts_cond \<equiv> \<lambda>s. is_Fun s \<and> is_Fu (the_Fun s) \<and> fv s = {} \<and> Tatt_lts s \<in> set P"
 
   note cond_defs =
     pubconst_cond_def valuevar_cond_def setconst_cond_def setop_pair_cond_def
     occursfact_cond_def invkey_cond_def ground_lts_cond_def
 
   have "(\<exists>m. s = \<langle>m: value\<rangle>\<^sub>v) \<longleftrightarrow> valuevar_cond s"
        "(\<exists>x c. arity\<^sub>s c = 0 \<and> s = Fun Pair [x, \<langle>c\<rangle>\<^sub>s]) \<longleftrightarrow> setop_pair_cond s"
        "(\<exists>c. arity\<^sub>s c = 0 \<and> s = \<langle>c\<rangle>\<^sub>s) \<longleftrightarrow> setconst_cond s"
        "(\<exists>c. public\<^sub>f c \<and> arity\<^sub>f c = 0 \<and> s = \<langle>c\<rangle>\<^sub>c) \<longleftrightarrow> pubconst_cond s"
        "(\<exists>x. s = occurs x) \<longleftrightarrow> occursfact_cond s"
        "(\<exists>x. s = \<langle>invfun [\<langle>privsec\<rangle>\<^sub>c, \<langle>x: value\<rangle>\<^sub>v]\<rangle>\<^sub>t) \<longleftrightarrow> invkey_cond s"
        "(\<exists>f ts. s = \<langle>f ts\<rangle>\<^sub>t \<and> fv s = {} \<and> Tatt_lts s \<in> set P) \<longleftrightarrow> ground_lts_cond s"
     for s::"('fun,'atom,'sets,'lbl) prot_term"
     unfolding is_Set_def the_Set_def is_Fu_def cond_defs
     by (fastforce,use 6[of s] in fastforce,fastforce,force,fastforce,fastforce,fastforce)
   moreover have
       "(\<forall>s \<in> set S. valuevar_cond s \<or> setop_pair_cond s \<or> setconst_cond s \<or> pubconst_cond s \<or>
                     s = \<langle>privsec\<rangle>\<^sub>c \<or> s = Fun OccursSec [] \<or> occursfact_cond s \<or> invkey_cond s \<or>
                     ground_lts_cond s) \<and>
        (\<not>public\<^sub>f privsec \<and> arity\<^sub>f privsec = 0 \<and> \<Gamma>\<^sub>f privsec \<noteq> None)"
     using a unfolding defs' cond_defs Tatts by meson
   ultimately have 7:
       "\<forall>s \<in> set S.
         (\<exists>x c. arity\<^sub>s c = 0 \<and> s = Fun Pair [x, \<langle>c\<rangle>\<^sub>s]) \<or>
         (\<exists>c. arity\<^sub>s c = 0 \<and> s = \<langle>c\<rangle>\<^sub>s) \<or>
         (\<exists>c. public\<^sub>f c \<and> arity\<^sub>f c = 0 \<and> s = \<langle>c\<rangle>\<^sub>c) \<or>
         s = \<langle>privsec\<rangle>\<^sub>c \<or> s = Fun OccursSec [] \<or>
         (\<exists>m. s = \<langle>m: value\<rangle>\<^sub>v) \<or>
         (\<exists>x. s = occurs x) \<or>
         (\<exists>x. s = \<langle>invfun [\<langle>privsec\<rangle>\<^sub>c, \<langle>x: value\<rangle>\<^sub>v]\<rangle>\<^sub>t) \<or>
         (\<exists>f ts. s = \<langle>f ts\<rangle>\<^sub>t \<and> fv s = {} \<and> Tatt_lts s \<in> set P)"
     unfolding Let_def by fastforce
 
   show ?thesis
     by (rule iffD2[OF welltyped_leakage_free_protocol_pointwise]; unfold list_all_iff; intro ballI)
        (use bspec[OF 7] 5 in blast)
 qed
 
 end
 
 end
 
 locale composable_stateful_protocols =
   pm: stateful_protocol_model arity\<^sub>f arity\<^sub>s public\<^sub>f Ana\<^sub>f \<Gamma>\<^sub>f label_witness1 label_witness2
   for arity\<^sub>f::"'fun \<Rightarrow> nat"
     and arity\<^sub>s::"'sets \<Rightarrow> nat"
     and public\<^sub>f::"'fun \<Rightarrow> bool"
     and Ana\<^sub>f::"'fun \<Rightarrow> ((('fun,'atom::finite,'sets,nat) prot_fun, nat) term list \<times> nat list)"
     and \<Gamma>\<^sub>f::"'fun \<Rightarrow> 'atom option"
     and label_witness1::"nat"
     and label_witness2::"nat"
   +
   fixes Pc::"('fun,'atom,'sets,nat) prot_transaction list"
     and Ps Ps_with_star_projs::"('fun,'atom,'sets,nat) prot_transaction list list"
     and Pc_SMP Sec_symbolic::"('fun,'atom,'sets,nat) prot_term list"
     and Ps_GSMPs::"(nat \<times> ('fun,'atom,'sets,nat) prot_term list) list"
   assumes Pc_def: "Pc = concat Ps"
     and Ps_with_star_projs_def: "let Pc' = Pc; L = [0..<length Ps] in
           Ps_with_star_projs = map (\<lambda>n. (map (transaction_proj n) Pc')) L \<and>
           set L = set (remdups (concat (
                           map (\<lambda>T. map (the_LabelN \<circ> fst)
                                        (filter (Not \<circ> has_LabelS) (transaction_strand T)))
                               Pc')))"
     and Pc_wellformed_composable:
           "list_all (list_all (Not \<circ> has_LabelS) \<circ> tl \<circ> transaction_send) Pc"
           "pm.wellformed_composable_protocols Ps Pc_SMP"
           "pm.wellformed_composable_protocols' Ps"
           "pm.composable_protocols Ps Ps_GSMPs Sec_symbolic"
 begin
 
 theorem composed_protocol_preserves_component_goals:
   assumes components_leakage_free:
       "list_all (pm.welltyped_leakage_free_protocol Sec_symbolic) Ps_with_star_projs"
     and n_def: "n < length Ps_with_star_projs"
     and P_def: "P = Ps_with_star_projs ! n"
     and P_welltyped_secure:
       "\<forall>\<A> \<in> pm.reachable_constraints P. \<nexists>\<I>.
           pm.welltyped_constraint_model \<I> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
   shows "\<forall>\<A> \<in> pm.reachable_constraints Pc. \<nexists>\<I>.
           pm.constraint_model \<I> (\<A>@[\<langle>n, send\<langle>[attack\<langle>ln n\<rangle>]\<rangle>\<rangle>])"
 proof -
   note 0 = Ps_with_star_projs_def[unfolded Let_def]
 
   have 1:
       "set Ps_with_star_projs =
           (\<lambda>n. map (transaction_proj n) Pc) `
             set (remdups (concat (map (\<lambda>T. map (the_LabelN \<circ> fst)
                                                (filter (Not \<circ> has_LabelS) (transaction_strand T)))
                                       Pc)))"
     by (metis (mono_tags, lifting) 0 image_set)
 
   have 2: "Ps_with_star_projs ! n = map (transaction_proj n) Pc"
     using conjunct1[OF 0] n_def by fastforce
 
   show ?thesis
     by (rule pm.composable_protocols_par_comp_prot'[
                   OF Pc_def 1 Pc_wellformed_composable
                      components_leakage_free 2 P_welltyped_secure[unfolded P_def]])
 qed
 
 end
 
 end
diff --git a/thys/Automated_Stateful_Protocol_Verification/Term_Implication.thy b/thys/Automated_Stateful_Protocol_Verification/Term_Implication.thy
--- a/thys/Automated_Stateful_Protocol_Verification/Term_Implication.thy
+++ b/thys/Automated_Stateful_Protocol_Verification/Term_Implication.thy
@@ -1,2845 +1,2845 @@
 (*  Title:      Term_Implication.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\<open>Term Implication\<close>
 theory Term_Implication
   imports Stateful_Protocol_Model Term_Variants
 begin
 
 subsection \<open>Single Term Implications\<close>
 definition timpl_apply_term ("\<langle>_ --\<guillemotright> _\<rangle>\<langle>_\<rangle>") where
   "\<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle> \<equiv> term_variants ((\<lambda>_. [])(Abs a := [Abs b])) t"
 
 definition timpl_apply_terms ("\<langle>_ --\<guillemotright> _\<rangle>\<langle>_\<rangle>\<^sub>s\<^sub>e\<^sub>t") where
   "\<langle>a --\<guillemotright> b\<rangle>\<langle>M\<rangle>\<^sub>s\<^sub>e\<^sub>t \<equiv> \<Union>((set o timpl_apply_term a b) ` M)"
 
 lemma timpl_apply_Fun:
   assumes "\<And>i. i < length T \<Longrightarrow> S ! i \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>T ! i\<rangle>"
     and "length T = length S"
   shows "Fun f S \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun f T\<rangle>"
 using assms term_variants_Fun term_variants_pred_iff_in_term_variants
 by (metis timpl_apply_term_def)
 
 lemma timpl_apply_Abs:
   assumes "\<And>i. i < length T \<Longrightarrow> S ! i \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>T ! i\<rangle>"
     and "length T = length S"
   shows "Fun (Abs b) S \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun (Abs a) T\<rangle>"
 using assms(1) term_variants_P[OF assms(2), of "(\<lambda>_. [])(Abs a := [Abs b])" "Abs b" "Abs a"]
 unfolding timpl_apply_term_def term_variants_pred_iff_in_term_variants[symmetric]
 by fastforce
 
 lemma timpl_apply_refl: "t \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle>"
 unfolding timpl_apply_term_def
 by (metis term_variants_pred_refl term_variants_pred_iff_in_term_variants)
 
 lemma timpl_apply_const: "Fun (Abs b) [] \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun (Abs a) []\<rangle>"
 using term_variants_pred_iff_in_term_variants term_variants_pred_const
 unfolding timpl_apply_term_def by auto
 
 lemma timpl_apply_const':
   "c = a \<Longrightarrow> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun (Abs c) []\<rangle> = {Fun (Abs b) [], Fun (Abs c) []}"
   "c \<noteq> a \<Longrightarrow> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun (Abs c) []\<rangle> = {Fun (Abs c) []}"
 using term_variants_pred_const_cases[of "(\<lambda>_. [])(Abs a := [Abs b])" "Abs c"]
       term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs a := [Abs b])"]
 unfolding timpl_apply_term_def by auto
 
 lemma timpl_apply_term_subst:
   "s \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle> \<Longrightarrow> s \<cdot> \<delta> \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t \<cdot> \<delta>\<rangle>"
 by (metis term_variants_pred_iff_in_term_variants term_variants_pred_subst timpl_apply_term_def)
 
 lemma timpl_apply_inv:
   assumes "Fun h S \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun f T\<rangle>"
   shows "length T = length S"
     and "\<And>i. i < length T \<Longrightarrow> S ! i \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>T ! i\<rangle>"
     and "f \<noteq> h \<Longrightarrow> f = Abs a \<and> h = Abs b"
 using assms term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs a := [Abs b])"]
 unfolding timpl_apply_term_def
 by (metis (full_types) term_variants_pred_inv(1),
     metis (full_types) term_variants_pred_inv(2),
     fastforce dest: term_variants_pred_inv(3))
 
 lemma timpl_apply_inv':
   assumes "s \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>Fun f T\<rangle>"
   shows "\<exists>g S. s = Fun g S"
 proof -
   have *: "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) (Fun f T) s"
     using assms term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs a := [Abs b])"]
     unfolding timpl_apply_term_def by force
   show ?thesis using term_variants_pred.cases[OF *, of ?thesis] by fastforce
 qed
 
 lemma timpl_apply_term_Var_iff:
   "Var x \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle> \<longleftrightarrow> t = Var x"
 using term_variants_pred_inv_Var term_variants_pred_iff_in_term_variants
 unfolding timpl_apply_term_def by metis
 
 
 
 subsection \<open>Term Implication Closure\<close>
 inductive_set timpl_closure for t TI where
   FP: "t \<in> timpl_closure t TI"
 | TI: "\<lbrakk>u \<in> timpl_closure t TI; (a,b) \<in> TI; term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u s\<rbrakk>
        \<Longrightarrow> s \<in> timpl_closure t TI"
 
 definition "timpl_closure_set M TI \<equiv> (\<Union>t \<in> M. timpl_closure t TI)"
 
 inductive_set timpl_closure'_step for TI where
   "\<lbrakk>(a,b) \<in> TI; term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) t s\<rbrakk>
     \<Longrightarrow> (t,s) \<in> timpl_closure'_step TI"
 
 definition "timpl_closure' TI \<equiv> (timpl_closure'_step TI)\<^sup>*"
 
 definition comp_timpl_closure where
   "comp_timpl_closure FP TI \<equiv>
     let f = \<lambda>X. FP \<union> (\<Union>x \<in> X. \<Union>(a,b) \<in> TI. set \<langle>a --\<guillemotright> b\<rangle>\<langle>x\<rangle>)
     in while (\<lambda>X. f X \<noteq> X) f {}"
 
 definition comp_timpl_closure_list where
   "comp_timpl_closure_list FP TI \<equiv>
     let f = \<lambda>X. remdups (concat (map (\<lambda>x. concat (map (\<lambda>(a,b). \<langle>a --\<guillemotright> b\<rangle>\<langle>x\<rangle>) TI)) X)@X)
     in while (\<lambda>X. set (f X) \<noteq> set X) f FP"
 
 lemma timpl_closure_setI:
   "t \<in> M \<Longrightarrow> t \<in> timpl_closure_set M TI"
 unfolding timpl_closure_set_def by (auto intro: timpl_closure.FP)
 
 lemma timpl_closure_set_empty_timpls:
   "timpl_closure t {} = {t}" (is "?A = ?B")
 proof (intro subset_antisym subsetI)
   fix s show "s \<in> ?A \<Longrightarrow> s \<in> ?B"
     by (induct s rule: timpl_closure.induct) auto
 qed (simp add: timpl_closure.FP)
 
 lemmas timpl_closure_set_is_timpl_closure_union = meta_eq_to_obj_eq[OF timpl_closure_set_def]
 
 lemma term_variants_pred_eq_case_Abs:
   fixes a b
   defines "P \<equiv> (\<lambda>_. [])(Abs a := [Abs b])"
   assumes "term_variants_pred P t s" "\<forall>f \<in> funs_term s. \<not>is_Abs f"
   shows "t = s"
 using assms(2,3)
 proof (induction t s rule: term_variants_pred.induct)
   case (term_variants_Fun T S f)
   have "\<not>is_Abs h" when i: "i < length S" and h: "h \<in> funs_term (S ! i)" for i h
     using i h term_variants_Fun.prems by auto
   hence "T ! i = S ! i" when i: "i < length T" for i
     using i term_variants_Fun.hyps(1) term_variants_Fun.IH by auto
   hence "T = S" using term_variants_Fun.hyps(1) nth_equalityI[of T S] by fast
   thus ?case using term_variants_Fun.hyps(1) by blast
 qed (simp_all add: term_variants_pred_refl P_def)
 
 lemma timpl_closure'_step_inv:
   assumes "(t,s) \<in> timpl_closure'_step TI"
   obtains a b where "(a,b) \<in> TI" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) t s"
 using assms by (auto elim: timpl_closure'_step.cases)
 
 lemma timpl_closure_mono:
   assumes "TI \<subseteq> TI'"
   shows "timpl_closure t TI \<subseteq> timpl_closure t TI'"
 proof
   fix s show "s \<in> timpl_closure t TI \<Longrightarrow> s \<in> timpl_closure t TI'"
     apply (induct rule: timpl_closure.induct)
     using assms by (auto intro: timpl_closure.intros)
 qed
 
 lemma timpl_closure_set_mono:
   assumes "M \<subseteq> M'" "TI \<subseteq> TI'"
   shows "timpl_closure_set M TI \<subseteq> timpl_closure_set M' TI'"
 using assms(1) timpl_closure_mono[OF assms(2)] unfolding timpl_closure_set_def by fast
 
 lemma timpl_closure_idem:
   "timpl_closure_set (timpl_closure t TI) TI = timpl_closure t TI" (is "?A = ?B")
 proof
   have "s \<in> timpl_closure t TI"
     when "s \<in> timpl_closure u TI" "u \<in> timpl_closure t TI"
     for s u
     using that
     by (induction rule: timpl_closure.induct)
        (auto intro: timpl_closure.intros)
   thus "?A \<subseteq> ?B" unfolding timpl_closure_set_def by blast
 
   show "?B \<subseteq> ?A"
     unfolding timpl_closure_set_def
     by (blast intro: timpl_closure.FP)
 qed
 
 lemma timpl_closure_set_idem:
   "timpl_closure_set (timpl_closure_set M TI) TI = timpl_closure_set M TI"
 using timpl_closure_idem[of _ TI]unfolding timpl_closure_set_def by auto
 
 lemma timpl_closure_set_mono_timpl_closure_set:
   assumes N: "N \<subseteq> timpl_closure_set M TI"
   shows "timpl_closure_set N TI \<subseteq> timpl_closure_set M TI"
 using timpl_closure_set_mono[OF N, of TI TI] timpl_closure_set_idem[of M TI]
 by simp
 
 lemma timpl_closure_is_timpl_closure':
   "s \<in> timpl_closure t TI \<longleftrightarrow> (t,s) \<in> timpl_closure' TI"
 proof
   show "s \<in> timpl_closure t TI \<Longrightarrow> (t,s) \<in> timpl_closure' TI"
     unfolding timpl_closure'_def
     by (induct rule: timpl_closure.induct)
        (auto intro: rtrancl_into_rtrancl timpl_closure'_step.intros)
 
   show "(t,s) \<in> timpl_closure' TI \<Longrightarrow> s \<in> timpl_closure t TI"
     unfolding timpl_closure'_def
     by (induct rule: rtrancl_induct)
        (auto dest: timpl_closure'_step_inv
              intro: timpl_closure.FP timpl_closure.TI)
 qed
 
 lemma timpl_closure'_mono:
   assumes "TI \<subseteq> TI'"
   shows "timpl_closure' TI \<subseteq> timpl_closure' TI'"
 using timpl_closure_mono[OF assms]
       timpl_closure_is_timpl_closure'[of _ _ TI]
       timpl_closure_is_timpl_closure'[of _ _ TI']
 by fast
 
 lemma timpl_closureton_is_timpl_closure:
   "timpl_closure_set {t} TI = timpl_closure t TI"
 by (simp add: timpl_closure_set_is_timpl_closure_union)
 
 lemma timpl_closure'_timpls_trancl_subset:
   "timpl_closure' (c\<^sup>+) \<subseteq> timpl_closure' c"
 unfolding timpl_closure'_def
 proof
   fix s t::"(('a,'b,'c,'d) prot_fun,'e) term"
   show "(s,t) \<in> (timpl_closure'_step (c\<^sup>+))\<^sup>* \<Longrightarrow> (s,t) \<in> (timpl_closure'_step c)\<^sup>*"
   proof (induction rule: rtrancl_induct)
     case (step u t)
     obtain a b where ab:
         "(a,b) \<in> c\<^sup>+" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u t"
       using step.hyps(2) timpl_closure'_step_inv by blast
     hence "(u,t) \<in> (timpl_closure'_step c)\<^sup>*"
     proof (induction arbitrary: t rule: trancl_induct)
       case (step d e)
       obtain s where s:
           "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs d])) u s"
           "term_variants_pred ((\<lambda>_. [])(Abs d := [Abs e])) s t"
         using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
 
       have "(u,s) \<in> (timpl_closure'_step c)\<^sup>*"
            "(s,t) \<in> timpl_closure'_step c"
         using step.hyps(2) s(2) step.IH[OF s(1)]
         by (auto intro: timpl_closure'_step.intros)
       thus ?case by simp
     qed (auto intro: timpl_closure'_step.intros)
     thus ?case using step.IH by simp
   qed simp
 qed
 
 lemma timpl_closure'_timpls_trancl_subset':
   "timpl_closure' {(a,b) \<in> c\<^sup>+. a \<noteq> b} \<subseteq> timpl_closure' c"
 using timpl_closure'_timpls_trancl_subset
       timpl_closure'_mono[of "{(a,b) \<in> c\<^sup>+. a \<noteq> b}" "c\<^sup>+"]
 by fast
 
 lemma timpl_closure_set_timpls_trancl_subset:
   "timpl_closure_set M (c\<^sup>+) \<subseteq> timpl_closure_set M c"
 using timpl_closure'_timpls_trancl_subset[of c]
       timpl_closure_is_timpl_closure'[of _ _ c]
       timpl_closure_is_timpl_closure'[of _ _ "c\<^sup>+"]
       timpl_closure_set_is_timpl_closure_union[of M c]
       timpl_closure_set_is_timpl_closure_union[of M "c\<^sup>+"]
 by fastforce
 
 lemma timpl_closure_set_timpls_trancl_subset':
   "timpl_closure_set M {(a,b) \<in> c\<^sup>+. a \<noteq> b} \<subseteq> timpl_closure_set M c"
 using timpl_closure'_timpls_trancl_subset'[of c]
       timpl_closure_is_timpl_closure'[of _ _ c]
       timpl_closure_is_timpl_closure'[of _ _ "{(a,b) \<in> c\<^sup>+. a \<noteq> b}"]
       timpl_closure_set_is_timpl_closure_union[of M c]
       timpl_closure_set_is_timpl_closure_union[of M "{(a,b) \<in> c\<^sup>+. a \<noteq> b}"]
 by fastforce
 
 lemma timpl_closure'_timpls_trancl_supset':
   "timpl_closure' c \<subseteq> timpl_closure' {(a,b) \<in> c\<^sup>+. a \<noteq> b}"
 unfolding timpl_closure'_def
 proof
   let ?cl = "{(a,b) \<in> c\<^sup>+. a \<noteq> b}"
 
   fix s t::"(('a,'b,'c,'d) prot_fun,'e) term"
   show "(s,t) \<in> (timpl_closure'_step c)\<^sup>* \<Longrightarrow> (s,t) \<in> (timpl_closure'_step ?cl)\<^sup>*"
   proof (induction rule: rtrancl_induct)
     case (step u t)
     obtain a b where ab:
         "(a,b) \<in> c" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u t"
       using step.hyps(2) timpl_closure'_step_inv by blast
     hence "(a,b) \<in> c\<^sup>+" by simp
     hence "(u,t) \<in> (timpl_closure'_step ?cl)\<^sup>*" using ab(2)
     proof (induction arbitrary: t rule: trancl_induct)
       case (base d) show ?case
       proof (cases "a = d")
         case True thus ?thesis
           using base term_variants_pred_refl_inv[of _ u t]
           by force
       next
         case False thus ?thesis
           using base timpl_closure'_step.intros[of a d ?cl]
           by fast
       qed
     next
       case (step d e)
       obtain s where s:
           "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs d])) u s"
           "term_variants_pred ((\<lambda>_. [])(Abs d := [Abs e])) s t"
         using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
 
       show ?case
       proof (cases "d = e")
         case True
         thus ?thesis
           using step.prems step.IH[of t]
           by blast
       next
         case False
         hence "(u,s) \<in> (timpl_closure'_step ?cl)\<^sup>*"
               "(s,t) \<in> timpl_closure'_step ?cl"
           using step.hyps(2) s(2) step.IH[OF s(1)]
           by (auto intro: timpl_closure'_step.intros)
         thus ?thesis by simp
       qed
     qed
     thus ?case using step.IH by simp
   qed simp
 qed
 
 lemma timpl_closure'_timpls_trancl_supset:
   "timpl_closure' c \<subseteq> timpl_closure' (c\<^sup>+)"
 using timpl_closure'_timpls_trancl_supset'[of c]
       timpl_closure'_mono[of "{(a,b) \<in> c\<^sup>+. a \<noteq> b}" "c\<^sup>+"]
 by fast
 
 lemma timpl_closure'_timpls_trancl_eq:
   "timpl_closure' (c\<^sup>+) = timpl_closure' c"
 using timpl_closure'_timpls_trancl_subset timpl_closure'_timpls_trancl_supset
 by blast
 
 lemma timpl_closure'_timpls_trancl_eq':
   "timpl_closure' {(a,b) \<in> c\<^sup>+. a \<noteq> b} = timpl_closure' c"
 using timpl_closure'_timpls_trancl_subset' timpl_closure'_timpls_trancl_supset'
 by blast
 
 lemma timpl_closure'_timpls_rtrancl_subset:
   "timpl_closure' (c\<^sup>*) \<subseteq> timpl_closure' c"
 unfolding timpl_closure'_def
 proof
   fix s t::"(('a,'b,'c,'d) prot_fun,'e) term"
   show "(s,t) \<in> (timpl_closure'_step (c\<^sup>*))\<^sup>* \<Longrightarrow> (s,t) \<in> (timpl_closure'_step c)\<^sup>*"
   proof (induction rule: rtrancl_induct)
     case (step u t)
     obtain a b where ab:
         "(a,b) \<in> c\<^sup>*" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u t"
       using step.hyps(2) timpl_closure'_step_inv by blast
     hence "(u,t) \<in> (timpl_closure'_step c)\<^sup>*"
     proof (induction arbitrary: t rule: rtrancl_induct)
       case base
       hence "u = t" using term_variants_pred_refl_inv by fastforce
       thus ?case by simp
     next
       case (step d e)
       obtain s where s:
           "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs d])) u s"
           "term_variants_pred ((\<lambda>_. [])(Abs d := [Abs e])) s t"
         using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
 
       have "(u,s) \<in> (timpl_closure'_step c)\<^sup>*"
            "(s,t) \<in> timpl_closure'_step c"
         using step.hyps(2) s(2) step.IH[OF s(1)]
         by (auto intro: timpl_closure'_step.intros)
       thus ?case by simp
     qed
     thus ?case using step.IH by simp
   qed simp
 qed
 
 lemma timpl_closure'_timpls_rtrancl_supset:
   "timpl_closure' c \<subseteq> timpl_closure' (c\<^sup>*)"
 unfolding timpl_closure'_def
 proof
   fix s t::"(('a,'b,'c,'d) prot_fun,'e) term"
   show "(s,t) \<in> (timpl_closure'_step c)\<^sup>* \<Longrightarrow> (s,t) \<in> (timpl_closure'_step (c\<^sup>*))\<^sup>*"
   proof (induction rule: rtrancl_induct)
     case (step u t)
     obtain a b where ab:
         "(a,b) \<in> c" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u t"
       using step.hyps(2) timpl_closure'_step_inv by blast
     hence "(a,b) \<in> c\<^sup>*" by simp
     hence "(u,t) \<in> (timpl_closure'_step (c\<^sup>*))\<^sup>*" using ab(2)
     proof (induction arbitrary: t rule: rtrancl_induct)
       case (base t) thus ?case using term_variants_pred_refl_inv[of _ u t] by fastforce
     next
       case (step d e)
       obtain s where s:
           "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs d])) u s"
           "term_variants_pred ((\<lambda>_. [])(Abs d := [Abs e])) s t"
         using term_variants_pred_dense'[OF step.prems, of "Abs d"] by blast
 
       show ?case
       proof (cases "d = e")
         case True
         thus ?thesis
           using step.prems step.IH[of t]
           by blast
       next
         case False
         hence "(u,s) \<in> (timpl_closure'_step (c\<^sup>*))\<^sup>*"
               "(s,t) \<in> timpl_closure'_step (c\<^sup>*)"
           using step.hyps(2) s(2) step.IH[OF s(1)]
           by (auto intro: timpl_closure'_step.intros)
         thus ?thesis by simp
       qed
     qed
     thus ?case using step.IH by simp
   qed simp
 qed
 
 lemma timpl_closure'_timpls_rtrancl_eq:
   "timpl_closure' (c\<^sup>*) = timpl_closure' c"
 using timpl_closure'_timpls_rtrancl_subset timpl_closure'_timpls_rtrancl_supset
 by blast
 
 lemma timpl_closure_timpls_trancl_eq:
   "timpl_closure t (c\<^sup>+) = timpl_closure t c"
 using timpl_closure'_timpls_trancl_eq[of c]
       timpl_closure_is_timpl_closure'[of _ _ c]
       timpl_closure_is_timpl_closure'[of _ _ "c\<^sup>+"]
 by fastforce
 
 lemma timpl_closure_set_timpls_trancl_eq:
   "timpl_closure_set M (c\<^sup>+) = timpl_closure_set M c"
 using timpl_closure_timpls_trancl_eq
       timpl_closure_set_is_timpl_closure_union[of M c]
       timpl_closure_set_is_timpl_closure_union[of M "c\<^sup>+"]
 by fastforce
 
 lemma timpl_closure_set_timpls_trancl_eq':
   "timpl_closure_set M {(a,b) \<in> c\<^sup>+. a \<noteq> b} = timpl_closure_set M c"
 using timpl_closure'_timpls_trancl_eq'[of c]
       timpl_closure_is_timpl_closure'[of _ _ c]
       timpl_closure_is_timpl_closure'[of _ _ "{(a,b) \<in> c\<^sup>+. a \<noteq> b}"]
       timpl_closure_set_is_timpl_closure_union[of M c]
       timpl_closure_set_is_timpl_closure_union[of M "{(a,b) \<in> c\<^sup>+. a \<noteq> b}"]
 by fastforce
 
 lemma timpl_closure_Var_in_iff:
   "Var x \<in> timpl_closure t TI \<longleftrightarrow> t = Var x" (is "?A \<longleftrightarrow> ?B")
 proof
   have "s \<in> timpl_closure t TI \<Longrightarrow> s = Var x \<Longrightarrow> s = t" for s
     apply (induction rule: timpl_closure.induct)
     by (simp, metis term_variants_pred_inv_Var(2))
   thus "?A \<Longrightarrow> ?B" by blast
 qed (blast intro: timpl_closure.FP)
 
 lemma timpl_closure_set_Var_in_iff:
   "Var x \<in> timpl_closure_set M TI \<longleftrightarrow> Var x \<in> M"
 unfolding timpl_closure_set_def by (simp add: timpl_closure_Var_in_iff[of x _ TI]) 
 
 lemma timpl_closure_Var_inv:
   assumes "t \<in> timpl_closure (Var x) TI"
   shows "t = Var x"
 using assms
 proof (induction rule: timpl_closure.induct)
   case (TI u a b s) thus ?case using term_variants_pred_inv_Var by fast
 qed simp
 
 lemma timpls_Un_mono: "mono (\<lambda>X. FP \<union> (\<Union>x \<in> X. \<Union>(a,b) \<in> TI. set \<langle>a --\<guillemotright> b\<rangle>\<langle>x\<rangle>))"
 by (auto intro!: monoI)
 
 lemma timpl_closure_set_lfp:
   fixes M TI
   defines "f \<equiv> \<lambda>X. M \<union> (\<Union>x \<in> X. \<Union>(a,b) \<in> TI. set \<langle>a --\<guillemotright> b\<rangle>\<langle>x\<rangle>)"
   shows "lfp f = timpl_closure_set M TI"
 proof
   note 0 = timpls_Un_mono[of M TI, unfolded f_def[symmetric]]
 
   let ?N = "timpl_closure_set M TI"
 
   show "lfp f \<subseteq> ?N"
   proof (induction rule: lfp_induct)
     case 2 thus ?case
     proof
       fix t assume "t \<in> f (lfp f \<inter> ?N)"
       hence "t \<in> M \<or> t \<in> (\<Union>x \<in> ?N. \<Union>(a,b) \<in> TI. set \<langle>a --\<guillemotright> b\<rangle>\<langle>x\<rangle>)" (is "?A \<or> ?B")
         unfolding f_def by blast
       thus "t \<in> ?N"
       proof
         assume ?B
-        then obtain s a b where s: "s \<in> ?N" "(a,b) \<in> TI" "t \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>s\<rangle>" by moura
-        thus ?thesis 
+        then obtain s a b where s: "s \<in> ?N" "(a,b) \<in> TI" "t \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>s\<rangle>" by blast
+        thus ?thesis
           using term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs a := [Abs b])" s]
           unfolding timpl_closure_set_def timpl_apply_term_def
           by (auto intro: timpl_closure.intros)
       qed (auto simp add: timpl_closure_set_def intro: timpl_closure.intros)
     qed
   qed (rule 0)
 
   have "t \<in> lfp f" when t: "t \<in> timpl_closure s TI" and s: "s \<in> M" for t s
     using t
   proof (induction t rule: timpl_closure.induct)
     case (TI u a b v) thus ?case 
       using term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs a := [Abs b])"]
             lfp_fixpoint[OF 0]
       unfolding timpl_apply_term_def f_def by fastforce
   qed (use s lfp_fixpoint[OF 0] f_def in blast)
   thus "?N \<subseteq> lfp f" unfolding timpl_closure_set_def by blast
 qed
 
 lemma timpl_closure_set_supset:
   assumes "\<forall>t \<in> FP. t \<in> closure"
   and "\<forall>t \<in> closure. \<forall>(a,b) \<in> TI. \<forall>s \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle>. s \<in> closure"
   shows "timpl_closure_set FP TI \<subseteq> closure"
 proof -
   have "t \<in> closure" when t: "t \<in> timpl_closure s TI" and s: "s \<in> FP" for t s
     using t
   proof (induction rule: timpl_closure.induct)
     case FP thus ?case using s assms(1) by blast
   next
     case (TI u a b s') thus ?case
       using assms(2) term_variants_pred_iff_in_term_variants[of "(\<lambda>_. [])(Abs a := [Abs b])"]
       unfolding timpl_apply_term_def by fastforce
   qed
   thus ?thesis unfolding timpl_closure_set_def by blast
 qed
 
 lemma timpl_closure_set_supset':
   assumes "\<forall>t \<in> FP. \<forall>(a,b) \<in> TI. \<forall>s \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle>. s \<in> FP"
   shows "timpl_closure_set FP TI \<subseteq> FP"
 using timpl_closure_set_supset[OF _ assms] by blast
 
 lemma timpl_closure'_param:
   assumes "(t,s) \<in> timpl_closure' c"
     and fg: "f = g \<or> (\<exists>a b. (a,b) \<in> c \<and> f = Abs a \<and> g = Abs b)"
   shows "(Fun f (S@t#T), Fun g (S@s#T)) \<in> timpl_closure' c"
 using assms(1) unfolding timpl_closure'_def
 proof (induction rule: rtrancl_induct)
   case base thus ?case
   proof (cases "f = g")
     case False
     then obtain a b where ab: "(a,b) \<in> c" "f = Abs a" "g = Abs b"
-      using fg by moura
+      using fg by blast
     show ?thesis
       using term_variants_pred_param[OF term_variants_pred_refl[of "(\<lambda>_. [])(Abs a := [Abs b])" t]]
             timpl_closure'_step.intros[OF ab(1)] ab(2,3)
       by fastforce
   qed simp
 next
   case (step u s)
   obtain a b where ab: "(a,b) \<in> c" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u s"
     using timpl_closure'_step_inv[OF step.hyps(2)] by blast
   have "(Fun g (S@u#T), Fun g (S@s#T)) \<in> timpl_closure'_step c"
       using ab(1) term_variants_pred_param[OF ab(2), of g g S T]
       by (auto simp add: timpl_closure'_def intro: timpl_closure'_step.intros)
   thus ?case using rtrancl_into_rtrancl[OF step.IH] fg by blast
 qed
 
 lemma timpl_closure'_param':
   assumes "(t,s) \<in> timpl_closure' c"
   shows "(Fun f (S@t#T), Fun f (S@s#T)) \<in> timpl_closure' c"
 using timpl_closure'_param[OF assms] by simp
 
 lemma timpl_closure_FunI:
   assumes IH: "\<And>i. i < length T \<Longrightarrow> (T ! i, S ! i) \<in> timpl_closure' c"
     and len: "length T = length S"
     and fg: "f = g \<or> (\<exists>a b. (a,b) \<in> c\<^sup>+ \<and> f = Abs a \<and> g = Abs b)"
   shows "(Fun f T, Fun g S) \<in> timpl_closure' c"
 proof -
   have aux: "(Fun f T, Fun g (take n S@drop n T)) \<in> timpl_closure' c"
     when "n \<le> length T" for n
     using that
   proof (induction n)
     case 0
     have "(T ! n, T ! n) \<in> timpl_closure' c" when n: "n < length T" for n
       using n unfolding timpl_closure'_def by simp
     hence "(Fun f T, Fun g T) \<in> timpl_closure' c"
     proof (cases "f = g")
       case False
       then obtain a b where ab: "(a, b) \<in> c\<^sup>+" "f = Abs a" "g = Abs b"
-        using fg by moura
+        using fg by blast
       show ?thesis
         using timpl_closure'_step.intros[OF ab(1), of "Fun f T" "Fun g T"] ab(2,3)
               term_variants_P[OF _ term_variants_pred_refl[of "(\<lambda>_. [])(Abs a := [Abs b])"],
                               of T g f]
               timpl_closure'_timpls_trancl_eq
         unfolding timpl_closure'_def
         by (metis fun_upd_same list.set_intros(1) r_into_rtrancl)
     qed (simp add: timpl_closure'_def)
     thus ?case by simp
   next
     case (Suc n)
     hence IH': "(Fun f T, Fun g (take n S@drop n T)) \<in> timpl_closure' c"
       and n: "n < length T" "n < length S"
       by (simp_all add: len)
 
     obtain T1 T2 where T: "T = T1@T ! n#T2" "length T1 = n"
       using length_prefix_ex'[OF n(1)] by auto
 
     obtain S1 S2 where S: "S = S1@S ! n#S2" "length S1 = n"
       using length_prefix_ex'[OF n(2)] by auto
 
     have "take n S@drop n T = S1@T ! n#T2" "take (Suc n) S@drop (Suc n) T = S1@S ! n#T2"
       using n T S append_eq_conv_conj
       by (metis, metis (no_types, opaque_lifting) Cons_nth_drop_Suc append.assoc append_Cons
                                              append_Nil take_Suc_conv_app_nth) 
     moreover have "(T ! n, S ! n) \<in> timpl_closure' c" using IH Suc.prems by simp
     ultimately show ?case
       using timpl_closure'_param IH'(1)
       by (metis (no_types, lifting) timpl_closure'_def rtrancl_trans)
   qed
 
   show ?thesis using aux[of "length T"] len by simp
 qed
 
 lemma timpl_closure_FunI':
   assumes IH: "\<And>i. i < length T \<Longrightarrow> (T ! i, S ! i) \<in> timpl_closure' c"
     and len: "length T = length S"
   shows "(Fun f T, Fun f S) \<in> timpl_closure' c"
 using timpl_closure_FunI[OF IH len] by simp
 
 lemma timpl_closure_FunI2:
   fixes f g::"('a, 'b, 'c, 'd) prot_fun"
   assumes IH: "\<And>i. i < length T \<Longrightarrow> \<exists>u. (T!i, u) \<in> timpl_closure' c \<and> (S!i, u) \<in> timpl_closure' c"
     and len: "length T = length S"
     and fg: "f = g \<or> (\<exists>a b d. (a, d) \<in> c\<^sup>+ \<and> (b, d) \<in> c\<^sup>+ \<and> f = Abs a \<and> g = Abs b)"
   shows "\<exists>h U. (Fun f T, Fun h U) \<in> timpl_closure' c \<and> (Fun g S, Fun h U) \<in> timpl_closure' c"
 proof -
   let ?P = "\<lambda>i u. (T ! i, u) \<in> timpl_closure' c \<and> (S ! i, u) \<in> timpl_closure' c"
 
   define U where "U \<equiv> map (\<lambda>i. SOME u. ?P i u) [0..<length T]"
 
   have U1: "length U = length T"
     unfolding U_def by auto
 
   have U2: "(T ! i, U ! i) \<in> timpl_closure' c \<and> (S ! i, U ! i) \<in> timpl_closure' c"
     when i: "i < length U" for i
     using i someI_ex[of "?P i"] IH[of i] U1 len
     unfolding U_def by simp
 
   show ?thesis
   proof (cases "f = g")
     case False
     then obtain a b d where abd: "(a, d) \<in> c\<^sup>+" "(b, d) \<in> c\<^sup>+" "f = Abs a" "g = Abs b"
-      using fg by moura
+      using fg by blast
 
     define h::"('a, 'b, 'c, 'd) prot_fun" where "h = Abs d"
 
     have "f = h \<or> (\<exists>a b. (a, b) \<in> c\<^sup>+ \<and> f = Abs a \<and> h = Abs b)"
          "g = h \<or> (\<exists>a b. (a, b) \<in> c\<^sup>+ \<and> g = Abs a \<and> h = Abs b)"
       using abd unfolding h_def by blast+
     thus ?thesis by (metis timpl_closure_FunI len U1 U2)
   qed (metis timpl_closure_FunI' len U1 U2)
 qed
 
 lemma timpl_closure_FunI3:
   fixes f g::"('a, 'b, 'c, 'd) prot_fun"
   assumes IH: "\<And>i. i < length T \<Longrightarrow> \<exists>u. (T!i, u) \<in> timpl_closure' c \<and> (S!i, u) \<in> timpl_closure' c"
     and len: "length T = length S"
     and fg: "f = g \<or> (\<exists>a b d. (a, d) \<in> c \<and> (b, d) \<in> c \<and> f = Abs a \<and> g = Abs b)"
   shows "\<exists>h U. (Fun f T, Fun h U) \<in> timpl_closure' c \<and> (Fun g S, Fun h U) \<in> timpl_closure' c"
 using timpl_closure_FunI2[OF IH len] fg unfolding timpl_closure'_timpls_trancl_eq by blast
 
 lemma timpl_closure_fv_eq:
   assumes "s \<in> timpl_closure t T"
   shows "fv s = fv t"
 using assms
 by (induct rule: timpl_closure.induct)
    (metis, metis term_variants_pred_fv_eq)
 
 lemma (in stateful_protocol_model) timpl_closure_subst:
   assumes t: "wf\<^sub>t\<^sub>r\<^sub>m t" "\<forall>x \<in> fv t. \<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)"
     and \<delta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)"
   shows "timpl_closure (t \<cdot> \<delta>) T = timpl_closure t T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>"
 proof
   have "s \<in> timpl_closure t T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>"
     when "s \<in> timpl_closure (t \<cdot> \<delta>) T" for s
     using that
   proof (induction s rule: timpl_closure.induct)
     case FP thus ?case using timpl_closure.FP[of t T] by simp
   next
     case (TI u a b s)
-    then obtain u' where u': "u' \<in> timpl_closure t T" "u = u' \<cdot> \<delta>" by moura
+    then obtain u' where u': "u' \<in> timpl_closure t T" "u = u' \<cdot> \<delta>" by blast
     
     have u'_fv: "\<forall>x \<in> fv u'. \<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)"
       using timpl_closure_fv_eq[OF u'(1)] t(2) by simp
     hence u_fv: "\<forall>x \<in> fv u. \<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)"
       using u'(2) wt_subst_trm''[OF \<delta>(1)] wt_subst_const_fv_type_eq[OF _ \<delta>(1,2), of u']
       by fastforce
 
     have "\<forall>x \<in> fv u' \<union> fv s. (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> Abs a \<noteq> f)"
     proof (intro ballI)
       fix x assume x: "x \<in> fv u' \<union> fv s"
       then obtain c where c: "\<Gamma>\<^sub>v x = TAtom (Atom c)"
         using u'_fv u_fv term_variants_pred_fv_eq[OF TI.hyps(3)]
         by blast
 
       show "(\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> Abs a \<noteq> f)"
       proof (cases "\<delta> x")
         case (Fun f T)
         hence **: "\<Gamma> (Fun f T) = TAtom (Atom c)" and "wf\<^sub>t\<^sub>r\<^sub>m (Fun f T)"
           using c wt_subst_trm''[OF \<delta>(1), of "Var x"] \<delta>(2)
           by fastforce+
         hence "\<delta> x = Fun f []" using Fun const_type_inv_wf by metis
         thus ?thesis using ** by force
       qed metis
     qed
     hence *: "\<forall>x \<in> fv u' \<union> fv s.
                 (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> ((\<lambda>_. [])(Abs a := [Abs b])) f = [])"
       by fastforce
 
     obtain s' where s': "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) u' s'" "s = s' \<cdot> \<delta>"
       using term_variants_pred_subst'[OF _ *] u'(2) TI.hyps(3)
       by blast
 
     show ?case using timpl_closure.TI[OF u'(1) TI.hyps(2) s'(1)] s'(2) by blast
   qed
   thus "timpl_closure (t \<cdot> \<delta>) T \<subseteq> timpl_closure t T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>" by fast
 
   have "s \<in> timpl_closure (t \<cdot> \<delta>) T"
     when s: "s \<in> timpl_closure t T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>" for s
   proof -
-    obtain s' where s': "s' \<in> timpl_closure t T" "s = s' \<cdot> \<delta>" using s by moura
+    obtain s' where s': "s' \<in> timpl_closure t T" "s = s' \<cdot> \<delta>" using s by blast
     have "s' \<cdot> \<delta> \<in> timpl_closure (t \<cdot> \<delta>) T" using s'(1)
     proof (induction s' rule: timpl_closure.induct)
       case FP thus ?case using timpl_closure.FP[of "t \<cdot> \<delta>" T] by simp
     next
       case (TI u' a b s') show ?case
         using timpl_closure.TI[OF TI.IH TI.hyps(2)]
               term_variants_pred_subst[OF TI.hyps(3)]
         by blast
     qed
     thus ?thesis using s'(2) by metis
   qed
   thus "timpl_closure t T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta> \<subseteq> timpl_closure (t \<cdot> \<delta>) T" by fast
 qed
 
 lemma (in stateful_protocol_model) timpl_closure_subst_subset:
   assumes t: "t \<in> M"
     and M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M. \<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)"
     and \<delta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "ground (subst_range \<delta>)" "subst_domain \<delta> \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M"
     and M_supset: "timpl_closure t T \<subseteq> M"
   shows "timpl_closure (t \<cdot> \<delta>) T \<subseteq> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>"
 proof -
   have t': "wf\<^sub>t\<^sub>r\<^sub>m t" "\<forall>x \<in> fv t. \<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)" using t M by auto
   show ?thesis using timpl_closure_subst[OF t' \<delta>(1,2), of T] M_supset by blast
 qed
 
 lemma (in stateful_protocol_model) timpl_closure_set_subst_subset:
   assumes M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M" "\<forall>x \<in> fv\<^sub>s\<^sub>e\<^sub>t M. \<exists>a. \<Gamma>\<^sub>v x = TAtom (Atom a)"
     and \<delta>: "wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta>" "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>)" "ground (subst_range \<delta>)" "subst_domain \<delta> \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M"
     and M_supset: "timpl_closure_set M T \<subseteq> M"
   shows "timpl_closure_set (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>) T \<subseteq> M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>"
 using timpl_closure_subst_subset[OF _ M \<delta>, of _ T] M_supset
       timpl_closure_set_is_timpl_closure_union[of "M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>" T]
       timpl_closure_set_is_timpl_closure_union[of M T]
 by auto
 
 lemma timpl_closure_set_Union:
   "timpl_closure_set (\<Union>Ms) T = (\<Union>M \<in> Ms. timpl_closure_set M T)"
 using timpl_closure_set_is_timpl_closure_union[of "\<Union>Ms" T]
       timpl_closure_set_is_timpl_closure_union[of _ T]
 by force
 
 lemma timpl_closure_set_Union_subst_set:
   assumes "s \<in> timpl_closure_set (\<Union>{M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta> | \<delta>. P \<delta>}) T"
   shows "\<exists>\<delta>. P \<delta> \<and> s \<in> timpl_closure_set (M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>) T"
 using assms timpl_closure_set_is_timpl_closure_union[of "(\<Union>{M \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta> | \<delta>. P \<delta>})" T]
       timpl_closure_set_is_timpl_closure_union[of _ T]
 by blast
 
 lemma timpl_closure_set_Union_subst_singleton:
   assumes "s \<in> timpl_closure_set {t \<cdot> \<delta> | \<delta>. P \<delta>} T"
   shows "\<exists>\<delta>. P \<delta> \<and> s \<in> timpl_closure_set {t \<cdot> \<delta>} T"
 using assms timpl_closure_set_is_timpl_closure_union[of "{t \<cdot> \<delta> |\<delta>. P \<delta>}" T]
       timpl_closureton_is_timpl_closure[of _ T]
 by fast
 
 lemma timpl_closure'_inv:
   assumes "(s, t) \<in> timpl_closure' TI"
   shows "(\<exists>x. s = Var x \<and> t = Var x) \<or> (\<exists>f g S T. s = Fun f S \<and> t = Fun g T \<and> length S = length T)"
 using assms unfolding timpl_closure'_def
 proof (induction rule: rtrancl_induct)
   case base thus ?case by (cases s) auto
 next
   case (step t u)
   obtain a b where ab: "(a, b) \<in> TI" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) t u"
     using timpl_closure'_step_inv[OF step.hyps(2)] by blast
   show ?case using step.IH
   proof
     assume "\<exists>x. s = Var x \<and> t = Var x"
     thus ?case using step.hyps(2) term_variants_pred_inv_Var ab by fastforce
   next
     assume "\<exists>f g S T. s = Fun f S \<and> t = Fun g T \<and> length S = length T"
-    then obtain f g S T where st: "s = Fun f S" "t = Fun g T" "length S = length T" by moura
+    then obtain f g S T where st: "s = Fun f S" "t = Fun g T" "length S = length T" by blast
     thus ?case
       using ab step.hyps(2) term_variants_pred_inv'[of "(\<lambda>_. [])(Abs a := [Abs b])" g T u]
       by auto
   qed
 qed
 
 lemma timpl_closure'_inv':
   assumes "(s, t) \<in> timpl_closure' TI"
   shows "(\<exists>x. s = Var x \<and> t = Var x) \<or>
          (\<exists>f g S T. s = Fun f S \<and> t = Fun g T \<and> length S = length T \<and>
                     (\<forall>i < length T. (S ! i, T ! i) \<in> timpl_closure' TI) \<and>
                     (f \<noteq> g \<longrightarrow> is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> TI\<^sup>+))"
     (is "?A s t \<or> ?B s t (timpl_closure' TI)")
 using assms unfolding timpl_closure'_def
 proof (induction rule: rtrancl_induct)
   case base thus ?case by (cases s) auto
 next
   case (step t u)
   obtain a b where ab: "(a, b) \<in> TI" "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) t u"
     using timpl_closure'_step_inv[OF step.hyps(2)] by blast
   show ?case using step.IH
   proof
     assume "?A s t"
     thus ?case using step.hyps(2) term_variants_pred_inv_Var ab by fastforce
   next
     assume "?B s t ((timpl_closure'_step TI)\<^sup>*)"
     then obtain f g S T where st:
         "s = Fun f S" "t = Fun g T" "length S = length T"
         "\<And>i. i < length T \<Longrightarrow> (S ! i, T ! i) \<in> (timpl_closure'_step TI)\<^sup>*"
         "f \<noteq> g \<Longrightarrow> is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> TI\<^sup>+"
-      by moura
+      by blast
     obtain h U where u:
         "u = Fun h U" "length T = length U"
         "\<And>i. i < length T \<Longrightarrow> term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) (T ! i) (U ! i)"
         "g \<noteq> h \<Longrightarrow> is_Abs g \<and> is_Abs h \<and> (the_Abs g, the_Abs h) \<in> TI\<^sup>+"
       using ab(2) st(2) r_into_trancl[OF ab(1)]
             term_variants_pred_inv'(1,2,3,4)[of "(\<lambda>_. [])(Abs a := [Abs b])" g T u]
             term_variants_pred_inv'(5)[of "(\<lambda>_. [])(Abs a := [Abs b])" g T u "Abs a" "Abs b"]
       unfolding is_Abs_def the_Abs_def by force
 
     have "(S ! i, U ! i) \<in> (timpl_closure'_step TI)\<^sup>*" when i: "i < length U" for i
       using u(2) i rtrancl.rtrancl_into_rtrancl[OF
               st(4)[of i] timpl_closure'_step.intros[OF ab(1) u(3)[of i]]]
       by argo
     moreover have "length S = length U" using st u by argo
     moreover have "is_Abs f \<and> is_Abs h \<and> (the_Abs f, the_Abs h) \<in> TI\<^sup>+" when fh: "f \<noteq> h"
       using fh st u by fastforce
     ultimately show ?case using st(1) u(1) by blast
   qed
 qed
 
 lemma timpl_closure'_inv'':
   assumes "(Fun f S, Fun g T) \<in> timpl_closure' TI"
   shows "length S = length T"
     and "\<And>i. i < length T \<Longrightarrow> (S ! i, T ! i) \<in> timpl_closure' TI"
     and "f \<noteq> g \<Longrightarrow> is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> TI\<^sup>+"
 using assms timpl_closure'_inv' by auto
 
 lemma timpl_closure_Fun_inv:
   assumes "s \<in> timpl_closure (Fun f T) TI"
   shows "\<exists>g S. s = Fun g S"
 using assms timpl_closure_is_timpl_closure' timpl_closure'_inv
 by fastforce
 
 lemma timpl_closure_Fun_inv':
   assumes "Fun g S \<in> timpl_closure (Fun f T) TI"
   shows "length S = length T"
     and "\<And>i. i < length S \<Longrightarrow> S ! i \<in> timpl_closure (T ! i) TI"
     and "f \<noteq> g \<Longrightarrow> is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> TI\<^sup>+"
 using assms timpl_closure_is_timpl_closure'
 by (metis timpl_closure'_inv''(1), metis timpl_closure'_inv''(2), metis timpl_closure'_inv''(3))
 
 lemma timpl_closure_Fun_not_Var[simp]:
   "Fun f T \<notin> timpl_closure (Var x) TI"
 using timpl_closure_Var_inv by fast
 
 lemma timpl_closure_Var_not_Fun[simp]:
   "Var x \<notin> timpl_closure (Fun f T) TI"
 using timpl_closure_Fun_inv by fast
 
 lemma (in stateful_protocol_model) timpl_closure_wf_trms:
   assumes m: "wf\<^sub>t\<^sub>r\<^sub>m m"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (timpl_closure m TI)"
 proof
   fix t assume "t \<in> timpl_closure m TI"
   thus "wf\<^sub>t\<^sub>r\<^sub>m t"
   proof (induction t rule: timpl_closure.induct)
     case TI thus ?case using term_variants_pred_wf_trms by force
   qed (rule m)
 qed
 
 lemma (in stateful_protocol_model) timpl_closure_set_wf_trms:
   assumes M: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M"
   shows "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (timpl_closure_set M TI)"
 proof
   fix t assume "t \<in> timpl_closure_set M TI"
   then obtain m where "t \<in> timpl_closure m TI" "m \<in> M" "wf\<^sub>t\<^sub>r\<^sub>m m"
     using M timpl_closure_set_is_timpl_closure_union by blast
   thus "wf\<^sub>t\<^sub>r\<^sub>m t" using timpl_closure_wf_trms by blast
 qed
 
 lemma timpl_closure_Fu_inv:
   assumes "t \<in> timpl_closure (Fun (Fu f) T) TI"
   shows "\<exists>S. length S = length T \<and> t = Fun (Fu f) S"
 using assms
 proof (induction t rule: timpl_closure.induct)
   case (TI u a b s)
   then obtain U where U: "length U = length T" "u = Fun (Fu f) U"
-    by moura
+    by blast
   hence *: "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) (Fun (Fu f) U) s"
     using TI.hyps(3) by meson
 
   show ?case
     using term_variants_pred_inv'(1,2,4)[OF *] U
     by force
 qed simp
 
 lemma timpl_closure_Fu_inv':
   assumes "Fun (Fu f) T \<in> timpl_closure t TI"
   shows "\<exists>S. length S = length T \<and> t = Fun (Fu f) S"
 using assms
 proof (induction "Fun (Fu f) T" arbitrary: T rule: timpl_closure.induct)
   case (TI u a b)
   obtain g U where U:
       "u = Fun g U" "length U = length T"
       "Fu f \<noteq> g \<Longrightarrow> Abs a = g \<and> Fu f = Abs b"
     using term_variants_pred_inv''[OF TI.hyps(4)] by fastforce
 
   have g: "g = Fu f" using U(3) by blast
   
   show ?case using TI.hyps(2)[OF U(1)[unfolded g]] U(2) by auto
 qed simp
 
 lemma timpl_closure_no_Abs_eq:
   assumes "t \<in> timpl_closure s TI"
     and "\<forall>f \<in> funs_term t. \<not>is_Abs f"
   shows "t = s"
 using assms
 proof (induction t rule: timpl_closure.induct)
   case (TI t a b s) thus ?case
     using term_variants_pred_eq_case_Abs[of a b t s]
     unfolding timpl_apply_term_def term_variants_pred_iff_in_term_variants[symmetric]
     by metis
 qed simp
 
 lemma timpl_closure_set_no_Abs_in_set:
   assumes "t \<in> timpl_closure_set FP TI"
     and "\<forall>f \<in> funs_term t. \<not>is_Abs f"
   shows "t \<in> FP"
 using assms timpl_closure_no_Abs_eq unfolding timpl_closure_set_def by blast
 
 lemma timpl_closure_funs_term_subset:
   "\<Union>(funs_term ` (timpl_closure t TI)) \<subseteq> funs_term t \<union> Abs ` snd ` TI"
   (is "?A \<subseteq> ?B \<union> ?C")
 proof
   fix f assume "f \<in> ?A"
-  then obtain s where "s \<in> timpl_closure t TI" "f \<in> funs_term s" by moura
+  then obtain s where "s \<in> timpl_closure t TI" "f \<in> funs_term s" by blast
   thus "f \<in> ?B \<union> ?C"
   proof (induction s rule: timpl_closure.induct)
     case (TI u a b s)
     have "Abs b \<in> Abs ` snd ` TI" using TI.hyps(2) by force
     thus ?case using term_variants_pred_funs_term[OF TI.hyps(3) TI.prems] TI.IH by force
   qed blast
 qed
 
 lemma timpl_closure_set_funs_term_subset:
   "\<Union>(funs_term ` (timpl_closure_set FP TI)) \<subseteq> \<Union>(funs_term ` FP) \<union> Abs ` snd ` TI"
 using timpl_closure_funs_term_subset[of _ TI]
       timpl_closure_set_is_timpl_closure_union[of FP TI]
 by auto
 
 lemma funs_term_OCC_TI_subset:
   defines "absc \<equiv> \<lambda>a. Fun (Abs a) []"
   assumes OCC1: "\<forall>t \<in> FP. \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` OCC"
     and OCC2: "snd ` TI \<subseteq> OCC"
   shows "\<forall>t \<in> timpl_closure_set FP TI. \<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> f \<in> Abs ` OCC" (is ?A)
     and "\<forall>t \<in> absc ` OCC. \<forall>(a,b) \<in> TI. \<forall>s \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle>. s \<in> absc ` OCC" (is ?B)
 proof -
   let ?F = "\<Union>(funs_term ` FP)"
   let ?G = "Abs ` snd ` TI"
 
   show ?A
   proof (intro ballI impI)
     fix t f assume t: "t \<in> timpl_closure_set FP TI" and f: "f \<in> funs_term t" "is_Abs f"
     hence "f \<in> ?F \<or> f \<in> ?G" using timpl_closure_set_funs_term_subset[of FP TI] by auto
     thus "f \<in> Abs ` OCC"
     proof
       assume "f \<in> ?F" thus ?thesis using OCC1 f(2) by fast
     next
       assume "f \<in> ?G" thus ?thesis using OCC2 by auto
     qed
   qed
 
   { fix s t a b
     assume t: "t \<in> absc ` OCC"
       and ab: "(a, b) \<in> TI"
       and s: "s \<in> set \<langle>a --\<guillemotright> b\<rangle>\<langle>t\<rangle>"
-    obtain c where c: "t = absc c" "c \<in> OCC" using t by moura
+    obtain c where c: "t = absc c" "c \<in> OCC" using t by blast
     hence "s = absc b \<or> s = absc c"
       using ab s timpl_apply_const'[of c a b] unfolding absc_def by auto
     moreover have "b \<in> OCC" using ab OCC2 by auto
     ultimately have "s \<in> absc ` OCC" using c(2) by blast
   } thus ?B by blast
 qed
 
 lemma (in stateful_protocol_model) intruder_synth_timpl_closure_set:
   fixes M::"('fun,'atom,'sets,'lbl) prot_terms" and t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "M \<turnstile>\<^sub>c t"
     and "s \<in> timpl_closure t TI"
   shows "timpl_closure_set M TI \<turnstile>\<^sub>c s"
 using assms
 proof (induction t arbitrary: s rule: intruder_synth_induct)
   case (AxiomC t)
   hence "s \<in> timpl_closure_set M TI"
     using timpl_closure_set_is_timpl_closure_union[of M TI]
     by blast
   thus ?case by simp
 next
   case (ComposeC T f)
   obtain g S where s: "s = Fun g S"
-    using timpl_closure_Fun_inv[OF ComposeC.prems] by moura
+    using timpl_closure_Fun_inv[OF ComposeC.prems] by blast
   hence s':
       "f = g" "length S = length T"
       "\<And>i. i < length S \<Longrightarrow> S ! i \<in> timpl_closure (T ! i) TI"
     using timpl_closure_Fun_inv'[of g S f T TI] ComposeC.prems ComposeC.hyps(2)
     unfolding is_Abs_def by fastforce+
   
   have "timpl_closure_set M TI \<turnstile>\<^sub>c u" when u: "u \<in> set S" for u
     using ComposeC.IH u s'(2,3) in_set_conv_nth[of _ T] in_set_conv_nth[of u S] by auto
   thus ?case
     using s s'(1,2) ComposeC.hyps(1,2) intruder_synth.ComposeC[of S g "timpl_closure_set M TI"]
     by argo
 qed
 
 lemma (in stateful_protocol_model) intruder_synth_timpl_closure':
   fixes M::"('fun,'atom,'sets,'lbl) prot_terms" and t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "timpl_closure_set M TI \<turnstile>\<^sub>c t"
     and "s \<in> timpl_closure t TI"
   shows "timpl_closure_set M TI \<turnstile>\<^sub>c s"
 by (metis intruder_synth_timpl_closure_set[OF assms] timpl_closure_set_idem)
 
 lemma timpl_closure_set_absc_subset_in:
   defines "absc \<equiv> \<lambda>a. Fun (Abs a) []"
   assumes A: "timpl_closure_set (absc ` A) TI \<subseteq> absc ` A"
     and a: "a \<in> A" "(a,b) \<in> TI\<^sup>+"
   shows "b \<in> A"
 proof -
   have "timpl_closure (absc a) (TI\<^sup>+) \<subseteq> absc ` A"
     using a(1) A timpl_closure_timpls_trancl_eq
     unfolding timpl_closure_set_def by fast
   thus ?thesis
     using timpl_closure.TI[OF timpl_closure.FP[of "absc a"] a(2), of "absc b"]
           term_variants_P[of "[]" "[]" "(\<lambda>_. [])(Abs a := [Abs b])" "Abs b" "Abs a"]
     unfolding absc_def by auto
 qed
 
 lemma timpl_closure_Abs_ex:
   assumes t: "s \<in> timpl_closure t TI"
     and a: "Abs a \<in> funs_term t"
   shows "\<exists>b ts. (a,b) \<in> TI\<^sup>* \<and> Fun (Abs b) ts \<sqsubseteq> s"
 using t
 proof (induction rule: timpl_closure.induct)
   case (TI u b c s)
   obtain d ts where d: "(a,d) \<in> TI\<^sup>*" "Fun (Abs d) ts \<sqsubseteq> u" using TI.IH by blast
   note 0 = TI.hyps(2) d(1) term_variants_pred_inv'(5)[OF term_variants_pred_const]
   show ?case using TI.hyps(3) d(2)
   proof (induction rule: term_variants_pred.induct)
     case (term_variants_P T S g f)
     note hyps = term_variants_P.hyps
     note prems = term_variants_P.prems
     note IH = term_variants_P.IH
     show ?case
     proof (cases "Fun (Abs d) ts = Fun f T")
       case False
       hence "\<exists>t \<in> set T. Fun (Abs d) ts \<sqsubseteq> t" using prems(1) by force
       then obtain i where i: "i < length T" "Fun (Abs d) ts \<sqsubseteq> T ! i" by (metis in_set_conv_nth)
       show ?thesis by (metis IH[OF i] i(1) hyps(1) nth_mem subtermeqI'' term.order.trans)
     qed (metis hyps(3) 0 prot_fun.sel(4) r_into_rtrancl rtrancl_trans term.eq_refl term.sel(2))
   next
     case (term_variants_Fun T S f)
     note hyps = term_variants_Fun.hyps
     note prems = term_variants_Fun.prems
     note IH = term_variants_Fun.IH
     show ?case
     proof (cases "Fun (Abs d) ts = Fun f T")
       case False
       hence "\<exists>t \<in> set T. Fun (Abs d) ts \<sqsubseteq> t" using prems(1) by force
       then obtain i where i: "i < length T" "Fun (Abs d) ts \<sqsubseteq> T ! i" by (metis in_set_conv_nth)
       show ?thesis by (metis IH[OF i] i(1) hyps(1) nth_mem subtermeqI'' term.order.trans)
     qed (metis 0(2) term.eq_refl term.sel(2))
   qed simp
 qed (meson a funs_term_Fun_subterm rtrancl_eq_or_trancl)
 
 lemma timpl_closure_trans:
   assumes "s \<in> timpl_closure t TI"
     and "u \<in> timpl_closure s TI"
   shows "u \<in> timpl_closure t TI"
 using assms unfolding timpl_closure_is_timpl_closure' timpl_closure'_def by simp
 
 lemma (in stateful_protocol_model) term_variants_pred_Ana\<^sub>f_keys:
   assumes
     "length ss = length ts"
     "\<forall>x \<in> fv k. x < length ss"
     "\<And>i. i < length ss \<Longrightarrow> term_variants_pred P (ss ! i) (ts ! i)"
   shows "term_variants_pred P (k \<cdot> (!) ss) (k \<cdot> (!) ts)"
 using assms by (meson term_variants_pred_subst'')
 
 lemma (in stateful_protocol_model) term_variants_pred_Ana_keys:
   fixes a b and s t::"('fun,'atom,'sets,'lbl) prot_term"
   defines "P \<equiv> ((\<lambda>_. [])(Abs a := [Abs b]))"
   assumes ab: "term_variants_pred P s t"
     and s: "Ana s = (Ks, Rs)"
     and t: "Ana t = (Kt, Rt)"
   shows "length Kt = length Ks" (is ?A)
     and "\<forall>i < length Ks. term_variants_pred P (Ks ! i) (Kt ! i)" (is ?B)
 proof -
   have ?A ?B when "s = Var x" for x
     using that ab s t iffD1[OF term_variants_pred_inv_Var(1) ab[unfolded that]] by auto
   moreover have ?A ?B when s': "s = Fun f ss" for f ss
   proof -
     obtain g ts where t':
         "t = Fun g ts" "length ss = length ts"
         "\<And>i. i < length ss \<Longrightarrow> term_variants_pred P (ss ! i) (ts ! i)"
         "f \<noteq> g \<Longrightarrow> f = Abs a \<and> g = Abs b"
       using term_variants_pred_inv'[OF ab[unfolded s']]
       unfolding P_def by fastforce
     have ?A ?B when "f \<noteq> g" using that s s' t t'(1,2,4) by auto
     moreover have A: ?A when fg: "f = g"
       using s t Ana_Fu_keys_length_eq[OF t'(2)] Ana_nonempty_inv[of s] Ana_nonempty_inv[of t]
       unfolding fg s' t'(1) by (metis (no_types) fst_conv term.inject(2))
     moreover have ?B when fg: "f = g"
     proof (cases "Ana s = ([],[])")
       case True thus ?thesis using s t t'(2,3) A[OF fg] unfolding fg s' t'(1) by auto
     next
       case False
       then obtain h Kh Rh where h:
           "f = Fu h" "g = Fu h" "arity\<^sub>f h = length ss" "arity\<^sub>f h > 0" "Ana\<^sub>f h = (Kh, Rh)"
           "Ana s = (Kh \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) ss, map ((!) ss) Rh)" "Ana t = (Kh \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) ts, map ((!) ts) Rh)"
         using A[OF fg] s t t'(2,3) Ana_nonempty_inv[of s] Ana_nonempty_inv[of t]
         unfolding fg s' t'(1) by fastforce
       show ?thesis
       proof (intro allI impI)
         fix i assume i: "i < length Ks"
         have Ks: "Ks = Kh \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) ss" and Kt: "Kt = Kh \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) ts"
           using h(6,7) s t by auto
 
         have 0: "Kh ! i \<in> set Kh" using Ks i by simp
 
         have 1: "\<forall>x \<in> fv (Kh ! i). x < length ss"
           using 0 Ana\<^sub>f_assm2_alt[OF h(5)]
           unfolding h(1-3) by fastforce
 
         have "term_variants_pred P (Kh ! i \<cdot> (!) ss) (Kh ! i \<cdot> (!) ts)"
           using term_variants_pred_Ana\<^sub>f_keys[OF t'(2) 1 t'(3)]
           unfolding P_def by fast
         thus "term_variants_pred P (Ks ! i) (Kt ! i)"
           using i unfolding Ks Kt by simp
       qed
     qed
     ultimately show ?A ?B by fast+
   qed
   ultimately show ?A ?B by (cases s; simp_all)+
 qed
 
 lemma (in stateful_protocol_model) timpl_closure_Ana_keys:
   fixes s t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "t \<in> timpl_closure s TI"
     and "Ana s = (Ks, Rs)"
     and "Ana t = (Kt, Rt)"
   shows "length Kt = length Ks" (is ?A)
     and "\<forall>i < length Ks. Kt ! i \<in> timpl_closure (Ks ! i) TI" (is ?B)
 using assms
 proof (induction arbitrary: Ks Rs Kt Rt rule: timpl_closure.induct)
   case FP
   { case 1 thus ?case by simp }
   { case 2 thus ?case using FP timpl_closure.FP by force }
 next
   case (TI u a b t)
   obtain Ku Ru where u: "Ana u = (Ku, Ru)" by (metis surj_pair)
   note 0 = term_variants_pred_Ana_keys[OF TI.hyps(3) u]
   { case 1 thus ?case using 0(1) TI.IH(1) u by fastforce }
   { case 2 thus ?case by (metis 0(2)[OF 2(2)] TI.IH[OF 2(1) u] timpl_closure.TI[OF _ TI.hyps(2)]) }
 qed
 
 lemma (in stateful_protocol_model) timpl_closure_Ana_keys_length_eq:
   fixes s t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "t \<in> timpl_closure s TI"
     and "Ana s = (Ks, Rs)"
     and "Ana t = (Kt, Rt)"
   shows "length Kt = length Ks"
 by (rule timpl_closure_Ana_keys(1,2)[OF assms])
 
 lemma (in stateful_protocol_model) timpl_closure_Ana_keys_subset:
   fixes s t::"('fun,'atom,'sets,'lbl) prot_term"
   assumes "t \<in> timpl_closure s TI"
     and "Ana s = (Ks, Rs)"
     and "Ana t = (Kt, Rt)"
   shows "set Kt \<subseteq> timpl_closure_set (set Ks) TI"
 proof -
   note 0 = timpl_closure_Ana_keys[OF assms]
   have "\<forall>i < length Ks. Kt ! i \<in> timpl_closure_set (set Ks) TI"
     using in_set_conv_nth 0(2) unfolding timpl_closure_set_def by auto
   thus "set Kt \<subseteq> timpl_closure_set (set Ks) TI"
     using 0(1) by (metis subsetI in_set_conv_nth)
 qed
 
 
 subsection \<open>Composition-only Intruder Deduction Modulo Term Implication Closure of the Intruder Knowledge\<close>
 context stateful_protocol_model
 begin
 
 fun in_trancl where
   "in_trancl TI a b = (
     if (a,b) \<in> set TI then True
     else list_ex (\<lambda>(c,d). c = a \<and> in_trancl (removeAll (c,d) TI) d b) TI)"
 
 definition in_rtrancl where
   "in_rtrancl TI a b \<equiv> a = b \<or> in_trancl TI a b"
 
 declare in_trancl.simps[simp del]
 
 fun timpls_transformable_to where
   "timpls_transformable_to TI (Var x) (Var y) = (x = y)"
 | "timpls_transformable_to TI (Fun f T) (Fun g S) = (
     (f = g \<or> (is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> set TI)) \<and>
     list_all2 (timpls_transformable_to TI) T S)"
 | "timpls_transformable_to _ _ _ = False"
 
 fun timpls_transformable_to' where
   "timpls_transformable_to' TI (Var x) (Var y) = (x = y)"
 | "timpls_transformable_to' TI (Fun f T) (Fun g S) = (
     (f = g \<or> (is_Abs f \<and> is_Abs g \<and> in_trancl TI (the_Abs f) (the_Abs g))) \<and>
     list_all2 (timpls_transformable_to' TI) T S)"
 | "timpls_transformable_to' _ _ _ = False"
 
 fun equal_mod_timpls where
   "equal_mod_timpls TI (Var x) (Var y) = (x = y)"
 | "equal_mod_timpls TI (Fun f T) (Fun g S) = (
     (f = g \<or> (is_Abs f \<and> is_Abs g \<and>
                 ((the_Abs f, the_Abs g) \<in> set TI \<or>
                  (the_Abs g, the_Abs f) \<in> set TI \<or>
                  (\<exists>ti \<in> set TI. (the_Abs f, snd ti) \<in> set TI \<and> (the_Abs g, snd ti) \<in> set TI)))) \<and>
     list_all2 (equal_mod_timpls TI) T S)"
 | "equal_mod_timpls _ _ _ = False"
 
 fun intruder_synth_mod_timpls where
   "intruder_synth_mod_timpls M TI (Var x) = List.member M (Var x)"
 | "intruder_synth_mod_timpls M TI (Fun f T) = (
     (list_ex (\<lambda>t. timpls_transformable_to TI t (Fun f T)) M) \<or>
     (public f \<and> length T = arity f \<and> list_all (intruder_synth_mod_timpls M TI) T))"
 
 fun intruder_synth_mod_timpls' where
   "intruder_synth_mod_timpls' M TI (Var x) = List.member M (Var x)"
 | "intruder_synth_mod_timpls' M TI (Fun f T) = (
     (list_ex (\<lambda>t. timpls_transformable_to' TI t (Fun f T)) M) \<or>
     (public f \<and> length T = arity f \<and> list_all (intruder_synth_mod_timpls' M TI) T))"
 
 fun intruder_synth_mod_eq_timpls where
   "intruder_synth_mod_eq_timpls M TI (Var x) = (Var x \<in> M)"
 | "intruder_synth_mod_eq_timpls M TI (Fun f T) = (
     (\<exists>t \<in> M. equal_mod_timpls TI t (Fun f T)) \<or>
     (public f \<and> length T = arity f \<and> list_all (intruder_synth_mod_eq_timpls M TI) T))"
 
 definition analyzed_closed_mod_timpls where
   "analyzed_closed_mod_timpls M TI \<equiv>
     let ti = intruder_synth_mod_timpls M TI;
         cl = \<lambda>ts. comp_timpl_closure ts (set TI);
         f = list_all ti;
         g = \<lambda>t. if f (fst (Ana t)) then f (snd (Ana t))
                 else if list_all (\<lambda>t. \<forall>f \<in> funs_term t. \<not>is_Abs f) (fst (Ana t)) then True
                 else if \<forall>s \<in> cl (set (fst (Ana t))). \<not>ti s then True
                 else \<forall>s \<in> cl {t}. case Ana s of (K,R) \<Rightarrow> f K \<longrightarrow> f R
     in list_all g M"
 
 definition analyzed_closed_mod_timpls' where
   "analyzed_closed_mod_timpls' M TI \<equiv>
     let f = list_all (intruder_synth_mod_timpls' M TI);
         g = \<lambda>t. if f (fst (Ana t)) then f (snd (Ana t))
                 else if list_all (\<lambda>t. \<forall>f \<in> funs_term t. \<not>is_Abs f) (fst (Ana t)) then True
                 else \<forall>s \<in> comp_timpl_closure {t} (set TI). case Ana s of (K,R) \<Rightarrow> f K \<longrightarrow> f R
     in list_all g M"
 
 lemma term_variants_pred_Abs_Ana_keys:
   fixes a b
   defines "P \<equiv> ((\<lambda>_. [])(Abs a := [Abs b]))"
   assumes st: "term_variants_pred P s t"
   shows "length (fst (Ana s)) = length (fst (Ana t))" (is "?P s t")
     and "\<forall>i < length (fst (Ana s)). term_variants_pred P (fst (Ana s) ! i) (fst (Ana t) ! i)"
           (is "?Q s t")
 proof -
   show "?P s t" using st
   proof (induction s t rule: term_variants_pred.induct)
     case (term_variants_Fun T S f) show ?case
     proof (cases f)
       case (Fu g) thus ?thesis using term_variants_Fun Ana_Fu_keys_length_eq by blast
     qed simp_all
   qed (simp_all add: P_def)
 
   show "?Q s t" using st
   proof (induction s t rule: term_variants_pred.induct)
     case (term_variants_Fun T S f)
     note hyps = term_variants_Fun.hyps
     let ?K = "\<lambda>U. fst (Ana (Fun f U))"
 
     show ?case
     proof (cases f)
       case (Fu g) show ?thesis
       proof (cases "arity\<^sub>f g = length T \<and> arity\<^sub>f g > 0")
         case True
         hence *: "?K T = fst (Ana\<^sub>f g) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T"
                  "?K S = fst (Ana\<^sub>f g) \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) S"
           using Fu Ana_Fu_intro fst_conv prod.collapse
           by (metis (mono_tags, lifting), metis (mono_tags, lifting) hyps(1))
 
         have K: "j < length T" when j: "j \<in> fv\<^sub>s\<^sub>e\<^sub>t (set (fst (Ana\<^sub>f g)))" for j
           using True Ana\<^sub>f_assm2_alt[of g "fst (Ana\<^sub>f g)" _ j ]
           by (metis UnI1 prod.collapse that) 
 
         show ?thesis
         proof (intro allI impI)
           fix i assume i: "i < length (?K T)"
           let ?u = "fst (Ana\<^sub>f g) ! i"
 
           have **: "?K T ! i = ?u \<cdot> (!) T" "?K S ! i = ?u \<cdot> (!) S"
             using * i by simp_all
 
           have ***: "x < length T" when "x \<in> fv (fst (Ana\<^sub>f g) ! i)" for x
             using that K Ana\<^sub>f_assm2_alt[of g "fst (Ana\<^sub>f g)" _ x] i hyps(1)
             unfolding * by force
 
           show "term_variants_pred P (?K T ! i) (?K S ! i)"
             using i hyps K *** term_variants_pred_subst''[of ?u P "(!) T" "(!) S"]
             unfolding * by auto
         qed
       qed (auto simp add: Fu)
     qed simp_all
   qed (simp_all add: P_def)
 qed
 
 lemma term_variants_pred_Abs_eq_case:
   assumes t: "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) s t" (is "?R s t")
     and s: "\<forall>f \<in> funs_term s. \<not>is_Abs f" (is "?P s")
   shows "s = t"
 using s term_variants_pred_eq_case[OF t] by fastforce
 
 lemma term_variants_Ana_keys_no_Abs_eq_case:
   fixes s t::"(('fun,'atom,'sets,'lbl) prot_fun,'v) term"
   assumes t: "term_variants_pred ((\<lambda>_. [])(Abs a := [Abs b])) s t" (is "?R s t")
     and s: "\<forall>t \<in> set (fst (Ana s)). \<forall>f \<in> funs_term t. \<not>is_Abs f" (is "?P s")
   shows "fst (Ana t) = fst (Ana s)" (is "?Q t s")
 using s term_variants_pred_Abs_Ana_keys[OF t] term_variants_pred_Abs_eq_case[of a b]
 by (metis nth_equalityI nth_mem)
 
 lemma timpl_closure_Ana_keys_no_Abs_eq_case:
   assumes t: "t \<in> timpl_closure s TI"
     and s: "\<forall>t \<in> set (fst (Ana s)). \<forall>f \<in> funs_term t. \<not>is_Abs f" (is "?P s")
   shows "fst (Ana t) = fst (Ana s)"
 using t
 proof (induction t rule: timpl_closure.induct)
   case (TI u a b t)
   thus ?case using s term_variants_Ana_keys_no_Abs_eq_case by fastforce
 qed simp
 
 lemma in_trancl_closure_iff_in_trancl_fun:
   "(a,b) \<in> (set TI)\<^sup>+ \<longleftrightarrow> in_trancl TI a b" (is "?A TI a b \<longleftrightarrow> ?B TI a b")
 proof
   show "?A TI a b \<Longrightarrow> ?B TI a b"
   proof (induction rule: trancl_induct)
     case (step c d)
     show ?case using step.IH step.hyps(2)
     proof (induction TI a c rule: in_trancl.induct)
       case (1 TI a b)
       have "(a,b) \<in> set TI \<or> (\<exists>e. (a,e) \<in> set TI \<and> in_trancl (removeAll (a,e) TI) e b)"
         using "1.prems"(1) in_trancl.simps[of TI a b]
         unfolding list_ex_iff by (cases "(a,b) \<in> set TI") auto
       show ?case
       proof (cases "(a,b) \<in> set TI")
         case True thus ?thesis
           by (metis (mono_tags, lifting) in_trancl.simps "1.prems"(2) list_ex_iff case_prodI
                 member_remove prod.inject remove_code(1))
       next
         case F: False
         then obtain e where e: "(a,e) \<in> set TI" "in_trancl (removeAll (a,e) TI) e b"
           using "1.prems"(1) in_trancl.simps[of TI a b]
           unfolding list_ex_iff by (cases "(a,b) \<in> set TI") auto
         show ?thesis
         proof (cases "(b, d) \<in> set (removeAll (a, e) TI)")
           case True thus ?thesis
             using in_trancl.simps[of TI a d] e(1) "1.prems"(2) "1.IH"[OF F e(1) _ e(2)]
             unfolding list_ex_iff by auto
         next
           case False thus ?thesis using in_trancl.simps[of TI a d] "1.prems"(2) by simp
         qed
       qed
     qed
   qed (metis in_trancl.simps)
 
   show "?B TI a b \<Longrightarrow> ?A TI a b"
   proof (induction TI a b rule: in_trancl.induct)
     case (1 TI a b)
     let ?P = "\<lambda>TI a b c d. in_trancl (List.removeAll (c,d) TI) d b"
     have *: "\<exists>(c,d) \<in> set TI. c = a \<and> ?P TI a b c d" when "(a,b) \<notin> set TI"
       using that "1.prems" list_ex_iff[of _ TI] in_trancl.simps[of TI a b]
       by auto
     show ?case
     proof (cases "(a,b) \<in> set TI")
       case False
       hence "\<exists>(c,d) \<in> set TI. c = a \<and> ?P TI a b c d" using * by blast
       then obtain d where d: "(a,d) \<in> set TI" "?P TI a b a d" by blast
       have "(d,b) \<in> (set (removeAll (a,d) TI))\<^sup>+" using "1.IH"[OF False d(1)] d(2) by blast
       moreover have "set (removeAll (a,d) TI) \<subseteq> set TI" by simp
       ultimately have "(d,b) \<in> (set TI)\<^sup>+" using trancl_mono by blast
       thus ?thesis using d(1) by fastforce
     qed simp
   qed
 qed
 
 lemma in_rtrancl_closure_iff_in_rtrancl_fun:
   "(a,b) \<in> (set TI)\<^sup>* \<longleftrightarrow> in_rtrancl TI a b"
 by (metis rtrancl_eq_or_trancl in_trancl_closure_iff_in_trancl_fun in_rtrancl_def)
 
 lemma in_trancl_mono:
   assumes "set TI \<subseteq> set TI'"
     and "in_trancl TI a b"
   shows "in_trancl TI' a b"
 by (metis assms in_trancl_closure_iff_in_trancl_fun trancl_mono)
 
 lemma equal_mod_timpls_refl:
   "equal_mod_timpls TI t t"
 proof (induction t)
   case (Fun f T) thus ?case
     using list_all2_conv_all_nth[of "equal_mod_timpls TI" T T] by force
 qed simp
 
 lemma equal_mod_timpls_inv_Var:
   "equal_mod_timpls TI (Var x) t \<Longrightarrow> t = Var x" (is "?A \<Longrightarrow> ?C")
   "equal_mod_timpls TI t (Var x) \<Longrightarrow> t = Var x" (is "?B \<Longrightarrow> ?C")
 proof -
   show "?A \<Longrightarrow> ?C" by (cases t) auto
   show "?B \<Longrightarrow> ?C" by (cases t) auto
 qed
 
 lemma equal_mod_timpls_inv:
   assumes "equal_mod_timpls TI (Fun f T) (Fun g S)"
   shows "length T = length S"
     and "\<And>i. i < length T \<Longrightarrow> equal_mod_timpls TI (T ! i) (S ! i)"
     and "f \<noteq> g \<Longrightarrow> (is_Abs f \<and> is_Abs g \<and> (
                       (the_Abs f, the_Abs g) \<in> set TI \<or> (the_Abs g, the_Abs f) \<in> set TI \<or>
                       (\<exists>ti \<in> set TI. (the_Abs f, snd ti) \<in> set TI \<and>
                                      (the_Abs g, snd ti) \<in> set TI)))"
 using assms list_all2_conv_all_nth[of "equal_mod_timpls TI" T S]
 by (auto elim: equal_mod_timpls.cases)
 
 lemma equal_mod_timpls_inv':
   assumes "equal_mod_timpls TI (Fun f T) t"
   shows "is_Fun t"
     and "length T = length (args t)"
     and "\<And>i. i < length T \<Longrightarrow> equal_mod_timpls TI (T ! i) (args t ! i)"
     and "f \<noteq> the_Fun t \<Longrightarrow> (is_Abs f \<and> is_Abs (the_Fun t) \<and> (
                       (the_Abs f, the_Abs (the_Fun t)) \<in> set TI \<or>
                       (the_Abs (the_Fun t), the_Abs f) \<in> set TI \<or>
                       (\<exists>ti \<in> set TI. (the_Abs f, snd ti) \<in> set TI \<and>
                                      (the_Abs (the_Fun t), snd ti) \<in> set TI)))"
     and "\<not>is_Abs f \<Longrightarrow> f = the_Fun t"
 using assms list_all2_conv_all_nth[of "equal_mod_timpls TI" T]
 by (cases t; auto)+
 
 lemma equal_mod_timpls_if_term_variants:
   fixes s t::"(('a, 'b, 'c, 'd) prot_fun, 'e) term" and a b::"'c set"
   defines "P \<equiv> (\<lambda>_. [])(Abs a := [Abs b])"
   assumes st: "term_variants_pred P s t"
     and ab: "(a,b) \<in> set TI"
   shows "equal_mod_timpls TI s t"
 using st P_def
 proof (induction rule: term_variants_pred.induct)
   case (term_variants_P T S f) thus ?case
     using ab list_all2_conv_all_nth[of "equal_mod_timpls TI" T S]
           in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
     by auto
 next
   case (term_variants_Fun T S f) thus ?case
     using ab list_all2_conv_all_nth[of "equal_mod_timpls TI" T S]
           in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
     by auto
 qed simp
 
 lemma equal_mod_timpls_mono:
   assumes "set TI \<subseteq> set TI'"
     and "equal_mod_timpls TI s t"
   shows "equal_mod_timpls TI' s t"
   using assms
 proof (induction TI s t rule: equal_mod_timpls.induct)
   case (2 TI f T g S)
   have *: "f = g \<or> (is_Abs f \<and> is_Abs g \<and> ((the_Abs f, the_Abs g) \<in> set TI \<or>
                  (the_Abs g, the_Abs f) \<in> set TI \<or>
                  (\<exists>ti \<in> set TI. (the_Abs f, snd ti) \<in> set TI \<and>
                                 (the_Abs g, snd ti) \<in> set TI)))"
           "list_all2 (equal_mod_timpls TI) T S"
     using "2.prems" by simp_all
 
   show ?case
     using "2.IH"[OF _ _ "2.prems"(1)] list.rel_mono_strong[OF *(2), of "equal_mod_timpls TI'"]
           *(1) in_trancl_mono[OF "2.prems"(1)] set_rev_mp[OF _ "2.prems"(1)]
           equal_mod_timpls.simps(2)[of TI' f T g S]
     by metis
 qed auto
 
 lemma equal_mod_timpls_refl_minus_eq:
   "equal_mod_timpls TI s t \<longleftrightarrow> equal_mod_timpls (filter (\<lambda>(a,b). a \<noteq> b) TI) s t"
   (is "?A \<longleftrightarrow> ?B")
 proof
   show ?A when ?B using that equal_mod_timpls_mono[of "filter (\<lambda>(a,b). a \<noteq> b) TI" TI] by auto
 
   show ?B when ?A using that
   proof (induction TI s t rule: equal_mod_timpls.induct)
     case (2 TI f T g S)
     define TI' where "TI' \<equiv> filter (\<lambda>(a,b). a \<noteq> b) TI"
 
     let ?P = "\<lambda>X Y. f = g \<or> (is_Abs f \<and> is_Abs g \<and> ((the_Abs f, the_Abs g) \<in> set X \<or>
                  (the_Abs g, the_Abs f) \<in> set X \<or> (\<exists>ti \<in> set Y.
                  (the_Abs f, snd ti) \<in> set X \<and> (the_Abs g, snd ti) \<in> set X)))"
 
     have *: "?P TI TI" "list_all2 (equal_mod_timpls TI) T S"
       using "2.prems" by simp_all
 
     have "?P TI' TI"
       using *(1) unfolding TI'_def is_Abs_def by auto
     hence "?P TI' TI'"
       by (metis (no_types, lifting) snd_conv)
     moreover have "list_all2 (equal_mod_timpls TI') T S"
       using *(2) "2.IH" list.rel_mono_strong unfolding TI'_def by blast
     ultimately show ?case unfolding TI'_def by force
   qed auto
 qed
 
 lemma timpls_transformable_to_refl:
   "timpls_transformable_to TI t t" (is ?A)
   "timpls_transformable_to' TI t t" (is ?B)
 by (induct t) (auto simp add: list_all2_conv_all_nth)
 
 lemma timpls_transformable_to_inv_Var:
   "timpls_transformable_to TI (Var x) t \<Longrightarrow> t = Var x" (is "?A \<Longrightarrow> ?C")
   "timpls_transformable_to TI t (Var x) \<Longrightarrow> t = Var x" (is "?B \<Longrightarrow> ?C")
   "timpls_transformable_to' TI (Var x) t \<Longrightarrow> t = Var x" (is "?A' \<Longrightarrow> ?C")
   "timpls_transformable_to' TI t (Var x) \<Longrightarrow> t = Var x" (is "?B' \<Longrightarrow> ?C")
 by (cases t; auto)+
 
 lemma timpls_transformable_to_inv:
   assumes "timpls_transformable_to TI (Fun f T) (Fun g S)"
   shows "length T = length S"
     and "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to TI (T ! i) (S ! i)"
     and "f \<noteq> g \<Longrightarrow> (is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> set TI)"
 using assms list_all2_conv_all_nth[of "timpls_transformable_to TI" T S] by auto
 
 lemma timpls_transformable_to'_inv:
   assumes "timpls_transformable_to' TI (Fun f T) (Fun g S)"
   shows "length T = length S"
     and "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to' TI (T ! i) (S ! i)"
     and "f \<noteq> g \<Longrightarrow> (is_Abs f \<and> is_Abs g \<and> in_trancl TI (the_Abs f) (the_Abs g))"
 using assms list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S] by auto
 
 lemma timpls_transformable_to_inv':
   assumes "timpls_transformable_to TI (Fun f T) t"
   shows "is_Fun t"
     and "length T = length (args t)"
     and "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to TI (T ! i) (args t ! i)"
     and "f \<noteq> the_Fun t \<Longrightarrow> (
           is_Abs f \<and> is_Abs (the_Fun t) \<and> (the_Abs f, the_Abs (the_Fun t)) \<in> set TI)"
     and "\<not>is_Abs f \<Longrightarrow> f = the_Fun t"
 using assms list_all2_conv_all_nth[of "timpls_transformable_to TI" T]
 by (cases t; auto)+
 
 lemma timpls_transformable_to'_inv':
   assumes "timpls_transformable_to' TI (Fun f T) t"
   shows "is_Fun t"
     and "length T = length (args t)"
     and "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to' TI (T ! i) (args t ! i)"
     and "f \<noteq> the_Fun t \<Longrightarrow> (
           is_Abs f \<and> is_Abs (the_Fun t) \<and> in_trancl TI (the_Abs f) (the_Abs (the_Fun t)))"
     and "\<not>is_Abs f \<Longrightarrow> f = the_Fun t"
 using assms list_all2_conv_all_nth[of "timpls_transformable_to' TI" T]
 by (cases t; auto)+
 
 lemma timpls_transformable_to_size_eq:
   fixes s t::"(('a, 'b, 'c, 'd) prot_fun, 'e) term"
   shows "timpls_transformable_to TI s t \<Longrightarrow> size s = size t" (is "?A \<Longrightarrow> ?C")
     and "timpls_transformable_to' TI s t \<Longrightarrow> size s = size t" (is "?B \<Longrightarrow> ?C")
 proof -
   have *: "size_list size T = size_list size S"
     when "length T = length S" "\<And>i. i < length T \<Longrightarrow> size (T ! i) = size (S ! i)"
     for S T::"(('a, 'b, 'c, 'd) prot_fun, 'e) term list"
     using that
   proof (induction T arbitrary: S)
     case (Cons x T')
     then obtain y S' where y: "S = y#S'" by (cases S) auto
     hence "size_list size T' = size_list size S'" "size x = size y"
       using Cons.prems Cons.IH[of S'] by force+
     thus ?case using y by simp
   qed simp
 
   show ?C when ?A using that
   proof (induction rule: timpls_transformable_to.induct)
     case (2 TI f T g S)
     hence "length T = length S" "\<And>i. i < length T \<Longrightarrow> size (T ! i) = size (S ! i)"
       using timpls_transformable_to_inv(1,2)[of TI f T g S] by auto
     thus ?case using *[of S T] by simp
   qed simp_all
 
   show ?C when ?B using that
   proof (induction rule: timpls_transformable_to.induct)
     case (2 TI f T g S)
     hence "length T = length S" "\<And>i. i < length T \<Longrightarrow> size (T ! i) = size (S ! i)"
       using timpls_transformable_to'_inv(1,2)[of TI f T g S] by auto
     thus ?case using *[of S T] by simp
   qed simp_all
 qed
 
 lemma timpls_transformable_to_if_term_variants:
   fixes s t::"(('a, 'b, 'c, 'd) prot_fun, 'e) term" and a b::"'c set"
   defines "P \<equiv> (\<lambda>_. [])(Abs a := [Abs b])"
   assumes st: "term_variants_pred P s t"
     and ab: "(a,b) \<in> set TI"
   shows "timpls_transformable_to TI s t"
 using st P_def
 proof (induction rule: term_variants_pred.induct)
   case (term_variants_P T S f) thus ?case
     using ab list_all2_conv_all_nth[of "timpls_transformable_to TI" T S]
     by auto
 next
   case (term_variants_Fun T S f) thus ?case
     using ab list_all2_conv_all_nth[of "timpls_transformable_to TI" T S]
     by auto
 qed simp
 
 lemma timpls_transformable_to'_if_term_variants:
   fixes s t::"(('a, 'b, 'c, 'd) prot_fun, 'e) term" and a b::"'c set"
   defines "P \<equiv> (\<lambda>_. [])(Abs a := [Abs b])"
   assumes st: "term_variants_pred P s t"
     and ab: "(a,b) \<in> (set TI)\<^sup>+"
   shows "timpls_transformable_to' TI s t"
 using st P_def
 proof (induction rule: term_variants_pred.induct)
   case (term_variants_P T S f) thus ?case
     using ab list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S]
           in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
     by auto
 next
   case (term_variants_Fun T S f) thus ?case
     using ab list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S]
           in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
     by auto
 qed simp
 
 lemma timpls_transformable_to_trans:
   assumes TI_trancl: "\<forall>(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b \<longrightarrow> (a,b) \<in> set TI"
     and st: "timpls_transformable_to TI s t"
     and tu: "timpls_transformable_to TI t u"
   shows "timpls_transformable_to TI s u"
 using st tu
 proof (induction s arbitrary: t u)
   case (Var x) thus ?case using tu timpls_transformable_to_inv_Var(1) by fast
 next
   case (Fun f T)
   obtain g S where t:
       "t = Fun g S" "length T = length S"
       "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to TI (T ! i) (S ! i)"
       "f \<noteq> g \<Longrightarrow> is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> set TI"
-    using timpls_transformable_to_inv'[OF Fun.prems(1)] TI_trancl by moura
+    using timpls_transformable_to_inv'[OF Fun.prems(1)] TI_trancl by auto
 
   obtain h U where u:
       "u = Fun h U" "length S = length U"
       "\<And>i. i < length S \<Longrightarrow> timpls_transformable_to TI (S ! i) (U ! i)"
       "g \<noteq> h \<Longrightarrow> is_Abs g \<and> is_Abs h \<and> (the_Abs g, the_Abs h) \<in> set TI"
-    using timpls_transformable_to_inv'[OF Fun.prems(2)[unfolded t(1)]] TI_trancl by moura
+    using timpls_transformable_to_inv'[OF Fun.prems(2)[unfolded t(1)]] TI_trancl by auto
 
   have "list_all2 (timpls_transformable_to TI) T U"
     using t(1,2,3) u(1,2,3) Fun.IH
           list_all2_conv_all_nth[of "timpls_transformable_to TI" T S]
           list_all2_conv_all_nth[of "timpls_transformable_to TI" S U]
           list_all2_conv_all_nth[of "timpls_transformable_to TI" T U]
     by force
   moreover have "(the_Abs f, the_Abs h) \<in> set TI"
     when "(the_Abs f, the_Abs g) \<in> set TI" "(the_Abs g, the_Abs h) \<in> set TI"
          "f \<noteq> h" "is_Abs f" "is_Abs h"
     using that(3,4,5) TI_trancl trancl_into_trancl[OF r_into_trancl[OF that(1)] that(2)]
     unfolding is_Abs_def the_Abs_def
     by force
   hence "is_Abs f \<and> is_Abs h \<and> (the_Abs f, the_Abs h) \<in> set TI"
     when "f \<noteq> h"
     using that TI_trancl t(4) u(4) by fast
   ultimately show ?case using t(1) u(1) by force
 qed
 
 lemma timpls_transformable_to'_trans:
   assumes st: "timpls_transformable_to' TI s t"
     and tu: "timpls_transformable_to' TI t u"
   shows "timpls_transformable_to' TI s u"
 using st tu
 proof (induction s arbitrary: t u)
   case (Var x) thus ?case using tu timpls_transformable_to_inv_Var(3) by fast
 next
   case (Fun f T)
   note 0 = in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
 
   obtain g S where t:
       "t = Fun g S" "length T = length S"
       "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to' TI (T ! i) (S ! i)"
       "f \<noteq> g \<Longrightarrow> is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> (set TI)\<^sup>+"
-    using timpls_transformable_to'_inv'[OF Fun.prems(1)] 0 by moura
+    using timpls_transformable_to'_inv'[OF Fun.prems(1)] 0 by auto
 
   obtain h U where u:
       "u = Fun h U" "length S = length U"
       "\<And>i. i < length S \<Longrightarrow> timpls_transformable_to' TI (S ! i) (U ! i)"
       "g \<noteq> h \<Longrightarrow> is_Abs g \<and> is_Abs h \<and> (the_Abs g, the_Abs h) \<in> (set TI)\<^sup>+"
-    using timpls_transformable_to'_inv'[OF Fun.prems(2)[unfolded t(1)]] 0 by moura
+    using timpls_transformable_to'_inv'[OF Fun.prems(2)[unfolded t(1)]] 0 by auto
 
   have "list_all2 (timpls_transformable_to' TI) T U"
     using t(1,2,3) u(1,2,3) Fun.IH
           list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S]
           list_all2_conv_all_nth[of "timpls_transformable_to' TI" S U]
           list_all2_conv_all_nth[of "timpls_transformable_to' TI" T U]
     by force
   moreover have "(the_Abs f, the_Abs h) \<in> (set TI)\<^sup>+"
     when "(the_Abs f, the_Abs g) \<in> (set TI)\<^sup>+" "(the_Abs g, the_Abs h) \<in> (set TI)\<^sup>+"
     using that by simp
   hence "is_Abs f \<and> is_Abs h \<and> (the_Abs f, the_Abs h) \<in> (set TI)\<^sup>+"
     when "f \<noteq> h"
     by (metis that t(4) u(4))
   ultimately show ?case using t(1) u(1) 0 by force
 qed
 
 lemma timpls_transformable_to_mono:
   assumes "set TI \<subseteq> set TI'"
     and "timpls_transformable_to TI s t"
   shows "timpls_transformable_to TI' s t"
   using assms
 proof (induction TI s t rule: timpls_transformable_to.induct)
   case (2 TI f T g S)
   have *: "f = g \<or> (is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> set TI)"
           "list_all2 (timpls_transformable_to TI) T S"
     using "2.prems" by simp_all
 
   show ?case
     using "2.IH" "2.prems"(1) list.rel_mono_strong[OF *(2)] *(1) in_trancl_mono[of TI TI']
     by (metis (no_types, lifting) timpls_transformable_to.simps(2) set_rev_mp)
 qed auto
 
 lemma timpls_transformable_to'_mono:
   assumes "set TI \<subseteq> set TI'"
     and "timpls_transformable_to' TI s t"
   shows "timpls_transformable_to' TI' s t"
   using assms
 proof (induction TI s t rule: timpls_transformable_to'.induct)
   case (2 TI f T g S)
   have *: "f = g \<or> (is_Abs f \<and> is_Abs g \<and> in_trancl TI (the_Abs f) (the_Abs g))"
           "list_all2 (timpls_transformable_to' TI) T S"
     using "2.prems" by simp_all
 
   show ?case
     using "2.IH" "2.prems"(1) list.rel_mono_strong[OF *(2)] *(1) in_trancl_mono[of TI TI']
     by (metis (no_types, lifting) timpls_transformable_to'.simps(2))
 qed auto
 
 lemma timpls_transformable_to_refl_minus_eq:
   "timpls_transformable_to TI s t \<longleftrightarrow> timpls_transformable_to (filter (\<lambda>(a,b). a \<noteq> b) TI) s t"
   (is "?A \<longleftrightarrow> ?B")
 proof
   let ?TI' = "\<lambda>TI. filter (\<lambda>(a,b). a \<noteq> b) TI"
 
   show ?A when ?B using that timpls_transformable_to_mono[of "?TI' TI" TI] by auto
 
   show ?B when ?A using that
   proof (induction TI s t rule: timpls_transformable_to.induct)
     case (2 TI f T g S)
     have *: "f = g \<or> (is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> set TI)"
             "list_all2 (timpls_transformable_to TI) T S"
       using "2.prems" by simp_all
 
     have "f = g \<or> (is_Abs f \<and> is_Abs g \<and> (the_Abs f, the_Abs g) \<in> set (?TI' TI))"
       using *(1) unfolding is_Abs_def by auto
     moreover have "list_all2 (timpls_transformable_to (?TI' TI)) T S"
       using *(2) "2.IH" list.rel_mono_strong by blast
     ultimately show ?case by force
   qed auto
 qed
 
 lemma timpls_transformable_to_iff_in_timpl_closure:
   assumes "set TI' = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "timpls_transformable_to TI' s t \<longleftrightarrow> t \<in> timpl_closure s (set TI)" (is "?A s t \<longleftrightarrow> ?B s t")
 proof
   show "?A s t \<Longrightarrow> ?B s t" using assms
   proof (induction s t rule: timpls_transformable_to.induct)
     case (2 TI f T g S)
     note prems = "2.prems"
     note IH = "2.IH"
 
     have 1: "length T = length S" "\<forall>i<length T. timpls_transformable_to TI' (T ! i) (S ! i)"
       using prems(1) list_all2_conv_all_nth[of "timpls_transformable_to TI'" T S] by simp_all
 
     note 2 = timpl_closure_is_timpl_closure'
     note 3 = in_set_conv_nth[of _ T] in_set_conv_nth[of _ S]
 
     have 4: "timpl_closure' (set TI') = timpl_closure' (set TI)"
       using timpl_closure'_timpls_trancl_eq'[of "set TI"] prems(2) by simp
 
     have IH': "(T ! i, S ! i) \<in> timpl_closure' (set TI')" when i: "i < length S" for i
     proof -
       have "timpls_transformable_to TI' (T ! i) (S ! i)" using i 1 by presburger 
       hence "S ! i \<in> timpl_closure (T ! i) (set TI)"
         using IH[of "T ! i" "S ! i"] i 1(1) prems(2) by force
       thus ?thesis using 2[of "S ! i" "T ! i" "set TI"] 4 by blast
     qed
 
     have 5: "f = g \<or> (\<exists>a b. (a, b) \<in> (set TI')\<^sup>+ \<and> f = Abs a \<and> g = Abs b)"
       using prems(1) the_Abs_def[of f] the_Abs_def[of g] is_Abs_def[of f] is_Abs_def[of g] 
       by fastforce
 
     show ?case using 2 4 timpl_closure_FunI[OF IH' 1(1) 5] 1(1) by auto
   qed (simp_all add: timpl_closure.FP)
 
   show "?B s t \<Longrightarrow> ?A s t"
   proof (induction t rule: timpl_closure.induct)
     case (TI u a b v) show ?case
     proof (cases "a = b")
       case True thus ?thesis using TI.hyps(3) TI.IH term_variants_pred_refl_inv by fastforce
     next
       case False
       hence 1: "timpls_transformable_to TI' u v"
         using TI.hyps(2) assms timpls_transformable_to_if_term_variants[OF TI.hyps(3), of TI']
         by blast
       have 2: "(c,d) \<in> set TI'" when cd: "(c,d) \<in> (set TI')\<^sup>+" "c \<noteq> d" for c d
       proof -
         let ?cl = "\<lambda>X. {(a,b) \<in> X\<^sup>+. a \<noteq> b}"
         have "?cl (set TI') = ?cl (?cl (set TI))" using assms by presburger
         hence "set TI' = ?cl (set TI')" using assms trancl_minus_refl_idem[of "set TI"] by argo
         thus ?thesis using cd by blast
       qed
       show ?thesis using timpls_transformable_to_trans[OF _ TI.IH 1] 2 by blast
     qed
   qed (use timpls_transformable_to_refl in fast)
 qed
 
 lemma timpls_transformable_to'_iff_in_timpl_closure:
   "timpls_transformable_to' TI s t \<longleftrightarrow> t \<in> timpl_closure s (set TI)" (is "?A s t \<longleftrightarrow> ?B s t")
 proof
   show "?A s t \<Longrightarrow> ?B s t"
   proof (induction s t rule: timpls_transformable_to'.induct)
     case (2 TI f T g S)
     note prems = "2.prems"
     note IH = "2.IH"
 
     have 1: "length T = length S" "\<forall>i<length T. timpls_transformable_to' TI (T ! i) (S ! i)"
       using prems list_all2_conv_all_nth[of "timpls_transformable_to' TI" T S] by simp_all
 
     note 2 = timpl_closure_is_timpl_closure'
     note 3 = in_set_conv_nth[of _ T] in_set_conv_nth[of _ S]
 
     have IH': "(T ! i, S ! i) \<in> timpl_closure' (set TI)" when i: "i < length S" for i
     proof -
       have "timpls_transformable_to' TI (T ! i) (S ! i)" using i 1 by presburger 
       hence "S ! i \<in> timpl_closure (T ! i) (set TI)" using IH[of "T ! i" "S ! i"] i 1(1) by force
       thus ?thesis using 2[of "S ! i" "T ! i" "set TI"] by blast
     qed
 
     have 4: "f = g \<or> (\<exists>a b. (a, b) \<in> (set TI)\<^sup>+ \<and> f = Abs a \<and> g = Abs b)"
       using prems the_Abs_def[of f] the_Abs_def[of g] is_Abs_def[of f] is_Abs_def[of g]
             in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
       by auto
 
     show ?case using 2 timpl_closure_FunI[OF IH' 1(1) 4] 1(1) by auto
   qed (simp_all add: timpl_closure.FP)
 
   show "?B s t \<Longrightarrow> ?A s t"
   proof (induction t rule: timpl_closure.induct)
     case (TI u a b v) thus ?case
       using timpls_transformable_to'_trans
             timpls_transformable_to'_if_term_variants
       by blast
   qed (use timpls_transformable_to_refl(2) in fast)
 qed
 
 lemma equal_mod_timpls_iff_ex_in_timpl_closure:
   assumes "set TI' = {(a,b) \<in> TI\<^sup>+. a \<noteq> b}"
   shows "equal_mod_timpls TI' s t \<longleftrightarrow> (\<exists>u. u \<in> timpl_closure s TI \<and> u \<in> timpl_closure t TI)"
     (is "?A s t \<longleftrightarrow> ?B s t")
 proof
   show "?A s t \<Longrightarrow> ?B s t" using assms
   proof (induction s t rule: equal_mod_timpls.induct)
     case (2 TI' f T g S)
     note prems = "2.prems"
     note IH = "2.IH"
 
     have 1: "length T = length S" "\<forall>i<length T. equal_mod_timpls (TI') (T ! i) (S ! i)"
       using prems list_all2_conv_all_nth[of "equal_mod_timpls TI'" T S] by simp_all
 
     note 2 = timpl_closure_is_timpl_closure'
     note 3 = in_set_conv_nth[of _ T] in_set_conv_nth[of _ S]
 
     have 4: "timpl_closure' (set TI') = timpl_closure' TI"
       using timpl_closure'_timpls_trancl_eq'[of TI] prems
       by simp
 
     have IH: "\<exists>u. (T ! i, u) \<in> timpl_closure' TI \<and> (S ! i, u) \<in> timpl_closure' TI"
       when i: "i < length S" for i
     proof -
       have "equal_mod_timpls TI' (T ! i) (S ! i)" using i 1 by presburger 
       hence "\<exists>u. u \<in> timpl_closure (T ! i) TI \<and> u \<in> timpl_closure (S ! i) TI"
         using IH[of "T ! i" "S ! i"] i 1(1) prems by force
       thus ?thesis using 4 unfolding 2 by blast
     qed
 
     let ?P = "\<lambda>G. f = g \<or> (\<exists>a b. (a, b) \<in> G \<and> f = Abs a \<and> g = Abs b) \<or>
                    (\<exists>a b. (a, b) \<in> G \<and> f = Abs b \<and> g = Abs a) \<or>
                    (\<exists>a b c. (a, c) \<in> G \<and> (b, c) \<in> G \<and> f = Abs a \<and> g = Abs b)"
 
     have "?P (set TI')"
       using prems the_Abs_def[of f] the_Abs_def[of g] is_Abs_def[of f] is_Abs_def[of g]
       by fastforce
     hence "?P (TI\<^sup>+)" unfolding prems by blast
     hence "?P (rtrancl TI)" by (metis (no_types, lifting) trancl_into_rtrancl)
     hence 5: "f = g \<or> (\<exists>a b c. (a, c) \<in> TI\<^sup>* \<and> (b, c) \<in> TI\<^sup>* \<and> f = Abs a \<and> g = Abs b)" by blast
 
     show ?case
       using timpl_closure_FunI3[OF _ 1(1) 5]  IH 1(1)
       unfolding timpl_closure'_timpls_rtrancl_eq 2
       by auto
   qed (use timpl_closure.FP in auto)
 
   show "?A s t" when B: "?B s t"
   proof -
     obtain u where u: "u \<in> timpl_closure s TI" "u \<in> timpl_closure t TI"
-      using B by moura
+      using B by blast
     thus ?thesis using assms
     proof (induction u arbitrary: s t rule: term.induct)
       case (Var x s t) thus ?case
         using timpl_closure_Var_in_iff[of x s TI]
               timpl_closure_Var_in_iff[of x t TI]
               equal_mod_timpls.simps(1)[of TI' x x]
         by blast
     next
       case (Fun f U s t)
       obtain g S where s:
           "s = Fun g S" "length U = length S"
           "\<And>i. i < length U \<Longrightarrow> U ! i \<in> timpl_closure (S ! i) TI"
           "g \<noteq> f \<Longrightarrow> is_Abs g \<and> is_Abs f \<and> (the_Abs g, the_Abs f) \<in> TI\<^sup>+"
         using Fun.prems(1) timpl_closure_Fun_inv'[of f U _ _ TI]
         by (cases s) auto
 
       obtain h T where t:
           "t = Fun h T" "length U = length T"
           "\<And>i. i < length U \<Longrightarrow> U ! i \<in> timpl_closure (T ! i) TI"
           "h \<noteq> f \<Longrightarrow> is_Abs h \<and> is_Abs f \<and> (the_Abs h, the_Abs f) \<in> TI\<^sup>+"
         using Fun.prems(2) timpl_closure_Fun_inv'[of f U _ _ TI]
         by (cases t) auto
 
       have g: "(the_Abs g, the_Abs f) \<in> set TI'" "is_Abs f" "is_Abs g" when neq_f: "g \<noteq> f"
       proof -
         obtain ga fa where a: "g = Abs ga" "f = Abs fa"
           using s(4)[OF neq_f] unfolding is_Abs_def by presburger
         hence "the_Abs g \<noteq> the_Abs f" using neq_f by simp
         thus "(the_Abs g, the_Abs f) \<in> set TI'" "is_Abs f" "is_Abs g"
           using s(4)[OF neq_f] Fun.prems by blast+
       qed
 
       have h: "(the_Abs h, the_Abs f) \<in> set TI'" "is_Abs f" "is_Abs h" when neq_f: "h \<noteq> f"
       proof -
         obtain ha fa where a: "h = Abs ha" "f = Abs fa"
           using t(4)[OF neq_f] unfolding is_Abs_def by presburger
         hence "the_Abs h \<noteq> the_Abs f" using neq_f by simp
         thus "(the_Abs h, the_Abs f) \<in> set TI'" "is_Abs f" "is_Abs h"
           using t(4)[OF neq_f] Fun.prems by blast+
       qed
 
       have "equal_mod_timpls TI' (S ! i) (T ! i)"
         when i: "i < length U" for i
         using i Fun.IH s(1,2,3) t(1,2,3) nth_mem[OF i] Fun.prems by meson
       hence "list_all2 (equal_mod_timpls TI') S T"
         using list_all2_conv_all_nth[of "equal_mod_timpls TI'" S T] s(2) t(2) by presburger
       thus ?case using s(1) t(1) g h by fastforce
     qed
   qed
 qed
 
 (* lemma equal_mod_timpls_iff_ex_in_timpl_closure':
   "equal_mod_timpls (TI\<^sup>+) s t \<longleftrightarrow> (\<exists>u. u \<in> timpl_closure s TI \<and> u \<in> timpl_closure t TI)"
 using equal_mod_timpls_iff_ex_in_timpl_closure equal_mod_timpls_refl_minus_eq
 by blast *)
 
 context
 begin
 private inductive timpls_transformable_to_pred where
   Var: "timpls_transformable_to_pred A (Var x) (Var x)"
 | Fun: "\<lbrakk>\<not>is_Abs f; length T = length S;
          \<And>i. i < length T \<Longrightarrow> timpls_transformable_to_pred A (T ! i) (S ! i)\<rbrakk>
         \<Longrightarrow> timpls_transformable_to_pred A (Fun f T) (Fun f S)"
 | Abs: "b \<in> A \<Longrightarrow> timpls_transformable_to_pred A (Fun (Abs a) []) (Fun (Abs b) [])"
 
 private lemma timpls_transformable_to_pred_inv_Var:
   assumes "timpls_transformable_to_pred A (Var x) t"
   shows "t = Var x"
 using assms by (auto elim: timpls_transformable_to_pred.cases)
 
 private lemma timpls_transformable_to_pred_inv:
   assumes "timpls_transformable_to_pred A (Fun f T) t"
   shows "is_Fun t"
     and "length T = length (args t)"
     and "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to_pred A (T ! i) (args t ! i)"
     and "\<not>is_Abs f \<Longrightarrow> f = the_Fun t"
     and "is_Abs f \<Longrightarrow> (is_Abs (the_Fun t) \<and> the_Abs (the_Fun t) \<in> A)"
 using assms by (auto elim!: timpls_transformable_to_pred.cases[of A])
 
 private lemma timpls_transformable_to_pred_finite_aux1:
   assumes f: "\<not>is_Abs f"
   shows "{s. timpls_transformable_to_pred A (Fun f T) s} \<subseteq>
           (\<lambda>S. Fun f S) ` {S. length T = length S \<and>
                               (\<forall>s \<in> set S. \<exists>t \<in> set T. timpls_transformable_to_pred A t s)}"
     (is "?B \<subseteq> ?C")
 proof
   fix s assume s: "s \<in> ?B"
   hence *: "timpls_transformable_to_pred A (Fun f T) s" by blast
 
   obtain S where S:
       "s = Fun f S" "length T = length S" "\<And>i. i < length T \<Longrightarrow> timpls_transformable_to_pred A (T ! i) (S ! i)"
     using f timpls_transformable_to_pred_inv[OF *] unfolding the_Abs_def is_Abs_def by auto
 
   have "\<forall>s\<in>set S. \<exists>t\<in>set T. timpls_transformable_to_pred A t s" using S(2,3) in_set_conv_nth by metis
   thus "s \<in> ?C" using S(1,2) by blast
 qed
 
 private lemma timpls_transformable_to_pred_finite_aux2:
   "{s. timpls_transformable_to_pred A (Fun (Abs a) []) s} \<subseteq> (\<lambda>b. Fun (Abs b) []) ` A" (is "?B \<subseteq> ?C")
 proof
   fix s assume s: "s \<in> ?B"
   hence *: "timpls_transformable_to_pred A (Fun (Abs a) []) s" by blast
 
   obtain b where b: "s = Fun (Abs b) []" "b \<in> A"
     using timpls_transformable_to_pred_inv[OF *] unfolding the_Abs_def is_Abs_def by auto
   thus "s \<in> ?C" by blast
 qed
 
 private lemma timpls_transformable_to_pred_finite:
   fixes t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term"
   assumes A: "finite A"
     and t: "wf\<^sub>t\<^sub>r\<^sub>m t"
   shows "finite {s. timpls_transformable_to_pred A t s}"
 using t
 proof (induction t)
   case (Var x)
   have "{s::(('fun,'atom,'sets,'lbl) prot_fun, 'a) term. timpls_transformable_to_pred A (Var x) s} = {Var x}"
     by (auto intro: timpls_transformable_to_pred.Var elim: timpls_transformable_to_pred_inv_Var)
   thus ?case by simp
 next
   case (Fun f T)
   have IH: "finite {s. timpls_transformable_to_pred A t s}" when t: "t \<in> set T" for t
     using Fun.IH[OF t] wf_trm_param[OF Fun.prems t] by blast
 
   show ?case
   proof (cases "is_Abs f")
     case True
     then obtain a where a: "f = Abs a" unfolding is_Abs_def by presburger
     hence "T = []" using wf_trm_arity[OF Fun.prems] by simp_all
     hence "{a. timpls_transformable_to_pred A (Fun f T) a} \<subseteq> (\<lambda>b. Fun (Abs b) []) ` A"
       using timpls_transformable_to_pred_finite_aux2[of A a] a by auto
     thus ?thesis using A finite_subset by fast
   next
     case False thus ?thesis
       using IH finite_lists_length_eq' timpls_transformable_to_pred_finite_aux1[of f A T] finite_subset
       by blast
   qed
 qed
 
 private lemma timpls_transformable_to_pred_if_timpls_transformable_to:
   assumes s: "timpls_transformable_to TI t s"
     and t: "wf\<^sub>t\<^sub>r\<^sub>m t" "\<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> A"
   shows "timpls_transformable_to_pred (A \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+) t s"
 using s t
 proof (induction rule: timpls_transformable_to.induct)
   case (2 TI f T g S)
   let ?A = "A \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+"
 
   note prems = "2.prems"
   note IH = "2.IH"
 
   note 0 = timpls_transformable_to_inv[OF prems(1)]
 
   have 1: "T = []" "S = []" when f: "f = Abs a" for a
     using f wf_trm_arity[OF prems(2)] 0(1) by simp_all
 
   have "\<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> A" when t: "t \<in> set T" for t
     using t prems(3) funs_term_subterms_eq(1)[of "Fun f T"] by blast
   hence 2: "timpls_transformable_to_pred ?A (T ! i) (S ! i)"
     when i: "i < length T" for i
     using i IH 0(1,2) wf_trm_param[OF prems(2)]
     by (metis (no_types) in_set_conv_nth)
 
   have 3: "the_Abs f \<in> ?A" when f: "is_Abs f" using prems(3) f by force
 
   show ?case
   proof (cases "f = g")
     case True
     note fg = True
     show ?thesis
     proof (cases "is_Abs f")
       case True
-      then obtain a where a: "f = Abs a" unfolding is_Abs_def by moura
+      then obtain a where a: "f = Abs a" unfolding is_Abs_def by blast
       thus ?thesis using fg 1[OF a] timpls_transformable_to_pred.Abs[of a ?A a] 3 by simp
     qed (use fg timpls_transformable_to_pred.Fun[OF _ 0(1) 2, of f] in blast)
   next
     case False
     then obtain a b where ab: "f = Abs a" "g = Abs b" "(a, b) \<in> (set TI)\<^sup>+"
       using 0(3) in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
       unfolding is_Abs_def the_Abs_def by fastforce
     hence "a \<in> ?A" "b \<in> ?A" by force+
     thus ?thesis using timpls_transformable_to_pred.Abs ab(1,2) 1[OF ab(1)] by metis
   qed
 qed (simp_all add: timpls_transformable_to_pred.Var)
 
 private lemma timpls_transformable_to_pred_if_timpls_transformable_to':
   assumes s: "timpls_transformable_to' TI t s"
     and t: "wf\<^sub>t\<^sub>r\<^sub>m t" "\<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> A"
   shows "timpls_transformable_to_pred (A \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+) t s"
 using s t
 proof (induction rule: timpls_transformable_to.induct)
   case (2 TI f T g S)
   let ?A = "A \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+"
 
   note prems = "2.prems"
   note IH = "2.IH"
 
   note 0 = timpls_transformable_to'_inv[OF prems(1)]
 
   have 1: "T = []" "S = []" when f: "f = Abs a" for a
     using f wf_trm_arity[OF prems(2)] 0(1) by simp_all
 
   have "\<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> A" when t: "t \<in> set T" for t
     using t prems(3) funs_term_subterms_eq(1)[of "Fun f T"] by blast
   hence 2: "timpls_transformable_to_pred ?A (T ! i) (S ! i)"
     when i: "i < length T" for i
     using i IH 0(1,2) wf_trm_param[OF prems(2)]
     by (metis (no_types) in_set_conv_nth)
 
   have 3: "the_Abs f \<in> ?A" when f: "is_Abs f" using prems(3) f by force
 
   show ?case
   proof (cases "f = g")
     case True
     note fg = True
     show ?thesis
     proof (cases "is_Abs f")
       case True
-      then obtain a where a: "f = Abs a" unfolding is_Abs_def by moura
+      then obtain a where a: "f = Abs a" unfolding is_Abs_def by blast
       thus ?thesis using fg 1[OF a] timpls_transformable_to_pred.Abs[of a ?A a] 3 by simp
     qed (use fg timpls_transformable_to_pred.Fun[OF _ 0(1) 2, of f] in blast)
   next
     case False
     then obtain a b where ab: "f = Abs a" "g = Abs b" "(a, b) \<in> (set TI)\<^sup>+"
       using 0(3) in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
       unfolding is_Abs_def the_Abs_def by fastforce
     hence "a \<in> ?A" "b \<in> ?A" by force+
     thus ?thesis using timpls_transformable_to_pred.Abs ab(1,2) 1[OF ab(1)] by metis
   qed
 qed (simp_all add: timpls_transformable_to_pred.Var)
 
 private lemma timpls_transformable_to_pred_if_equal_mod_timpls:
   assumes s: "equal_mod_timpls TI t s"
     and t: "wf\<^sub>t\<^sub>r\<^sub>m t" "\<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> A"
   shows "timpls_transformable_to_pred (A \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+) t s"
 using s t
 proof (induction rule: equal_mod_timpls.induct)
   case (2 TI f T g S)
   let ?A = "A \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+"
 
   note prems = "2.prems"
   note IH = "2.IH"
 
   note 0 = equal_mod_timpls_inv[OF prems(1)]
 
   have 1: "T = []" "S = []" when f: "f = Abs a" for a
     using f wf_trm_arity[OF prems(2)] 0(1) by simp_all
 
   have "\<forall>f \<in> funs_term t. is_Abs f \<longrightarrow> the_Abs f \<in> A" when t: "t \<in> set T" for t
     using t prems(3) funs_term_subterms_eq(1)[of "Fun f T"] by blast
   hence 2: "timpls_transformable_to_pred ?A (T ! i) (S ! i)"
     when i: "i < length T" for i
     using i IH 0(1,2) wf_trm_param[OF prems(2)]
     by (metis (no_types) in_set_conv_nth)
 
   have 3: "the_Abs f \<in> ?A" when f: "is_Abs f" using prems(3) f by force
 
   show ?case
   proof (cases "f = g")
     case True
     note fg = True
     show ?thesis
     proof (cases "is_Abs f")
       case True
-      then obtain a where a: "f = Abs a" unfolding is_Abs_def by moura
+      then obtain a where a: "f = Abs a" unfolding is_Abs_def by blast
       thus ?thesis using fg 1[OF a] timpls_transformable_to_pred.Abs[of a ?A a] 3 by simp
     qed (use fg timpls_transformable_to_pred.Fun[OF _ 0(1) 2, of f] in blast)
   next
     case False
     then obtain a b where ab: "f = Abs a" "g = Abs b"
         "(a, b) \<in> (set TI)\<^sup>+ \<or> (b, a) \<in> (set TI)\<^sup>+ \<or>
          (\<exists>ti \<in> set TI. (a, snd ti) \<in> (set TI)\<^sup>+ \<and> (b, snd ti) \<in> (set TI)\<^sup>+)"
       using 0(3) in_trancl_closure_iff_in_trancl_fun[of _ _ TI]
       unfolding is_Abs_def the_Abs_def by fastforce
     hence "a \<in> ?A" "b \<in> ?A" by force+
     thus ?thesis using timpls_transformable_to_pred.Abs ab(1,2) 1[OF ab(1)] by metis
   qed
 qed (simp_all add: timpls_transformable_to_pred.Var)
 
 lemma timpls_transformable_to_finite:
   assumes t: "wf\<^sub>t\<^sub>r\<^sub>m t"
   shows "finite {s. timpls_transformable_to TI t s}" (is ?P)
     and "finite {s. timpls_transformable_to' TI t s}" (is ?Q)
 proof -
   let ?A = "the_Abs ` {f \<in> funs_term t. is_Abs f} \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+"
 
   have 0: "finite ?A" by auto
 
   have 1: "{s. timpls_transformable_to TI t s} \<subseteq> {s. timpls_transformable_to_pred ?A t s}"
     using timpls_transformable_to_pred_if_timpls_transformable_to[OF _ t] by auto
 
   have 2: "{s. timpls_transformable_to' TI t s} \<subseteq> {s. timpls_transformable_to_pred ?A t s}"
     using timpls_transformable_to_pred_if_timpls_transformable_to'[OF _ t] by auto
 
   show ?P using timpls_transformable_to_pred_finite[OF 0 t] finite_subset[OF 1] by blast
   show ?Q using timpls_transformable_to_pred_finite[OF 0 t] finite_subset[OF 2] by blast
 qed
 
 lemma equal_mod_timpls_finite:
   assumes t: "wf\<^sub>t\<^sub>r\<^sub>m t"
   shows "finite {s. equal_mod_timpls TI t s}"
 proof -
   let ?A = "the_Abs ` {f \<in> funs_term t. is_Abs f} \<union> fst ` (set TI)\<^sup>+ \<union> snd ` (set TI)\<^sup>+"
 
   have 0: "finite ?A" by auto
 
   have 1: "{s. equal_mod_timpls TI t s} \<subseteq> {s. timpls_transformable_to_pred ?A t s}"
     using timpls_transformable_to_pred_if_equal_mod_timpls[OF _ t] by auto
 
   show ?thesis using timpls_transformable_to_pred_finite[OF 0 t] finite_subset[OF 1] by blast
 qed
 
 end
 
 lemma intruder_synth_mod_timpls_is_synth_timpl_closure_set:
   fixes t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term" and TI TI'
   assumes "set TI' = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
   shows "intruder_synth_mod_timpls M TI' t \<longleftrightarrow> timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c t"
       (is "?C t \<longleftrightarrow> ?D t")
 proof -
   have *: "(\<exists>m \<in> M. timpls_transformable_to TI' m t) \<longleftrightarrow> t \<in> timpl_closure_set M (set TI)"
     when "set TI' = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     for M TI TI' and t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term"
     using timpls_transformable_to_iff_in_timpl_closure[OF that]
           timpl_closure_set_is_timpl_closure_union[of M "set TI"]
           timpl_closure_set_timpls_trancl_eq[of M "set TI"]
           timpl_closure_set_timpls_trancl_eq'[of M "set TI"]
     by auto
 
   show "?C t \<longleftrightarrow> ?D t"
   proof
     show "?C t \<Longrightarrow> ?D t" using assms
     proof (induction t arbitrary: M TI TI' rule: intruder_synth_mod_timpls.induct)
       case (1 M TI' x)
       hence "Var x \<in> timpl_closure_set (set M) (set TI)"
         using timpl_closure.FP member_def unfolding timpl_closure_set_def by force
       thus ?case by simp
     next
       case (2 M TI f T)
       show ?case
       proof (cases "\<exists>m \<in> set M. timpls_transformable_to TI' m (Fun f T)")
         case True thus ?thesis
           using "2.prems" *[of TI' TI "set M" "Fun f T"]
                 intruder_synth.AxiomC[of "Fun f T" "timpl_closure_set (set M) (set TI)"]
           by blast
       next
         case False
         hence "\<not>(list_ex (\<lambda>t. timpls_transformable_to TI' t (Fun f T)) M)"
           unfolding list_ex_iff by blast
         hence "public f" "length T = arity f" "list_all (intruder_synth_mod_timpls M TI') T"
           using "2.prems"(1) by force+
         thus ?thesis using "2.IH"[OF _ _ "2.prems"(2)] unfolding list_all_iff by force
       qed
     qed
   
     show "?D t \<Longrightarrow> ?C t"
     proof (induction t rule: intruder_synth_induct)
       case (AxiomC t) thus ?case
         using timpl_closure_set_Var_in_iff[of _ "set M" "set TI"] *[OF assms, of "set M" t]
         by (cases t rule: term.exhaust) (force simp add: member_def list_ex_iff)+
     next
       case (ComposeC T f) thus ?case
         using list_all_iff[of "intruder_synth_mod_timpls M TI'" T]
               intruder_synth_mod_timpls.simps(2)[of M TI' f T]
         by blast
     qed
   qed
 qed
 
 lemma intruder_synth_mod_timpls'_is_synth_timpl_closure_set:
   fixes t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term" and TI
   shows "intruder_synth_mod_timpls' M TI t \<longleftrightarrow> timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c t"
       (is "?A t \<longleftrightarrow> ?B t")
 proof -
   have *: "(\<exists>m \<in> M. timpls_transformable_to' TI m t) \<longleftrightarrow> t \<in> timpl_closure_set M (set TI)"
     for M TI and t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term"
     using timpls_transformable_to'_iff_in_timpl_closure[of TI _ t]
           timpl_closure_set_is_timpl_closure_union[of M "set TI"]
     by blast+
 
   show "?A t \<longleftrightarrow> ?B t"
   proof
     show "?A t \<Longrightarrow> ?B t"
     proof (induction t arbitrary: M TI rule: intruder_synth_mod_timpls'.induct)
       case (1 M TI x)
       hence "Var x \<in> timpl_closure_set (set M) (set TI)"
         using timpl_closure.FP List.member_def[of M] unfolding timpl_closure_set_def by auto
       thus ?case by simp
     next
       case (2 M TI f T)
       show ?case
       proof (cases "\<exists>m \<in> set M. timpls_transformable_to' TI m (Fun f T)")
         case True thus ?thesis
           using "2.prems" *[of "set M" TI "Fun f T"]
                 intruder_synth.AxiomC[of "Fun f T" "timpl_closure_set (set M) (set TI)"]
           by blast
       next
         case False
         hence "public f" "length T = arity f" "list_all (intruder_synth_mod_timpls' M TI) T"
           using "2.prems" list_ex_iff[of _ M] by force+
         thus ?thesis
           using "2.IH"[of _ M TI] list_all_iff[of "intruder_synth_mod_timpls' M TI" T]
           by force
       qed
     qed
   
     show "?B t \<Longrightarrow> ?A t"
     proof (induction t rule: intruder_synth_induct)
       case (AxiomC t) thus ?case
         using AxiomC timpl_closure_set_Var_in_iff[of _ "set M" "set TI"] *[of "set M" TI t]
               list_ex_iff[of _ M] List.member_def[of M]
         by (cases t rule: term.exhaust) force+
     next
       case (ComposeC T f) thus ?case
         using list_all_iff[of "intruder_synth_mod_timpls' M TI" T]
               intruder_synth_mod_timpls'.simps(2)[of M TI f T]
         by blast
     qed
   qed
 qed
 
 lemma intruder_synth_mod_eq_timpls_is_synth_timpl_closure_set:
   fixes t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term" and TI
   defines "cl \<equiv> \<lambda>TI. {(a,b) \<in> TI\<^sup>+. a \<noteq> b}"
   shows (* "set TI' = (set TI)\<^sup>+ \<Longrightarrow>
          intruder_synth_mod_eq_timpls M TI' t \<longleftrightarrow>
          (\<exists>s \<in> timpl_closure t (set TI). timpl_closure_set M (set TI) \<turnstile>\<^sub>c s)"
       (is "?P TI TI' \<Longrightarrow> ?A t \<longleftrightarrow> ?B t")
     and *) "set TI' = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b} \<Longrightarrow>
          intruder_synth_mod_eq_timpls M TI' t \<longleftrightarrow>
          (\<exists>s \<in> timpl_closure t (set TI). timpl_closure_set M (set TI) \<turnstile>\<^sub>c s)"
       (is "?Q TI TI' \<Longrightarrow> ?C t \<longleftrightarrow> ?D t")
 proof -
   (* have *: "(\<exists>m \<in> M. equal_mod_timpls TI' m t) \<longleftrightarrow>
            (\<exists>s \<in> timpl_closure t (set TI). s \<in> timpl_closure_set M (set TI))"
     when P: "?P TI TI'"
     for M TI TI' and t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term"
     using equal_mod_timpls_iff_ex_in_timpl_closure'[OF P]
           timpl_closure_set_is_timpl_closure_union[of M "set TI"]
           timpl_closure_set_timpls_trancl_eq[of M "set TI"]
     by blast *)
 
   have **: "(\<exists>m \<in> M. equal_mod_timpls TI' m t) \<longleftrightarrow>
             (\<exists>s \<in> timpl_closure t (set TI). s \<in> timpl_closure_set M (set TI))"
     when Q: "?Q TI TI'"
     for M TI TI' and t::"(('fun,'atom,'sets,'lbl) prot_fun, 'a) term"
     using equal_mod_timpls_iff_ex_in_timpl_closure[OF Q]
           timpl_closure_set_is_timpl_closure_union[of M "set TI"]
           timpl_closure_set_timpls_trancl_eq'[of M "set TI"]
     by fastforce
 
 (*   show "?A t \<longleftrightarrow> ?B t" when P: "?P TI TI'"
   proof
     show "?A t \<Longrightarrow> ?B t"
     proof (induction t arbitrary: M TI rule: intruder_synth_mod_eq_timpls.induct)
       case (1 M TI x)
       hence "Var x \<in> timpl_closure_set M TI" "Var x \<in> timpl_closure (Var x) TI"
         using timpl_closure.FP unfolding timpl_closure_set_def by auto
       thus ?case by force
     next
       case (2 M TI f T)
       show ?case
       proof (cases "\<exists>m \<in> M. equal_mod_timpls (TI\<^sup>+) m (Fun f T)")
         case True thus ?thesis
           using "2.prems" *[of M TI "Fun f T"] intruder_synth.AxiomC[of _ "timpl_closure_set M TI"]
           by blast
       next
         case False
         hence f: "public f" "length T = arity f" "list_all (intruder_synth_mod_eq_timpls M (TI\<^sup>+)) T"
           using "2.prems" by force+
   
         let ?sy = "intruder_synth (timpl_closure_set M TI)"
 
         have IH: "\<exists>u \<in> timpl_closure (T ! i) TI. ?sy u"
           when i: "i < length T" for i
           using "2.IH"[of _ M TI] f(3) nth_mem[OF i]
           unfolding list_all_iff by blast
   
         define S where "S \<equiv> map (\<lambda>u. SOME v. v \<in> timpl_closure u TI \<and> ?sy v) T"
   
         have S1: "length T = length S"
           unfolding S_def by simp
   
         have S2: "S ! i \<in> timpl_closure (T ! i) TI"
                  "timpl_closure_set M TI \<turnstile>\<^sub>c S ! i"
           when i: "i < length S" for i
           using i IH someI_ex[of "\<lambda>v. v \<in> timpl_closure (T ! i) TI \<and> ?sy v"]
           unfolding S_def by auto
   
         have "Fun f S \<in> timpl_closure (Fun f T) TI"
           using timpl_closure_FunI[of T S TI f f] S1 S2(1)
           unfolding timpl_closure_is_timpl_closure' by presburger
         thus ?thesis
           by (metis intruder_synth.ComposeC[of S f] f(1,2) S1 S2(2) in_set_conv_nth[of _ S])
       qed
     qed
   
     show "?A t" when B: "?B t"
     proof -
       obtain s where "timpl_closure_set M TI \<turnstile>\<^sub>c s" "s \<in> timpl_closure t TI"
-        using B by moura
+        using B by blast
       thus ?thesis
       proof (induction s arbitrary: t rule: intruder_synth_induct)
         case (AxiomC s t)
         note 1 = timpl_closure_set_Var_in_iff[of _ M TI] timpl_closure_Var_inv[of s _ TI]
         note 2 = *[of M TI]
         show ?case
         proof (cases t)
           case Var thus ?thesis using 1 AxiomC by auto
         next
           case Fun thus ?thesis using 2 AxiomC by auto
         qed
       next
         case (ComposeC T f t)
         obtain g S where gS:
             "t = Fun g S" "length S = length T"
             "\<forall>i < length T. T ! i \<in> timpl_closure (S ! i) TI"
             "g \<noteq> f \<Longrightarrow> is_Abs g \<and> is_Abs f \<and> (the_Abs g, the_Abs f) \<in> TI\<^sup>+"
           using ComposeC.prems(1) timpl_closure'_inv'[of t "Fun f T" TI]
                 timpl_closure_is_timpl_closure'[of _ _ TI]
           by fastforce
   
         have IH: "intruder_synth_mod_eq_timpls M (TI\<^sup>+) u" when u: "u \<in> set S" for u
           by (metis u gS(2,3) ComposeC.IH in_set_conv_nth)
   
         note 0 = list_all_iff[of "intruder_synth_mod_eq_timpls M (TI\<^sup>+)" S]
                  intruder_synth_mod_eq_timpls.simps(2)[of M "TI\<^sup>+" g S]
   
         have "f = g" using ComposeC.hyps gS(4) unfolding is_Abs_def by fastforce
         thus ?case by (metis ComposeC.hyps(1,2) gS(1,2) IH 0)
       qed
     qed
   qed *)
 
   show "?C t \<longleftrightarrow> ?D t" when Q: "?Q TI TI'"
   proof
     show "?C t \<Longrightarrow> ?D t" using Q
     proof (induction t arbitrary: M TI rule: intruder_synth_mod_eq_timpls.induct)
       case (1 M TI' x M TI)
       hence "Var x \<in> timpl_closure_set M (set TI)" "Var x \<in> timpl_closure (Var x) (set TI)"
         using timpl_closure.FP unfolding timpl_closure_set_def by auto
       thus ?case by force
     next
       case (2 M TI' f T M TI)
       show ?case
       proof (cases "\<exists>m \<in> M. equal_mod_timpls TI' m (Fun f T)")
         case True thus ?thesis
           using **[OF "2.prems"(2), of M "Fun f T"]
                 intruder_synth.AxiomC[of _ "timpl_closure_set M (set TI)"]
           by blast
       next
         case False
         hence f: "public f" "length T = arity f" "list_all (intruder_synth_mod_eq_timpls M TI') T"
           using "2.prems" by force+
   
         let ?sy = "intruder_synth (timpl_closure_set M (set TI))"
 
         have IH: "\<exists>u \<in> timpl_closure (T ! i) (set TI). ?sy u"
           when i: "i < length T" for i
           using "2.IH"[of _ M TI] f(3) nth_mem[OF i] "2.prems"(2)
           unfolding list_all_iff by blast
   
         define S where "S \<equiv> map (\<lambda>u. SOME v. v \<in> timpl_closure u (set TI) \<and> ?sy v) T"
   
         have S1: "length T = length S"
           unfolding S_def by simp
   
         have S2: "S ! i \<in> timpl_closure (T ! i) (set TI)"
                   "timpl_closure_set M (set TI) \<turnstile>\<^sub>c S ! i"
           when i: "i < length S" for i
           using i IH someI_ex[of "\<lambda>v. v \<in> timpl_closure (T ! i) (set TI) \<and> ?sy v"]
           unfolding S_def by auto
   
         have "Fun f S \<in> timpl_closure (Fun f T) (set TI)"
           using timpl_closure_FunI[of T S "set TI" f f] S1 S2(1)
           unfolding timpl_closure_is_timpl_closure' by presburger
         thus ?thesis
           by (metis intruder_synth.ComposeC[of S f] f(1,2) S1 S2(2) in_set_conv_nth[of _ S])
       qed
     qed
   
     show "?C t" when D: "?D t"
     proof -
       obtain s where "timpl_closure_set M (set TI) \<turnstile>\<^sub>c s" "s \<in> timpl_closure t (set TI)"
-        using D by moura
+        using D by blast
       thus ?thesis
       proof (induction s arbitrary: t rule: intruder_synth_induct)
         case (AxiomC s t)
         note 1 = timpl_closure_set_Var_in_iff[of _ M "set TI"] timpl_closure_Var_inv[of s _ "set TI"]
         note 2 = **[OF Q, of M]
         show ?case
         proof (cases t)
           case Var thus ?thesis using 1 AxiomC by auto
         next
           case Fun thus ?thesis using 2 AxiomC by auto
         qed
       next
         case (ComposeC T f t)
         obtain g S where gS:
             "t = Fun g S" "length S = length T"
             "\<forall>i < length T. T ! i \<in> timpl_closure (S ! i) (set TI)"
             "g \<noteq> f \<Longrightarrow> is_Abs g \<and> is_Abs f \<and> (the_Abs g, the_Abs f) \<in> (set TI)\<^sup>+"
           using ComposeC.prems(1) timpl_closure'_inv'[of t "Fun f T" "set TI"]
                 timpl_closure_is_timpl_closure'[of _ _ "set TI"]
           by fastforce
   
         have IH: "intruder_synth_mod_eq_timpls M TI' u" when u: "u \<in> set S" for u
           by (metis u gS(2,3) ComposeC.IH in_set_conv_nth)
   
         note 0 = list_all_iff[of "intruder_synth_mod_eq_timpls M TI'" S]
                  intruder_synth_mod_eq_timpls.simps(2)[of M TI' g S]
   
         have "f = g" using ComposeC.hyps gS(4) unfolding is_Abs_def by fastforce
         thus ?case by (metis ComposeC.hyps(1,2) gS(1,2) IH 0)
       qed
     qed
   qed
 qed
 
 lemma timpl_closure_finite:
   assumes t: "wf\<^sub>t\<^sub>r\<^sub>m t"
   shows "finite (timpl_closure t (set TI))"
 using timpls_transformable_to'_iff_in_timpl_closure[of TI t]
       timpls_transformable_to_finite[OF t, of TI]
 by auto
 
 lemma timpl_closure_set_finite:
   fixes TI::"('sets set \<times> 'sets set) list"
   assumes M_finite: "finite M"
     and M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M"
   shows "finite (timpl_closure_set M (set TI))"
 using timpl_closure_set_is_timpl_closure_union[of M "set TI"]
       timpl_closure_finite[of _ TI] M_finite M_wf finite
 by auto
 
 lemma comp_timpl_closure_is_timpl_closure_set:
   fixes M and TI::"('sets set \<times> 'sets set) list"
   assumes M_finite: "finite M"
     and M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s M"
   shows "comp_timpl_closure M (set TI) = timpl_closure_set M (set TI)"
 using lfp_while''[OF timpls_Un_mono[of M "set TI"]]
       timpl_closure_set_finite[OF M_finite M_wf]
       timpl_closure_set_lfp[of M "set TI"]
 unfolding comp_timpl_closure_def Let_def by presburger
 
 context
 begin
 
 private lemma analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux1:
   fixes M::"('fun,'atom,'sets,'lbl) prot_terms"
   assumes f: "arity\<^sub>f f = length T" "arity\<^sub>f f > 0" "Ana\<^sub>f f = (K, R)"
     and i: "i < length R"
     and M: "timpl_closure_set M TI \<turnstile>\<^sub>c T ! (R ! i)"
     and m: "Fun (Fu f) T \<in> M"
     and t: "Fun (Fu f) S \<in> timpl_closure (Fun (Fu f) T) TI"
   shows "timpl_closure_set M TI \<turnstile>\<^sub>c S ! (R ! i)"
 proof -
   have "R ! i < length T" using i Ana\<^sub>f_assm2_alt[OF f(3)] f(1) by simp
   thus ?thesis
     using timpl_closure_Fun_inv'(1,2)[OF t] intruder_synth_timpl_closure'[OF M]
     by presburger
 qed
 
 private lemma analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux2:
   fixes M::"('fun,'atom,'sets,'lbl) prot_terms"
   assumes M: "\<forall>s \<in> set (snd (Ana m)). timpl_closure_set M TI \<turnstile>\<^sub>c s"
     and m: "m \<in> M"
     and t: "t \<in> timpl_closure m TI"
     and s: "s \<in> set (snd (Ana t))"
   shows "timpl_closure_set M TI \<turnstile>\<^sub>c s"
 proof -
   obtain f S K N where fS: "t = Fun (Fu f) S" "arity\<^sub>f f = length S" "0 < arity\<^sub>f f"
       and Ana_f: "Ana\<^sub>f f = (K, N)"
       and Ana_t: "Ana t = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) S, map ((!) S) N)"
     using Ana_nonempty_inv[of t] s by fastforce
   then obtain T where T: "m = Fun (Fu f) T" "length T = length S"
     using t timpl_closure_Fu_inv'[of f S m TI]
-    by moura
+    by blast
   hence Ana_m: "Ana m = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t (!) T, map ((!) T) N)"
     using fS(2,3) Ana_f by auto
 
   obtain i where i: "i < length N" "s = S ! (N ! i)"
     using s[unfolded fS(1)] Ana_t[unfolded fS(1)] T(2)
           in_set_conv_nth[of s "map (\<lambda>i. S ! i) N"]
     by auto
   hence "timpl_closure_set M TI \<turnstile>\<^sub>c T ! (N ! i)"
     using M[unfolded T(1)] Ana_m[unfolded T(1)] T(2)
     by simp
   thus ?thesis
     using analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux1[
             OF fS(2)[unfolded T(2)[symmetric]] fS(3) Ana_f
                i(1) _ m[unfolded T(1)] t[unfolded fS(1) T(1)]]
           i(2)
     by argo
 qed
 
 lemma analyzed_closed_mod_timpls_is_analyzed_timpl_closure_set:
   fixes M::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes TI': "set TI' = {(a,b) \<in> (set TI)\<^sup>+. a \<noteq> b}"
     and M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)"
   shows "analyzed_closed_mod_timpls M TI' \<longleftrightarrow> analyzed (timpl_closure_set (set M) (set TI))"
     (is "?A \<longleftrightarrow> ?B")
 proof
   let ?C = "\<forall>t \<in> timpl_closure_set (set M) (set TI).
               analyzed_in t (timpl_closure_set (set M) (set TI))"
 
   let ?P = "\<lambda>T. \<forall>t \<in> set T. timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c t"
   let ?Q = "\<lambda>t. \<forall>s \<in> comp_timpl_closure {t} (set TI'). case Ana s of (K, R) \<Rightarrow> ?P K \<longrightarrow> ?P R"
   let ?W = "\<lambda>t. \<forall>t \<in> set (fst (Ana t)). \<forall>f \<in> funs_term t. \<not>is_Abs f"
   let ?V = "\<lambda>t. \<forall>s \<in> comp_timpl_closure (set (fst (Ana t))) (set TI').
                   \<not>timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c s"
   
   note defs = analyzed_closed_mod_timpls_def analyzed_in_code
   note 0 = intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI', of M]
   note 1 = timpl_closure_set_is_timpl_closure_union[of _ "set TI"]
 
   have 2: "comp_timpl_closure N (set TI') = timpl_closure_set N (set TI)"
     when "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s N" "finite N" for N::"('fun,'atom,'sets,'lbl) prot_terms"
     using that timpl_closure_set_timpls_trancl_eq'[of N "set TI"]
           comp_timpl_closure_is_timpl_closure_set[of N TI']
     unfolding TI'[symmetric] by presburger
   hence 3: "comp_timpl_closure {t} (set TI') \<subseteq> timpl_closure_set (set M) (set TI)"
     when t: "t \<in> set M" "wf\<^sub>t\<^sub>r\<^sub>m t" for t
     using t timpl_closure_set_mono[of "{t}" "set M"] by simp
 
   have ?A when C: ?C
     unfolding analyzed_closed_mod_timpls_def
               intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI']
               list_all_iff Let_def
   proof (intro ballI)
     fix t assume t: "t \<in> set M"
     show "if ?P (fst (Ana t)) then ?P (snd (Ana t))
           else if ?W t then True
           else if ?V t then True
           else ?Q t" (is ?R)
     proof (cases "?P (fst (Ana t))")
       case True
       hence "?P (snd (Ana t))"
         using C timpl_closure_setI[OF t, of "set TI"] prod.exhaust_sel
         unfolding analyzed_in_def by blast
       thus ?thesis using True by simp
     next
       case False
       have "?Q t" using 3[OF t] C M_wf t unfolding analyzed_in_def by auto
       thus ?thesis using False by argo
     qed
   qed
   thus ?A when B: ?B using B analyzed_is_all_analyzed_in by metis
 
   have ?C when A: ?A unfolding analyzed_in_def Let_def
   proof (intro ballI allI impI; elim conjE)
     fix t K T s
     assume t: "t \<in> timpl_closure_set (set M) (set TI)"
       and s: "s \<in> set T"
       and Ana_t: "Ana t = (K, T)"
       and K: "\<forall>k \<in> set K. timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c k"
 
     obtain m where m: "m \<in> set M" "t \<in> timpl_closure m (set TI)"
-      using timpl_closure_set_is_timpl_closure_union t by moura
+      using timpl_closure_set_is_timpl_closure_union t by blast
 
     show "timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c s"
     proof (cases "\<forall>k \<in> set (fst (Ana m)). timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c k")
       case True
       hence *: "\<forall>r \<in> set (snd (Ana m)). timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c r"
         using m(1) A
         unfolding analyzed_closed_mod_timpls_def
                   intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI']
                   list_all_iff Let_def
         by simp
 
       show ?thesis
         using K s Ana_t A
               analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux2[OF * m]
         by simp
     next
       case False
       note F = this
 
       have *: "comp_timpl_closure {m} (set TI') = timpl_closure m (set TI)"
         using 2[of "{m}"] timpl_closureton_is_timpl_closure M_wf m(1)
         by blast
 
       have "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set (fst (Ana m)))"
         using Ana_keys_wf'[of m "fst (Ana m)"] M_wf m(1) surj_pair[of "Ana m"] by fastforce
       hence **: "comp_timpl_closure (set (fst (Ana m))) (set TI') =
                    timpl_closure_set (set (fst (Ana m))) (set TI)"
         using 2[of "set (fst (Ana m))"] by blast
 
       have ***: "set K \<subseteq> timpl_closure_set (set (fst (Ana m))) (set TI)"
                 "length K = length (fst (Ana m))"
         using timpl_closure_Ana_keys_subset[OF m(2) _ Ana_t]
               timpl_closure_Ana_keys_length_eq[OF m(2) _ Ana_t]
               surj_pair[of "Ana m"]
         by fastforce+
 
       show ?thesis
       proof (cases "?W m")
         case True
         hence "fst (Ana t) = fst (Ana m)" using m timpl_closure_Ana_keys_no_Abs_eq_case by fast
         thus ?thesis using F K Ana_t by simp
       next
         case False
         note F' = this
 
         show ?thesis
         proof (cases "?V m")
           case True
           hence "\<forall>k \<in> set K. \<not>timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c k"
             using F K Ana_t m s *** unfolding ** by blast
           thus ?thesis using K F' *** by simp
         next
           case False
           hence "?Q m"
             using m(1) A F F'
             unfolding analyzed_closed_mod_timpls_def
                       intruder_synth_mod_timpls_is_synth_timpl_closure_set[OF TI']
                       list_all_iff Let_def
             by auto
           thus ?thesis
             using * m(2) K s Ana_t
             unfolding Let_def by auto
         qed
       qed
     qed
   qed
   thus ?B when A: ?A using A analyzed_is_all_analyzed_in by metis
 qed
 
 lemma analyzed_closed_mod_timpls'_is_analyzed_timpl_closure_set:
   fixes M::"('fun,'atom,'sets,'lbl) prot_term list"
   assumes M_wf: "wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (set M)"
   shows "analyzed_closed_mod_timpls' M TI \<longleftrightarrow> analyzed (timpl_closure_set (set M) (set TI))"
     (is "?A \<longleftrightarrow> ?B")
 proof
   let ?C = "\<forall>t \<in> timpl_closure_set (set M) (set TI). analyzed_in t (timpl_closure_set (set M) (set TI))"
 
   let ?P = "\<lambda>T. \<forall>t \<in> set T. timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c t"
   let ?Q = "\<lambda>t. \<forall>s \<in> comp_timpl_closure {t} (set TI). case Ana s of (K, R) \<Rightarrow> ?P K \<longrightarrow> ?P R"
   let ?W = "\<lambda>t. \<forall>t \<in> set (fst (Ana t)). \<forall>f \<in> funs_term t. \<not>is_Abs f"
   
   note defs = analyzed_closed_mod_timpls'_def analyzed_in_code
   note 0 = intruder_synth_mod_timpls'_is_synth_timpl_closure_set[of M TI]
   note 1 = timpl_closure_set_is_timpl_closure_union[of _ "set TI"]
 
   have 2: "comp_timpl_closure {t} (set TI) = timpl_closure_set {t} (set TI)"
     when t: "t \<in> set M" "wf\<^sub>t\<^sub>r\<^sub>m t" for t
     using t timpl_closure_set_timpls_trancl_eq[of "{t}" "set TI"]
           comp_timpl_closure_is_timpl_closure_set[of "{t}"]
     by blast
   hence 3: "comp_timpl_closure {t} (set TI) \<subseteq> timpl_closure_set (set M) (set TI)"
     when t: "t \<in> set M" "wf\<^sub>t\<^sub>r\<^sub>m t" for t
     using t timpl_closure_set_mono[of "{t}" "set M"]
     by fast
 
   have ?A when C: ?C
     unfolding analyzed_closed_mod_timpls'_def
               intruder_synth_mod_timpls'_is_synth_timpl_closure_set
               list_all_iff Let_def
   proof (intro ballI)
     fix t assume t: "t \<in> set M"
     show "if ?P (fst (Ana t)) then ?P (snd (Ana t)) else if ?W t then True else ?Q t" (is ?R)
     proof (cases "?P (fst (Ana t))")
       case True
       hence "?P (snd (Ana t))"
         using C timpl_closure_setI[OF t, of "set TI"] prod.exhaust_sel
         unfolding analyzed_in_def by blast
       thus ?thesis using True by simp
     next
       case False
       have "?Q t" using 3[OF t] C M_wf t unfolding analyzed_in_def by auto
       thus ?thesis using False by argo
     qed
   qed
   thus ?A when B: ?B using B analyzed_is_all_analyzed_in by metis
 
   have ?C when A: ?A unfolding analyzed_in_def Let_def
   proof (intro ballI allI impI; elim conjE)
     fix t K T s
     assume t: "t \<in> timpl_closure_set (set M) (set TI)"
       and s: "s \<in> set T"
       and Ana_t: "Ana t = (K, T)"
       and K: "\<forall>k \<in> set K. timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c k"
 
     obtain m where m: "m \<in> set M" "t \<in> timpl_closure m (set TI)"
-      using timpl_closure_set_is_timpl_closure_union t by moura
+      using timpl_closure_set_is_timpl_closure_union t by blast
 
     show "timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c s"
     proof (cases "\<forall>k \<in> set (fst (Ana m)). timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c k")
       case True
       hence *: "\<forall>r \<in> set (snd (Ana m)). timpl_closure_set (set M) (set TI) \<turnstile>\<^sub>c r"
         using m(1) A
         unfolding analyzed_closed_mod_timpls'_def
                   intruder_synth_mod_timpls'_is_synth_timpl_closure_set
                   list_all_iff
         by simp
 
       show ?thesis
         using K s Ana_t A
               analyzed_closed_mod_timpls_is_analyzed_closed_timpl_closure_set_aux2[OF * m]
         by simp
     next
       case False
       note F = this
 
       have *: "comp_timpl_closure {m} (set TI) = timpl_closure m (set TI)"
         using 2[OF m(1)] timpl_closureton_is_timpl_closure M_wf m(1)
         by blast
 
       show ?thesis
       proof (cases "?W m")
         case True
         hence "fst (Ana t) = fst (Ana m)" using m timpl_closure_Ana_keys_no_Abs_eq_case by fast
         thus ?thesis using F K Ana_t by simp
       next
         case False
         hence "?Q m"
           using m(1) A F
           unfolding analyzed_closed_mod_timpls'_def
                     intruder_synth_mod_timpls'_is_synth_timpl_closure_set
                     list_all_iff Let_def
           by auto 
         thus ?thesis
           using * m(2) K s Ana_t
           unfolding Let_def by auto
       qed
     qed
   qed
   thus ?B when A: ?A using A analyzed_is_all_analyzed_in by metis
 qed
 
 end
 
 end
 
 end
diff --git a/thys/Automated_Stateful_Protocol_Verification/Term_Variants.thy b/thys/Automated_Stateful_Protocol_Verification/Term_Variants.thy
--- a/thys/Automated_Stateful_Protocol_Verification/Term_Variants.thy
+++ b/thys/Automated_Stateful_Protocol_Verification/Term_Variants.thy
@@ -1,424 +1,424 @@
 (*  Title:      Term_Variants.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\<open>Term Variants\<close>
 theory Term_Variants
   imports Stateful_Protocol_Composition_and_Typing.Intruder_Deduction
 begin
 
 fun term_variants where
   "term_variants P (Var x) = [Var x]"
 | "term_variants P (Fun f T) = (
   let S = product_lists (map (term_variants P) T)
   in map (Fun f) S@concat (map (\<lambda>g. map (Fun g) S) (P f)))"
 
 inductive term_variants_pred for P where
   term_variants_Var:
   "term_variants_pred P (Var x) (Var x)"
 | term_variants_P:
   "\<lbrakk>length T = length S; \<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i); g \<in> set (P f)\<rbrakk>
    \<Longrightarrow> term_variants_pred P (Fun f T) (Fun g S)"
 | term_variants_Fun:
   "\<lbrakk>length T = length S; \<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i)\<rbrakk>
    \<Longrightarrow> term_variants_pred P (Fun f T) (Fun f S)"
 
 lemma term_variants_pred_inv:
   assumes "term_variants_pred P (Fun f T) (Fun h S)"
   shows "length T = length S"
     and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i)"
     and "f \<noteq> h \<Longrightarrow> h \<in> set (P f)"
 using assms by (auto elim: term_variants_pred.cases)
 
 lemma term_variants_pred_inv':
   assumes "term_variants_pred P (Fun f T) t"
   shows "is_Fun t"
     and "length T = length (args t)"
     and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (args t ! i)"
     and "f \<noteq> the_Fun t \<Longrightarrow> the_Fun t \<in> set (P f)"
     and "P \<equiv> (\<lambda>_. [])(g := [h]) \<Longrightarrow> f \<noteq> the_Fun t \<Longrightarrow> f = g \<and> the_Fun t = h"
 using assms by (auto elim: term_variants_pred.cases)
 
 lemma term_variants_pred_inv'':
   assumes "term_variants_pred P t (Fun f T)"
   shows "is_Fun t"
     and "length T = length (args t)"
     and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (args t ! i) (T ! i)"
     and "f \<noteq> the_Fun t \<Longrightarrow> f \<in> set (P (the_Fun t))"
     and "P \<equiv> (\<lambda>_. [])(g := [h]) \<Longrightarrow> f \<noteq> the_Fun t \<Longrightarrow> f = h \<and> the_Fun t = g"
 using assms by (auto elim: term_variants_pred.cases)
 
 lemma term_variants_pred_inv_Var:
   "term_variants_pred P (Var x) t \<longleftrightarrow> t = Var x"
   "term_variants_pred P t (Var x) \<longleftrightarrow> t = Var x"
 by (auto intro: term_variants_Var elim: term_variants_pred.cases)
 
 lemma term_variants_pred_inv_const:
   "term_variants_pred P (Fun c []) t \<longleftrightarrow> ((\<exists>g \<in> set (P c). t = Fun g []) \<or> (t = Fun c []))"
 by (auto intro: term_variants_P term_variants_Fun elim: term_variants_pred.cases)
 
 lemma term_variants_pred_refl: "term_variants_pred P t t"
 by (induct t) (auto intro: term_variants_pred.intros)
 
 lemma term_variants_pred_refl_inv:
   assumes st: "term_variants_pred P s t"
     and P: "\<forall>f. \<forall>g \<in> set (P f). f = g"
   shows "s = t"
   using st P
 proof (induction s t rule: term_variants_pred.induct)
   case (term_variants_Var x) thus ?case by blast
 next
   case (term_variants_P T S g f)
   hence "T ! i = S ! i" when i: "i < length T" for i using i by blast
   hence "T = S" using term_variants_P.hyps(1) by (simp add: nth_equalityI)
   thus ?case using term_variants_P.prems term_variants_P.hyps(3) by fast
 next
   case (term_variants_Fun T S f)
   hence "T ! i = S ! i" when i: "i < length T" for i using i by blast
   hence "T = S" using term_variants_Fun.hyps(1) by (simp add: nth_equalityI)
   thus ?case by fast
 qed
 
 lemma term_variants_pred_const:
   assumes "b \<in> set (P a)"
   shows "term_variants_pred P (Fun a []) (Fun b [])"
 using term_variants_P[of "[]" "[]"] assms by simp
 
 lemma term_variants_pred_const_cases:
   "P a \<noteq> [] \<Longrightarrow> term_variants_pred P (Fun a []) t \<longleftrightarrow>
                  (t = Fun a [] \<or> (\<exists>b \<in> set (P a). t = Fun b []))"
   "P a = [] \<Longrightarrow> term_variants_pred P (Fun a []) t \<longleftrightarrow> t = Fun a []"
 using term_variants_pred_inv_const[of P] by auto
 
 lemma term_variants_pred_param:
   assumes "term_variants_pred P t s"
     and fg: "f = g \<or> g \<in> set (P f)"
   shows "term_variants_pred P (Fun f (S@t#T)) (Fun g (S@s#T))"
 proof -
   have 1: "length (S@t#T) = length (S@s#T)" by simp
   
   have "term_variants_pred P (T ! i) (T ! i)" "term_variants_pred P (S ! i) (S ! i)" for i
     by (metis term_variants_pred_refl)+
   hence 2: "term_variants_pred P ((S@t#T) ! i) ((S@s#T) ! i)" for i
     by (simp add: assms nth_Cons' nth_append)
 
   show ?thesis by (metis term_variants_Fun[OF 1 2] term_variants_P[OF 1 2] fg)
 qed
 
 lemma term_variants_pred_Cons:
   assumes t: "term_variants_pred P t s"
     and T: "term_variants_pred P (Fun f T) (Fun f S)"
     and fg: "f = g \<or> g \<in> set (P f)"
   shows "term_variants_pred P (Fun f (t#T)) (Fun g (s#S))"
 proof -
   have 1: "length (t#T) = length (s#S)"
        and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i)"
     using term_variants_pred_inv[OF T] by simp_all
   hence 2: "\<And>i. i < length (t#T) \<Longrightarrow> term_variants_pred P ((t#T) ! i) ((s#S) ! i)"
     by (metis t One_nat_def diff_less length_Cons less_Suc_eq less_imp_diff_less nth_Cons'
               zero_less_Suc) 
 
   show ?thesis using 1 2 fg by (auto intro: term_variants_pred.intros)
 qed
 
 lemma term_variants_pred_dense:
   fixes P Q::"'a set" and fs gs::"'a list"
   defines "P_fs x \<equiv> if x \<in> P then fs else []"
     and "P_gs x \<equiv> if x \<in> P then gs else []"
     and "Q_fs x \<equiv> if x \<in> Q then fs else []"
   assumes ut: "term_variants_pred P_fs u t"
     and g: "g \<in> Q" "g \<in> set gs"
   shows "\<exists>s. term_variants_pred P_gs u s \<and> term_variants_pred Q_fs s t"
 proof -
   define F where "F \<equiv> \<lambda>(P::'a set) (fs::'a list) x. if x \<in> P then fs else []"
 
   show ?thesis using ut g P_fs_def unfolding P_gs_def Q_fs_def
   proof (induction u t arbitrary: g gs rule: term_variants_pred.induct)
     case (term_variants_Var h x) thus ?case
       by (auto intro: term_variants_pred.term_variants_Var)
   next
     case (term_variants_P T S h' h g gs)
     note hyps = term_variants_P.hyps(1,2,4,5,6,7)
     note IH = term_variants_P.hyps(3)
 
     have "\<exists>s. term_variants_pred (F P gs) (T ! i) s \<and> term_variants_pred (F Q fs) s (S ! i)"
       when i: "i < length T" for i
       using IH[OF i hyps(4,5,6)] unfolding F_def by presburger
     then obtain U where U:
         "length T = length U" "\<And>i. i < length T \<Longrightarrow> term_variants_pred (F P gs) (T ! i) (U ! i)"
         "length U = length S" "\<And>i. i < length U \<Longrightarrow> term_variants_pred (F Q fs) (U ! i) (S ! i)"
       using hyps(1) Skolem_list_nth[of _ "\<lambda>i s. term_variants_pred (F P gs) (T ! i) s \<and>
                                                 term_variants_pred (F Q fs) s (S ! i)"]
-      by moura
+      by (metis (no_types))
 
     show ?case
       using term_variants_pred.term_variants_P[OF U(1,2), of g h]
             term_variants_pred.term_variants_P[OF U(3,4), of h' g]
             hyps(3)[unfolded hyps(6)] hyps(4,5)
       unfolding F_def by force
   next
     case (term_variants_Fun T S h' g gs)
     note hyps = term_variants_Fun.hyps(1,2,4,5,6)
     note IH = term_variants_Fun.hyps(3)
 
     have "\<exists>s. term_variants_pred (F P gs) (T ! i) s \<and> term_variants_pred (F Q fs) s (S ! i)"
       when i: "i < length T" for i
       using IH[OF i hyps(3,4,5)] unfolding F_def by presburger
     then obtain U where U:
         "length T = length U" "\<And>i. i < length T \<Longrightarrow> term_variants_pred (F P gs) (T ! i) (U ! i)"
         "length U = length S" "\<And>i. i < length U \<Longrightarrow> term_variants_pred (F Q fs) (U ! i) (S ! i)"
       using hyps(1) Skolem_list_nth[of _ "\<lambda>i s. term_variants_pred (F P gs) (T ! i) s \<and>
                                                 term_variants_pred (F Q fs) s (S ! i)"]
-      by moura
+      by (metis (no_types))
     
     thus ?case
       using term_variants_pred.term_variants_Fun[OF U(1,2)]
             term_variants_pred.term_variants_Fun[OF U(3,4)]
       unfolding F_def by meson
   qed
 qed
 
 lemma term_variants_pred_dense':
   assumes ut: "term_variants_pred ((\<lambda>_. [])(a := [b])) u t"
   shows "\<exists>s. term_variants_pred ((\<lambda>_. [])(a := [c])) u s \<and>
              term_variants_pred ((\<lambda>_. [])(c := [b])) s t"
 using ut term_variants_pred_dense[of "{a}" "[b]" u t c "{c}" "[c]"]
 unfolding fun_upd_def by simp
 
 lemma term_variants_pred_eq_case:
   fixes t s::"('a,'b) term"
   assumes "term_variants_pred P t s" "\<forall>f \<in> funs_term t. P f = []"
   shows "t = s"
 using assms
 proof (induction t s rule: term_variants_pred.induct)
   case (term_variants_Fun T S f) thus ?case
     using subtermeq_imp_funs_term_subset[OF Fun_param_in_subterms[OF nth_mem], of _ T f]
           nth_equalityI[of T S]
     by blast
 qed (simp_all add: term_variants_pred_refl)
 
 lemma term_variants_pred_subst:
   assumes "term_variants_pred P t s"
   shows "term_variants_pred P (t \<cdot> \<delta>) (s \<cdot> \<delta>)"
 using assms
 proof (induction t s rule: term_variants_pred.induct)
   case (term_variants_P T S f g)
   have 1: "length (map (\<lambda>t. t \<cdot> \<delta>) T) = length (map (\<lambda>t. t \<cdot> \<delta>) S)"
     using term_variants_P.hyps
     by simp
 
   have 2: "term_variants_pred P ((map (\<lambda>t. t \<cdot> \<delta>) T) ! i) ((map (\<lambda>t. t \<cdot> \<delta>) S) ! i)"
     when "i < length (map (\<lambda>t. t \<cdot> \<delta>) T)" for i
     using term_variants_P that
     by fastforce
 
   show ?case
     using term_variants_pred.term_variants_P[OF 1 2 term_variants_P.hyps(3)]
     by fastforce
 next
   case (term_variants_Fun T S f)
   have 1: "length (map (\<lambda>t. t \<cdot> \<delta>) T) = length (map (\<lambda>t. t \<cdot> \<delta>) S)"
     using term_variants_Fun.hyps
     by simp
 
   have 2: "term_variants_pred P ((map (\<lambda>t. t \<cdot> \<delta>) T) ! i) ((map (\<lambda>t. t \<cdot> \<delta>) S) ! i)"
     when "i < length (map (\<lambda>t. t \<cdot> \<delta>) T)" for i
     using term_variants_Fun that
     by fastforce
 
   show ?case
     using term_variants_pred.term_variants_Fun[OF 1 2]
     by fastforce
 qed (simp add: term_variants_pred_refl)
 
 lemma term_variants_pred_subst':
   fixes t s::"('a,'b) term" and \<delta>::"('a,'b) subst"
   assumes "term_variants_pred P (t \<cdot> \<delta>) s"
     and "\<forall>x \<in> fv t \<union> fv s. (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> P f = [])"
   shows "\<exists>u. term_variants_pred P t u \<and> s = u \<cdot> \<delta>"
 using assms
 proof (induction "t \<cdot> \<delta>" s arbitrary: t rule: term_variants_pred.induct)
   case (term_variants_Var x g) thus ?case using term_variants_pred_refl by fast
 next
   case (term_variants_P T S g f) show ?case
   proof (cases t)
     case (Var x) thus ?thesis
       using term_variants_P.hyps(4,5) term_variants_P.prems
       by fastforce
   next
     case (Fun h U)
     hence 1: "h = f" "T = map (\<lambda>s. s \<cdot> \<delta>) U" "length U = length T"
       using term_variants_P.hyps(5) by simp_all
     hence 2: "T ! i = U ! i \<cdot> \<delta>" when "i < length T" for i
       using that by simp
 
     have "\<forall>x \<in> fv (U ! i) \<union> fv (S ! i). (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> P f = [])"
       when "i < length U" for i
       using that Fun term_variants_P.prems term_variants_P.hyps(1) 1(3)
       by force
     hence IH: "\<forall>i < length U. \<exists>u. term_variants_pred P (U ! i) u \<and> S ! i = u \<cdot> \<delta>"
       by (metis 1(3) term_variants_P.hyps(3)[OF _ 2])
 
     have "\<exists>V. length U = length V \<and> S = map (\<lambda>v. v \<cdot> \<delta>) V \<and>
                (\<forall>i < length U. term_variants_pred P (U ! i) (V ! i))"
       using term_variants_P.hyps(1) 1(3) subst_term_list_obtain[OF IH] by metis
     then obtain V where V: "length U = length V" "S = map (\<lambda>v. v \<cdot> \<delta>) V"
                            "\<And>i. i < length U \<Longrightarrow> term_variants_pred P (U ! i) (V ! i)"
-      by moura
+      by blast
 
     have "term_variants_pred P (Fun f U) (Fun g V)"
       by (metis term_variants_pred.term_variants_P[OF V(1,3) term_variants_P.hyps(4)])
     moreover have "Fun g S = Fun g V \<cdot> \<delta>" using V(2) by simp
     ultimately show ?thesis using term_variants_P.hyps(1,4) Fun 1 by blast
   qed
 next
   case (term_variants_Fun T S f t) show ?case
   proof (cases t)
     case (Var x)
     hence "T = []" "P f = []" using term_variants_Fun.hyps(4) term_variants_Fun.prems by fastforce+
     thus ?thesis using term_variants_pred_refl Var term_variants_Fun.hyps(1,4) by fastforce
   next
     case (Fun h U)
     hence 1: "h = f" "T = map (\<lambda>s. s \<cdot> \<delta>) U" "length U = length T"
       using term_variants_Fun.hyps(4) by simp_all
     hence 2: "T ! i = U ! i \<cdot> \<delta>" when "i < length T" for i
       using that by simp
 
     have "\<forall>x \<in> fv (U ! i) \<union> fv (S ! i). (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> P f = [])"
       when "i < length U" for i
       using that Fun term_variants_Fun.prems term_variants_Fun.hyps(1) 1(3)
       by force
     hence IH: "\<forall>i < length U. \<exists>u. term_variants_pred P (U ! i) u \<and> S ! i = u \<cdot> \<delta>"
       by (metis 1(3) term_variants_Fun.hyps(3)[OF _ 2 ])
 
     have "\<exists>V. length U = length V \<and> S = map (\<lambda>v. v \<cdot> \<delta>) V \<and>
                (\<forall>i < length U. term_variants_pred P (U ! i) (V ! i))"
       using term_variants_Fun.hyps(1) 1(3) subst_term_list_obtain[OF IH] by metis
     then obtain V where V: "length U = length V" "S = map (\<lambda>v. v \<cdot> \<delta>) V"
                            "\<And>i. i < length U \<Longrightarrow> term_variants_pred P (U ! i) (V ! i)"
-      by moura
+      by blast
 
     have "term_variants_pred P (Fun f U) (Fun f V)"
       by (metis term_variants_pred.term_variants_Fun[OF V(1,3)])
     moreover have "Fun f S = Fun f V \<cdot> \<delta>" using V(2) by simp
     ultimately show ?thesis using term_variants_Fun.hyps(1) Fun 1 by blast
   qed
 qed
 
 lemma term_variants_pred_subst'':
   assumes "\<forall>x \<in> fv t. term_variants_pred P (\<delta> x) (\<theta> x)"
   shows "term_variants_pred P (t \<cdot> \<delta>) (t \<cdot> \<theta>)"
 using assms
 proof (induction t)
   case (Fun f ts) thus ?case
     using term_variants_Fun[of "map (\<lambda>t. t \<cdot> \<delta>) ts" "map (\<lambda>t. t \<cdot> \<theta>) ts" P f] by force
 qed simp
 
 lemma term_variants_pred_iff_in_term_variants:
   fixes t::"('a,'b) term"
   shows "term_variants_pred P t s \<longleftrightarrow> s \<in> set (term_variants P t)"
     (is "?A t s \<longleftrightarrow> ?B t s")
 proof
   define U where "U \<equiv> \<lambda>P (T::('a,'b) term list). product_lists (map (term_variants P) T)"
 
   have a:
       "g \<in> set (P f) \<Longrightarrow> set (map (Fun g) (U P T)) \<subseteq> set (term_variants P (Fun f T))"
       "set (map (Fun f) (U P T)) \<subseteq> set (term_variants P (Fun f T))"
     for f P g and T::"('a,'b) term list"
     using term_variants.simps(2)[of P f T]
     unfolding U_def Let_def by auto
 
   have b: "\<exists>S \<in> set (U P T). s = Fun f S \<or> (\<exists>g \<in> set (P f). s = Fun g S)"
     when "s \<in> set (term_variants P (Fun f T))" for P T f s
     using that by (cases "P f") (auto simp add: U_def Let_def)
 
   have c: "length T = length S" when "S \<in> set (U P T)" for S P T
     using that unfolding U_def
     by (simp add: in_set_product_lists_length)
 
   show "?A t s \<Longrightarrow> ?B t s"
   proof (induction t s rule: term_variants_pred.induct)
     case (term_variants_P T S g f)
     note hyps = term_variants_P.hyps
     note IH = term_variants_P.IH
 
     have "S \<in> set (U P T)"
       using IH hyps(1) product_lists_in_set_nth'[of _ S]
       unfolding U_def by simp
     thus ?case using a(1)[of _ P, OF hyps(3)] by auto
   next
     case (term_variants_Fun T S f)
     note hyps = term_variants_Fun.hyps
     note IH = term_variants_Fun.IH
 
     have "S \<in> set (U P T)"
       using IH hyps(1) product_lists_in_set_nth'[of _ S]
       unfolding U_def by simp
     thus ?case using a(2)[of f P T] by (cases "P f") auto
   qed (simp add: term_variants_Var)
 
   show "?B t s \<Longrightarrow> ?A t s"
   proof (induction P t arbitrary: s rule: term_variants.induct)
     case (2 P f T)
     obtain S where S:
         "s = Fun f S \<or> (\<exists>g \<in> set (P f). s = Fun g S)"
         "S \<in> set (U P T)" "length T = length S"
-      using c b[OF "2.prems"] by moura
+      using c b[OF "2.prems"] by blast
 
     have "\<forall>i < length T. term_variants_pred P (T ! i) (S ! i)"
       using "2.IH" S product_lists_in_set_nth by (fastforce simp add: U_def)
     thus ?case using S by (auto intro: term_variants_pred.intros)
   qed (simp add: term_variants_Var)
 qed
 
 lemma term_variants_pred_finite:
   "finite {s. term_variants_pred P t s}"
 using term_variants_pred_iff_in_term_variants[of P t]
 by simp
 
 lemma term_variants_pred_fv_eq:
   assumes "term_variants_pred P s t"
   shows "fv s = fv t"
 using assms
 by (induct rule: term_variants_pred.induct)
    (metis, metis fv_eq_FunI, metis fv_eq_FunI)
 
 lemma (in intruder_model) term_variants_pred_wf_trms:
   assumes "term_variants_pred P s t"
     and "\<And>f g. g \<in> set (P f) \<Longrightarrow> arity f = arity g"
     and "wf\<^sub>t\<^sub>r\<^sub>m s"
   shows "wf\<^sub>t\<^sub>r\<^sub>m t"
 using assms
 apply (induction rule: term_variants_pred.induct, simp)
 by (metis (no_types) wf_trmI wf_trm_arity in_set_conv_nth wf_trm_param_idx)+
 
 lemma term_variants_pred_funs_term:
   assumes "term_variants_pred P s t"
     and "f \<in> funs_term t"
   shows "f \<in> funs_term s \<or> (\<exists>g \<in> funs_term s. f \<in> set (P g))"
   using assms
 proof (induction rule: term_variants_pred.induct)
   case (term_variants_P T S g h) thus ?case
   proof (cases "f = g")
     case False
     then obtain s where "s \<in> set S" "f \<in> funs_term s"
       using funs_term_subterms_eq(1)[of "Fun g S"] term_variants_P.prems by auto
     thus ?thesis
       using term_variants_P.IH term_variants_P.hyps(1) in_set_conv_nth[of s S] by force
   qed simp
 next
   case (term_variants_Fun T S h) thus ?case
   proof (cases "f = h")
     case False
     then obtain s where "s \<in> set S" "f \<in> funs_term s"
       using funs_term_subterms_eq(1)[of "Fun h S"] term_variants_Fun.prems by auto
     thus ?thesis
       using term_variants_Fun.IH term_variants_Fun.hyps(1) in_set_conv_nth[of s S] by force
   qed simp
 qed fast
 
 end
diff --git a/thys/Automated_Stateful_Protocol_Verification/Transactions.thy b/thys/Automated_Stateful_Protocol_Verification/Transactions.thy
--- a/thys/Automated_Stateful_Protocol_Verification/Transactions.thy
+++ b/thys/Automated_Stateful_Protocol_Verification/Transactions.thy
@@ -1,898 +1,898 @@
 (*  Title:      Transactions.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\<open>Protocol Transactions\<close>
 theory Transactions
   imports
     Stateful_Protocol_Composition_and_Typing.Typed_Model
     Stateful_Protocol_Composition_and_Typing.Labeled_Stateful_Strands 
 begin
 
 subsection \<open>Definitions\<close>
 datatype 'b prot_atom =
   is_Atom: Atom 'b
 | Value
 | SetType
 | AttackType
 | Bottom
 | OccursSecType
 | AbsValue
 
 datatype ('a,'b,'c,'d) prot_fun =
   Fu (the_Fu: 'a)
 | Set (the_Set: 'c)
 | Val (the_Val: "nat")
 | Abs (the_Abs: "'c set")
 | Attack (the_Attack_label: "'d strand_label")
 | Pair
 | PubConst (the_PubConst_type: "'b prot_atom") nat
 | OccursFact
 | OccursSec
 
 definition "is_Fun_Set t \<equiv> is_Fun t \<and> args t = [] \<and> is_Set (the_Fun t)"
 
 definition "is_Fun_Attack t \<equiv> is_Fun t \<and> args t = [] \<and> is_Attack (the_Fun t)"
 
 definition "is_PubConstValue f \<equiv> is_PubConst f \<and> the_PubConst_type f = Value"
 
 abbreviation occurs where
   "occurs t \<equiv> Fun OccursFact [Fun OccursSec [], t]"
 
 type_synonym ('a,'b,'c,'d) prot_term_type = "(('a,'b,'c,'d) prot_fun,'b prot_atom) term_type"
 
 type_synonym ('a,'b,'c,'d) prot_var = "('a,'b,'c,'d) prot_term_type \<times> nat"
 
 type_synonym ('a,'b,'c,'d) prot_term = "(('a,'b,'c,'d) prot_fun,('a,'b,'c,'d) prot_var) term"
 type_synonym ('a,'b,'c,'d) prot_terms = "('a,'b,'c,'d) prot_term set"
 
 type_synonym ('a,'b,'c,'d) prot_subst = "(('a,'b,'c,'d) prot_fun, ('a,'b,'c,'d) prot_var) subst"
 
 type_synonym ('a,'b,'c,'d) prot_strand_step =
   "(('a,'b,'c,'d) prot_fun, ('a,'b,'c,'d) prot_var, 'd) labeled_stateful_strand_step"
 type_synonym ('a,'b,'c,'d) prot_strand = "('a,'b,'c,'d) prot_strand_step list"
 type_synonym ('a,'b,'c,'d) prot_constr = "('a,'b,'c,'d) prot_strand_step list"
 
 (* TODO: rename transaction_decl *)
 datatype ('a,'b,'c,'d) prot_transaction =
   Transaction
     (transaction_decl:    "unit \<Rightarrow> (('a,'b,'c,'d) prot_var \<times> 'a set) list")
     (transaction_fresh:   "('a,'b,'c,'d) prot_var list")
     (transaction_receive: "('a,'b,'c,'d) prot_strand")
     (transaction_checks:  "('a,'b,'c,'d) prot_strand")
     (transaction_updates: "('a,'b,'c,'d) prot_strand")
     (transaction_send:    "('a,'b,'c,'d) prot_strand")
 
 definition transaction_strand where
   "transaction_strand T \<equiv>
     transaction_receive T@transaction_checks T@
     transaction_updates T@transaction_send T"
 
 fun transaction_proj where
   "transaction_proj l (Transaction A B C D E F) = (
   let f = proj l
   in Transaction A B (f C) (f D) (f E) (f F))"
 
 fun transaction_star_proj where
   "transaction_star_proj (Transaction A B C D E F) = (
   let f = filter has_LabelS
   in Transaction A B (f C) (f D) (f E) (f F))"
 
 abbreviation fv_transaction where
   "fv_transaction T \<equiv> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)"
 
 abbreviation bvars_transaction where
   "bvars_transaction T \<equiv> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)"
 
 abbreviation vars_transaction where
   "vars_transaction T \<equiv> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)"
 
 abbreviation trms_transaction where
   "trms_transaction T \<equiv> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)"
 
 abbreviation setops_transaction where
   "setops_transaction T \<equiv> setops\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_strand T))"
 
 definition wellformed_transaction where
   "wellformed_transaction T \<equiv>
     list_all is_Receive (unlabel (transaction_receive T)) \<and>
     list_all is_Check_or_Assignment (unlabel (transaction_checks T)) \<and>
     list_all is_Update (unlabel (transaction_updates T)) \<and>
     list_all is_Send (unlabel (transaction_send T)) \<and>
     distinct (map fst (transaction_decl T ())) \<and>
     distinct (transaction_fresh T) \<and>
     set (transaction_fresh T) \<inter> fst ` set (transaction_decl T ()) = {} \<and>
     set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {} \<and>
     set (transaction_fresh T) \<inter> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = {} \<and>
     set (transaction_fresh T) \<inter> bvars_transaction T = {} \<and>
     fv_transaction T \<inter> bvars_transaction T = {} \<and>
     wf'\<^sub>s\<^sub>s\<^sub>t (fst ` set (transaction_decl T ()) \<union> set (transaction_fresh T))
           (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
 
 type_synonym ('a,'b,'c,'d) prot = "('a,'b,'c,'d) prot_transaction list"
 
 abbreviation Var_Value_term ("\<langle>_: value\<rangle>\<^sub>v") where
   "\<langle>n: value\<rangle>\<^sub>v \<equiv> Var (Var Value, n)::('a,'b,'c,'d) prot_term"
 
 abbreviation Var_SetType_term ("\<langle>_: SetType\<rangle>\<^sub>v") where
   "\<langle>n: SetType\<rangle>\<^sub>v \<equiv> Var (Var SetType, n)::('a,'b,'c,'d) prot_term"
 
 abbreviation Var_AttackType_term ("\<langle>_: AttackType\<rangle>\<^sub>v") where
   "\<langle>n: AttackType\<rangle>\<^sub>v \<equiv> Var (Var AttackType, n)::('a,'b,'c,'d) prot_term"
 
 abbreviation Var_Atom_term ("\<langle>_: _\<rangle>\<^sub>v") where
   "\<langle>n: a\<rangle>\<^sub>v \<equiv> Var (Var (Atom a), n)::('a,'b,'c,'d) prot_term"
 
 abbreviation Var_Comp_Fu_term ("\<langle>_: _\<langle>_\<rangle>\<rangle>\<^sub>v") where
   "\<langle>n: f\<langle>T\<rangle>\<rangle>\<^sub>v \<equiv> Var (Fun (Fu f) T, n)::('a,'b,'c,'d) prot_term"
 
 abbreviation TAtom_Atom_term ("\<langle>_\<rangle>\<^sub>\<tau>\<^sub>a") where
   "\<langle>a\<rangle>\<^sub>\<tau>\<^sub>a \<equiv> Var (Atom a)::('a,'b,'c,'d) prot_term_type"
 
 abbreviation TComp_Fu_term ("\<langle>_ _\<rangle>\<^sub>\<tau>") where
   "\<langle>f T\<rangle>\<^sub>\<tau> \<equiv> Fun (Fu f) T::('a,'b,'c,'d) prot_term_type"
 
 abbreviation Fun_Fu_term ("\<langle>_ _\<rangle>\<^sub>t") where
   "\<langle>f T\<rangle>\<^sub>t \<equiv> Fun (Fu f) T::('a,'b,'c,'d) prot_term"
 
 abbreviation Fun_Fu_const_term ("\<langle>_\<rangle>\<^sub>c") where
   "\<langle>c\<rangle>\<^sub>c \<equiv> Fun (Fu c) []::('a,'b,'c,'d) prot_term"
 
 abbreviation Fun_Set_const_term ("\<langle>_\<rangle>\<^sub>s") where
   "\<langle>f\<rangle>\<^sub>s \<equiv> Fun (Set f) []::('a,'b,'c,'d) prot_term"
 
 abbreviation Fun_Set_composed_term ("\<langle>_\<langle>_\<rangle>\<rangle>\<^sub>s") where
   "\<langle>f\<langle>T\<rangle>\<rangle>\<^sub>s \<equiv> Fun (Set f) T::('a,'b,'c,'d) prot_term"
 
 abbreviation Fun_Abs_const_term ("\<langle>_\<rangle>\<^sub>a\<^sub>b\<^sub>s") where
   "\<langle>a\<rangle>\<^sub>a\<^sub>b\<^sub>s \<equiv> Fun (Abs a) []::('a,'b,'c,'d) prot_term"
 
 abbreviation Fun_Attack_const_term ("attack\<langle>_\<rangle>") where
   "attack\<langle>n\<rangle> \<equiv> Fun (Attack n) []::('a,'b,'c,'d) prot_term"
 
 abbreviation prot_transaction1 ("transaction\<^sub>1 _ _ new _ _ _") where
   "transaction\<^sub>1 (S1::('a,'b,'c,'d) prot_strand) S2 new (B::('a,'b,'c,'d) prot_term list) S3 S4
   \<equiv> Transaction (\<lambda>(). []) (map the_Var B) S1 S2 S3 S4"
 
 abbreviation prot_transaction2 ("transaction\<^sub>2 _ _  _ _") where
   "transaction\<^sub>2 (S1::('a,'b,'c,'d) prot_strand) S2 S3 S4
   \<equiv> Transaction (\<lambda>(). []) [] S1 S2 S3 S4"
 
 
 subsection \<open>Lemmata\<close>
 
 lemma prot_atom_UNIV:
   "(UNIV::'b prot_atom set) = range Atom \<union> {Value, SetType, AttackType, Bottom, OccursSecType, AbsValue}"
 proof -
   have "a \<in> range Atom \<or> a = Value \<or> a = SetType \<or> a = AttackType \<or>
         a = Bottom \<or> a = OccursSecType \<or> a = AbsValue"
     for a::"'b prot_atom"
     by (cases a) auto
   thus ?thesis by auto
 qed
 
 instance prot_atom::(finite) finite
 by intro_classes (simp add: prot_atom_UNIV)
 
 instantiation prot_atom::(enum) enum
 begin
 definition "enum_prot_atom == map Atom enum_class.enum@[Value, SetType, AttackType, Bottom, OccursSecType, AbsValue]"
 definition "enum_all_prot_atom P == list_all P (map Atom enum_class.enum@[Value, SetType, AttackType, Bottom, OccursSecType, AbsValue])"
 definition "enum_ex_prot_atom P == list_ex P (map Atom enum_class.enum@[Value, SetType, AttackType, Bottom, OccursSecType, AbsValue])"
 
 instance
 proof intro_classes
   have *: "set (map Atom (enum_class.enum::'a list)) = range Atom"
           "distinct (enum_class.enum::'a list)"
     using UNIV_enum enum_distinct by auto
 
   show "(UNIV::'a prot_atom set) = set enum_class.enum"
     using *(1) by (simp add: prot_atom_UNIV enum_prot_atom_def)
 
   have "set (map Atom enum_class.enum) \<inter> set [Value, SetType, AttackType, Bottom, OccursSecType, AbsValue] = {}" by auto
   moreover have "inj_on Atom (set (enum_class.enum::'a list))" unfolding inj_on_def by auto
   hence "distinct (map Atom (enum_class.enum::'a list))" by (metis *(2) distinct_map)
   ultimately show "distinct (enum_class.enum::'a prot_atom list)" by (simp add: enum_prot_atom_def)
 
   have "Ball UNIV P \<longleftrightarrow> Ball (range Atom) P \<and> Ball {Value, SetType, AttackType, Bottom, OccursSecType, AbsValue} P"
     for P::"'a prot_atom \<Rightarrow> bool"
     by (metis prot_atom_UNIV UNIV_I UnE) 
   thus "enum_class.enum_all P = Ball (UNIV::'a prot_atom set) P" for P
     using *(1) Ball_set[of "map Atom enum_class.enum" P]
     by (auto simp add: enum_all_prot_atom_def)
 
   have "Bex UNIV P \<longleftrightarrow> Bex (range Atom) P \<or> Bex {Value, SetType, AttackType, Bottom, OccursSecType, AbsValue} P"
     for P::"'a prot_atom \<Rightarrow> bool"
     by (metis prot_atom_UNIV UNIV_I UnE) 
   thus "enum_class.enum_ex P = Bex (UNIV::'a prot_atom set) P" for P
     using *(1) Bex_set[of "map Atom enum_class.enum" P]
     by (auto simp add: enum_ex_prot_atom_def)
 qed
 end
 
 lemma wellformed_transaction_cases:
   assumes "wellformed_transaction T"
   shows 
       "(l,x) \<in> set (transaction_receive T) \<Longrightarrow> \<exists>t. x = receive\<langle>t\<rangle>" (is "?A \<Longrightarrow> ?A'")
       "(l,x) \<in> set (transaction_checks T) \<Longrightarrow>
               (\<exists>ac t s. x = \<langle>ac: t \<doteq> s\<rangle>) \<or> (\<exists>ac t s. x = \<langle>ac: t \<in> s\<rangle>) \<or>
               (\<exists>X F G. x = \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>)"
           (is "?B \<Longrightarrow> ?B'")
       "(l,x) \<in> set (transaction_updates T) \<Longrightarrow>
               (\<exists>t s. x = insert\<langle>t,s\<rangle>) \<or> (\<exists>t s. x = delete\<langle>t,s\<rangle>)" (is "?C \<Longrightarrow> ?C'")
       "(l,x) \<in> set (transaction_send T) \<Longrightarrow> \<exists>t. x = send\<langle>t\<rangle>" (is "?D \<Longrightarrow> ?D'")
 proof -
   have a:
       "list_all is_Receive (unlabel (transaction_receive T))"
       "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
       "list_all is_Update (unlabel (transaction_updates T))"
       "list_all is_Send (unlabel (transaction_send T))"
     using assms unfolding wellformed_transaction_def by metis+
 
   note b = Ball_set unlabel_in
   note c = stateful_strand_step.collapse
 
   show "?A \<Longrightarrow> ?A'" by (metis (mono_tags, lifting) a(1) b c(2))
   show "?B \<Longrightarrow> ?B'" by (metis (no_types, lifting) a(2) b c(3,6,7))
   show "?C \<Longrightarrow> ?C'" by (metis (mono_tags, lifting) a(3) b c(4,5))
   show "?D \<Longrightarrow> ?D'" by (metis (mono_tags, lifting) a(4) b c(1))
 qed
 
 lemma wellformed_transaction_unlabel_cases:
   assumes "wellformed_transaction T"
   shows 
       "x \<in> set (unlabel (transaction_receive T)) \<Longrightarrow> \<exists>t. x = receive\<langle>t\<rangle>" (is "?A \<Longrightarrow> ?A'")
       "x \<in> set (unlabel (transaction_checks T)) \<Longrightarrow>
               (\<exists>ac t s. x = \<langle>ac: t \<doteq> s\<rangle>) \<or> (\<exists>ac t s. x = \<langle>ac: t \<in> s\<rangle>) \<or>
               (\<exists>X F G. x = \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>)"
         (is "?B \<Longrightarrow> ?B'")
       "x \<in> set (unlabel (transaction_updates T)) \<Longrightarrow>
               (\<exists>t s. x = insert\<langle>t,s\<rangle>) \<or> (\<exists>t s. x = delete\<langle>t,s\<rangle>)" (is "?C \<Longrightarrow> ?C'")
       "x \<in> set (unlabel (transaction_send T)) \<Longrightarrow> \<exists>t. x = send\<langle>t\<rangle>" (is "?D \<Longrightarrow> ?D'")
 proof -
   have a:
       "list_all is_Receive (unlabel (transaction_receive T))"
       "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
       "list_all is_Update (unlabel (transaction_updates T))"
       "list_all is_Send (unlabel (transaction_send T))"
     using assms unfolding wellformed_transaction_def by metis+
 
   note b = Ball_set
   note c = stateful_strand_step.collapse
 
   show "?A \<Longrightarrow> ?A'" by (metis (mono_tags, lifting) a(1) b c(2))
   show "?B \<Longrightarrow> ?B'" by (metis (no_types, lifting) a(2) b c(3,6,7))
   show "?C \<Longrightarrow> ?C'" by (metis (mono_tags, lifting) a(3) b c(4,5))
   show "?D \<Longrightarrow> ?D'" by (metis (mono_tags, lifting) a(4) b c(1))
 qed
 
 lemma transaction_strand_subsets[simp]:
   "set (transaction_receive T) \<subseteq> set (transaction_strand T)"
   "set (transaction_checks T) \<subseteq> set (transaction_strand T)"
   "set (transaction_updates T) \<subseteq> set (transaction_strand T)"
   "set (transaction_send T) \<subseteq> set (transaction_strand T)"
   "set (unlabel (transaction_receive T)) \<subseteq> set (unlabel (transaction_strand T))"
   "set (unlabel (transaction_checks T)) \<subseteq> set (unlabel (transaction_strand T))"
   "set (unlabel (transaction_updates T)) \<subseteq> set (unlabel (transaction_strand T))"
   "set (unlabel (transaction_send T)) \<subseteq> set (unlabel (transaction_strand T))"
 unfolding transaction_strand_def unlabel_def by force+
 
 lemma transaction_strand_subst_subsets[simp]:
   "set (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<subseteq> set (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
   "set (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<subseteq> set (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
   "set (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<subseteq> set (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
   "set (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<subseteq> set (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
   "set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<subseteq> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   "set (unlabel (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<subseteq> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   "set (unlabel (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<subseteq> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
   "set (unlabel (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) \<subseteq> set (unlabel (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
 unfolding transaction_strand_def unlabel_def subst_apply_labeled_stateful_strand_def by force+
 
 lemma transaction_strand_dual_unfold:
   defines "f \<equiv> \<lambda>S. dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S"
   shows "f (transaction_strand T) = 
          f (transaction_receive T)@f (transaction_checks T)@
          f (transaction_updates T)@f (transaction_send T)"
 using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append unfolding f_def transaction_strand_def by auto
 
 lemma transaction_strand_unlabel_dual_unfold:
   defines "f \<equiv> \<lambda>S. unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S)"
   shows "f (transaction_strand T) = 
          f (transaction_receive T)@f (transaction_checks T)@
          f (transaction_updates T)@f (transaction_send T)"
 using unlabel_append dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append unfolding f_def transaction_strand_def by auto
 
 lemma transaction_dual_subst_unfold:
   "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
     dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@
     dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@
     dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)@
     dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 by (simp add: transaction_strand_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append subst_lsst_append)
 
 lemma transaction_dual_subst_unlabel_unfold:
   "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)) =
     unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@
     unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@
     unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))@
     unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
 by (simp add: transaction_dual_subst_unfold unlabel_append)
 
 lemma trms_transaction_unfold:
   "trms_transaction T =
       trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<union>
       trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
 by (metis trms\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def)
 
 lemma trms_transaction_subst_unfold:
   "trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
       trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union>
       trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 by (metis trms\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
 
 lemma vars_transaction_unfold:
   "vars_transaction T =
       vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<union>
       vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
 by (metis vars\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def)
 
 lemma vars_transaction_subst_unfold:
   "vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
       vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union>
       vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> vars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 by (metis vars\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
 
 lemma fv_transaction_unfold:
   "fv_transaction T =
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<union>
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
 by (metis fv\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def)
 
 lemma fv_transaction_subst_unfold:
   "fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union>
       fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> fv\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 by (metis fv\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
 
 lemma bvars_transaction_unfold:
   "bvars_transaction T =
       bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<union> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) \<union>
       bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) \<union> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
 by (metis bvars\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def)
 
 lemma bvars_transaction_subst_unfold:
   "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) =
       bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union>
       bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<union> bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
 by (metis bvars\<^sub>s\<^sub>s\<^sub>t_append unlabel_append append_assoc transaction_strand_def subst_lsst_append)
 
 lemma bvars_wellformed_transaction_unfold:
   assumes "wellformed_transaction T"
   shows "bvars_transaction T = bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T)" (is ?A)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) = {}" (is ?B)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) = {}" (is ?C)
     and "bvars\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) = {}" (is ?D)
 proof -
   have 0: "list_all is_Receive (unlabel (transaction_receive T))"
           "list_all is_Update (unlabel (transaction_updates T))"
           "list_all is_Send (unlabel (transaction_send T))"
     using assms unfolding wellformed_transaction_def by metis+
 
   have "filter is_NegChecks (unlabel (transaction_receive T)) = []"
        "filter is_NegChecks (unlabel (transaction_updates T)) = []"
        "filter is_NegChecks (unlabel (transaction_send T)) = []"
     using list_all_filter_nil[OF 0(1), of is_NegChecks]
           list_all_filter_nil[OF 0(2), of is_NegChecks]
           list_all_filter_nil[OF 0(3), of is_NegChecks]
           stateful_strand_step.distinct_disc(11,21,29,35,39,41)
     by blast+
   thus ?A ?B ?C ?D
     using bvars_transaction_unfold[of T]
           bvars\<^sub>s\<^sub>s\<^sub>t_NegChecks[of "unlabel (transaction_receive T)"]
           bvars\<^sub>s\<^sub>s\<^sub>t_NegChecks[of "unlabel (transaction_updates T)"]
           bvars\<^sub>s\<^sub>s\<^sub>t_NegChecks[of "unlabel (transaction_send T)"]
     by (metis bvars\<^sub>s\<^sub>s\<^sub>t_def UnionE emptyE list.set(1) list.simps(8) subsetI subset_Un_eq sup_commute)+
 qed
 
 lemma transaction_strand_memberD[dest]:
   assumes "x \<in> set (transaction_strand T)"
   shows "x \<in> set (transaction_receive T) \<or> x \<in> set (transaction_checks T) \<or>
          x \<in> set (transaction_updates T) \<or> x \<in> set (transaction_send T)"
 using assms by (simp add: transaction_strand_def)
 
 lemma transaction_strand_unlabel_memberD[dest]:
   assumes "x \<in> set (unlabel (transaction_strand T))"
   shows "x \<in> set (unlabel (transaction_receive T)) \<or> x \<in> set (unlabel (transaction_checks T)) \<or>
          x \<in> set (unlabel (transaction_updates T)) \<or> x \<in> set (unlabel (transaction_send T))"
 using assms by (simp add: unlabel_def transaction_strand_def)
 
 lemma wellformed_transaction_strand_memberD[dest]:
   assumes "wellformed_transaction T" and "(l,x) \<in> set (transaction_strand T)"
   shows
     "x = receive\<langle>ts\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_receive T)" (is "?A \<Longrightarrow> ?A'")
     "x = select\<langle>t,s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_checks T)" (is "?B \<Longrightarrow> ?B'")
     "x = \<langle>t == s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_checks T)" (is "?C \<Longrightarrow> ?C'")
     "x = \<langle>t in s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_checks T)" (is "?D \<Longrightarrow> ?D'")
     "x = \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>  \<Longrightarrow> (l,x) \<in> set (transaction_checks T)" (is "?E \<Longrightarrow> ?E'")
     "x = insert\<langle>t,s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_updates T)" (is "?F \<Longrightarrow> ?F'")
     "x = delete\<langle>t,s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_updates T)" (is "?G \<Longrightarrow> ?G'")
     "x = send\<langle>ts\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_send T)" (is "?H \<Longrightarrow> ?H'")
     "x = \<langle>ac: t \<doteq> s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_checks T)" (is "?I \<Longrightarrow> ?I'")
     "x = \<langle>ac: t \<in> s\<rangle> \<Longrightarrow> (l,x) \<in> set (transaction_checks T)" (is "?J \<Longrightarrow> ?J'")
 proof -
   have "(l,x) \<in> set (transaction_receive T) \<or> (l,x) \<in> set (transaction_checks T) \<or>
         (l,x) \<in> set (transaction_updates T) \<or> (l,x) \<in> set (transaction_send T)"
     using assms(2) by auto
   thus "?A \<Longrightarrow> ?A'" "?B \<Longrightarrow> ?B'" "?C \<Longrightarrow> ?C'" "?D \<Longrightarrow> ?D'" "?E \<Longrightarrow> ?E'"
        "?F \<Longrightarrow> ?F'" "?G \<Longrightarrow> ?G'" "?H \<Longrightarrow> ?H'" "?I \<Longrightarrow> ?I'" "?J \<Longrightarrow> ?J'"
     using wellformed_transaction_cases[OF assms(1)] by fast+
 qed
 
 lemma wellformed_transaction_strand_unlabel_memberD[dest]:
   assumes "wellformed_transaction T" and "x \<in> set (unlabel (transaction_strand T))"
   shows
     "x = receive\<langle>ts\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_receive T))" (is "?A \<Longrightarrow> ?A'")
     "x = select\<langle>t,s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_checks T))" (is "?B \<Longrightarrow> ?B'")
     "x = \<langle>t == s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_checks T))" (is "?C \<Longrightarrow> ?C'")
     "x = \<langle>t in s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_checks T))" (is "?D \<Longrightarrow> ?D'")
     "x = \<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: G\<rangle>  \<Longrightarrow> x \<in> set (unlabel (transaction_checks T))" (is "?E \<Longrightarrow> ?E'")
     "x = insert\<langle>t,s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_updates T))" (is "?F \<Longrightarrow> ?F'")
     "x = delete\<langle>t,s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_updates T))" (is "?G \<Longrightarrow> ?G'")
     "x = send\<langle>ts\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_send T))" (is "?H \<Longrightarrow> ?H'")
     "x = \<langle>ac: t \<doteq> s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_checks T))" (is "?I \<Longrightarrow> ?I'")
     "x = \<langle>ac: t \<in> s\<rangle> \<Longrightarrow> x \<in> set (unlabel (transaction_checks T))" (is "?J \<Longrightarrow> ?J'")
 proof -
   have "x \<in> set (unlabel (transaction_receive T)) \<or> x \<in> set (unlabel (transaction_checks T)) \<or>
         x \<in> set (unlabel (transaction_updates T)) \<or> x \<in> set (unlabel (transaction_send T))"
     using assms(2) by auto
   thus "?A \<Longrightarrow> ?A'" "?B \<Longrightarrow> ?B'" "?C \<Longrightarrow> ?C'" "?D \<Longrightarrow> ?D'" "?E \<Longrightarrow> ?E'"
        "?F \<Longrightarrow> ?F'" "?G \<Longrightarrow> ?G'" "?H \<Longrightarrow> ?H'" "?I \<Longrightarrow> ?I'" "?J \<Longrightarrow> ?J'"
     using wellformed_transaction_unlabel_cases[OF assms(1)] by fast+
 qed
 
 lemma wellformed_transaction_send_receive_trm_cases:
   assumes T: "wellformed_transaction T"
   shows "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<Longrightarrow> \<exists>ts. t \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))"
     and "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<Longrightarrow> \<exists>ts. t \<in> set ts \<and> send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
 using wellformed_transaction_unlabel_cases(1,4)[OF T]
       trms\<^sub>s\<^sub>s\<^sub>t_in[of t "unlabel (transaction_receive T)"]
       trms\<^sub>s\<^sub>s\<^sub>t_in[of t "unlabel (transaction_send T)"]
 by fastforce+
 
 lemma wellformed_transaction_send_receive_subst_trm_cases:
   assumes T: "wellformed_transaction T"
   shows "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta> \<Longrightarrow> \<exists>ts. t \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     and "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta> \<Longrightarrow> \<exists>ts. t \<in> set ts \<and> send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
 proof -
   assume "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>"
   then obtain s where s: "s \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)" "t = s \<cdot> \<theta>"
     by blast
   hence "\<exists>ts. s \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T))"
     using wellformed_transaction_send_receive_trm_cases(1)[OF T] by simp
   thus "\<exists>ts. t \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_receive T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     using s(2) unlabel_subst[of _ \<theta>] subst_set_map[of s _ \<theta>]
           stateful_strand_step_subst_inI(2)[of _ "unlabel (transaction_receive T)" \<theta>]
     by metis
 next
   assume "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<theta>"
   then obtain s where s: "s \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)" "t = s \<cdot> \<theta>"
     by blast
   hence "\<exists>ts. s \<in> set ts \<and> send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
     using wellformed_transaction_send_receive_trm_cases(2)[OF T] by simp
   thus "\<exists>ts. t \<in> set ts \<and> send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>))"
     using s(2) unlabel_subst[of _ \<theta>] subst_set_map[of s _ \<theta>]
           stateful_strand_step_subst_inI(1)[of _ "unlabel (transaction_send T)" \<theta>]
     by metis
 qed
 
 lemma wellformed_transaction_send_receive_fv_subset:
   assumes T: "wellformed_transaction T"
   shows "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<Longrightarrow> fv t \<subseteq> fv_transaction T" (is "?A \<Longrightarrow> ?A'")
     and "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<Longrightarrow> fv t \<subseteq> fv_transaction T" (is "?B \<Longrightarrow> ?B'")
 proof -
   let ?P = "\<exists>ts. t \<in> set ts \<and> receive\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))"
   let ?Q = "\<exists>ts. t \<in> set ts \<and> send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))"
 
   have *: "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T) \<Longrightarrow> ?P" "t \<in> trms\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T) \<Longrightarrow> ?Q"
     using wellformed_transaction_send_receive_trm_cases[OF T, of t]
     unfolding transaction_strand_def by force+
   
   show "?A \<Longrightarrow> ?A'" using *(1) by (induct "transaction_strand T") (simp, force)
   show "?B \<Longrightarrow> ?B'" using *(2) by (induct "transaction_strand T") (simp, force)
 qed
 
 lemma dual_wellformed_transaction_ident_cases[dest]:
   "list_all is_Assignment (unlabel S) \<Longrightarrow> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S = S"
   "list_all is_Check (unlabel S) \<Longrightarrow> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S = S"
   "list_all is_Update (unlabel S) \<Longrightarrow> dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S = S"
 proof (induction S)
   case (Cons s S)
-  obtain l x where s: "s = (l,x)" by moura
+  obtain l x where s: "s = (l,x)" by force
   { case 1 thus ?case using Cons s unfolding unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by (cases x) auto }
   { case 2 thus ?case using Cons s unfolding unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by (cases x) auto }
   { case 3 thus ?case using Cons s unfolding unlabel_def dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def by (cases x) auto }
 qed simp_all
 
 lemma wellformed_transaction_wf\<^sub>s\<^sub>s\<^sub>t:
   fixes T::"('a, 'b, 'c, 'd) prot_transaction"
   assumes T: "wellformed_transaction T"
   shows "wf'\<^sub>s\<^sub>s\<^sub>t (fst ` set (transaction_decl T ()) \<union> set (transaction_fresh T))
                (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
     and "fv_transaction T \<inter> bvars_transaction T = {}"
 using T unfolding wellformed_transaction_def by simp_all
 
 lemma dual_wellformed_transaction_ident_cases'[dest]:
   assumes "wellformed_transaction T"
   shows "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_checks T) = transaction_checks T" (is ?A)
         "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_updates T) = transaction_updates T" (is ?B)
 proof -
   have "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
        "list_all is_Update (unlabel (transaction_updates T))"
     using assms is_Check_or_Assignment_iff unfolding wellformed_transaction_def by auto
   thus ?A ?B
     using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all_same(9)[of "transaction_checks T"]
           dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_list_all_same(8)[of "transaction_updates T"]
     by (blast, blast)
 qed
 
 lemma dual_transaction_strand:
   assumes "wellformed_transaction T"
   shows "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) =
          dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)@transaction_checks T@
          transaction_updates T@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)"
 using dual_wellformed_transaction_ident_cases'[OF assms] dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_append
 unfolding transaction_strand_def by metis
 
 lemma dual_unlabel_transaction_strand:
   assumes "wellformed_transaction T"
   shows "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)) =
          (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)))@(unlabel (transaction_checks T))@
          (unlabel (transaction_updates T))@(unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)))"
 using dual_transaction_strand[OF assms] by (simp add: unlabel_def)
 
 lemma dual_transaction_strand_subst:
   assumes "wellformed_transaction T"
   shows "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) =
           (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_receive T)@transaction_checks T@
           transaction_updates T@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>"
 proof -
   have "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>) = dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>"
     using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst by metis
   thus ?thesis using dual_transaction_strand[OF assms] by argo
 qed
 
 lemma dual_transaction_ik_is_transaction_send:
   assumes "wellformed_transaction T"
   shows "ik\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))) = trms\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_send T))"
     (is "?A = ?B")
 proof -
   { fix t assume "t \<in> ?A"
     then obtain ts where ts:
         "t \<in> set ts" "receive\<langle>ts\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
       by (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def)
     hence *: "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_strand T))"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(1) by metis
     have "t \<in> ?B"
       using ts(1) wellformed_transaction_strand_unlabel_memberD(8)[OF assms *, of ts] by force
   } moreover {
     fix t assume "t \<in> ?B"
     then obtain ts where ts:
         "t \<in> set ts" "send\<langle>ts\<rangle> \<in> set (unlabel (transaction_send T))"
       using wellformed_transaction_unlabel_cases(4)[OF assms] by fastforce
     hence "receive\<langle>ts\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_send T)))"
       using dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_unlabel_steps_iff(1) by metis
     hence "receive\<langle>ts\<rangle> \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)))"
       using dual_unlabel_transaction_strand[OF assms] by simp 
     hence "t \<in> ?A" using ts(1) by (auto simp add: ik\<^sub>s\<^sub>s\<^sub>t_def)
   } ultimately show "?A = ?B" by auto
 qed
 
 lemma dual_transaction_ik_is_transaction_send':
   fixes \<delta>::"('a,'b,'c,'d) prot_subst"
   assumes "wellformed_transaction T"
   shows "ik\<^sub>s\<^sub>s\<^sub>t (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>)))  =
          trms\<^sub>s\<^sub>s\<^sub>t (unlabel (transaction_send T)) \<cdot>\<^sub>s\<^sub>e\<^sub>t \<delta>" (is "?A = ?B")
 using dual_transaction_ik_is_transaction_send[OF assms]
       subst_lsst_unlabel[of "dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T)" \<delta>]
       ik\<^sub>s\<^sub>s\<^sub>t_subst[of "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (transaction_strand T))" \<delta>]
       dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst[of "transaction_strand T" \<delta>]
 by auto
 
 lemma db\<^sub>s\<^sub>s\<^sub>t_transaction_prefix_eq:
   assumes T: "wellformed_transaction T"
     and S: "prefix S (transaction_receive T@transaction_checks T)"
   shows "db\<^sub>l\<^sub>s\<^sub>s\<^sub>t A = db\<^sub>l\<^sub>s\<^sub>s\<^sub>t (A@dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>))"
 proof -
   let ?T1 = "transaction_receive T"
   let ?T2 = "transaction_checks T"
 
   have *: "prefix (unlabel S) (unlabel (?T1@?T2))" using S prefix_unlabel by blast
 
   have "list_all is_Receive (unlabel ?T1)"
        "list_all is_Check_or_Assignment (unlabel ?T2)"
     using T by (simp_all add: wellformed_transaction_def)
   hence "\<forall>b \<in> set (unlabel ?T1). \<not>is_Insert b \<and> \<not>is_Delete b"
         "\<forall>b \<in> set (unlabel ?T2). \<not>is_Insert b \<and> \<not>is_Delete b"
     by (metis (mono_tags, lifting) Ball_set stateful_strand_step.distinct_disc(16,18),
         metis (mono_tags, lifting) Ball_set stateful_strand_step.distinct_disc(24,26,33,35,37,39))
   hence "\<forall>b \<in> set (unlabel (?T1@?T2)). \<not>is_Insert b \<and> \<not>is_Delete b"
     by (auto simp add: unlabel_def)
   hence "\<forall>b \<in> set (unlabel S). \<not>is_Insert b \<and> \<not>is_Delete b"
     using * unfolding prefix_def by fastforce
   hence "\<forall>b \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t S) \<cdot>\<^sub>s\<^sub>s\<^sub>t \<delta>). \<not>is_Insert b \<and> \<not>is_Delete b"
   proof (induction S)
     case (Cons a S)
     then obtain l b where "a = (l,b)" by (metis surj_pair)
     thus ?case
       using Cons unfolding dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_def unlabel_def subst_apply_stateful_strand_def
       by (cases b) auto
   qed simp
   hence **: "\<forall>b \<in> set (unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (S \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<delta>))). \<not>is_Insert b \<and> \<not>is_Delete b"
     by (metis dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_subst_unlabel)
 
   show ?thesis 
     using db\<^sub>s\<^sub>s\<^sub>t_no_upd_append[OF **] unlabel_append
     unfolding db\<^sub>s\<^sub>s\<^sub>t_def by metis
 qed
 
 lemma db\<^sub>l\<^sub>s\<^sub>s\<^sub>t_dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_set_ex:
    assumes "d \<in> set (db'\<^sub>l\<^sub>s\<^sub>s\<^sub>t (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) \<I> D)"
     "\<forall>t u. insert\<langle>t,u\<rangle> \<in> set (unlabel A) \<longrightarrow> (\<exists>s. u = Fun (Set s) [])"
     "\<forall>t u. delete\<langle>t,u\<rangle> \<in> set (unlabel A) \<longrightarrow> (\<exists>s. u = Fun (Set s) [])"
     "\<forall>d \<in> set D. \<exists>s. snd d = Fun (Set s) []"
   shows "\<exists>s. snd d = Fun (Set s) []"
   using assms
 proof (induction A arbitrary: D)
   case (Cons a A)
   obtain l b where a: "a = (l,b)" by (metis surj_pair)
 
   have 1: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = receive\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>#unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     when "b = send\<langle>ts\<rangle>" for ts
     by (simp add: a that subst_lsst_unlabel_cons)
 
   have 2: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = send\<langle>ts \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<theta>\<rangle>#unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     when "b = receive\<langle>ts\<rangle>" for ts
     by (simp add: a that subst_lsst_unlabel_cons)
 
   have 3: "unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t (a#A) \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>) = (b \<cdot>\<^sub>s\<^sub>s\<^sub>t\<^sub>p \<theta>)#unlabel (dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>l\<^sub>s\<^sub>s\<^sub>t \<theta>)"
     when "\<nexists>ts. b = send\<langle>ts\<rangle> \<or> b = receive\<langle>ts\<rangle>"
     using a that dual\<^sub>l\<^sub>s\<^sub>s\<^sub>t_Cons subst_lsst_unlabel_cons[of l b]
     by (cases b) auto
 
   show ?case using 1 2 3 a Cons by (cases b) fastforce+
 qed simp
 
 lemma is_Fun_SetE[elim]:
   assumes t: "is_Fun_Set t"
   obtains s where "t = Fun (Set s) []"
 proof (cases t)
   case (Fun f T)
-  then obtain s where "f = Set s" using t unfolding is_Fun_Set_def by (cases f) moura+
+  then obtain s where "f = Set s" using t unfolding is_Fun_Set_def by (cases f) force+
   moreover have "T = []" using Fun t unfolding is_Fun_Set_def by (cases T) auto
   ultimately show ?thesis using Fun that by fast
 qed (use t is_Fun_Set_def in fast)
 
 lemma Fun_Set_InSet_iff:
   "(u = \<langle>a: Var x \<in> Fun (Set s) []\<rangle>) \<longleftrightarrow>
    (is_InSet u \<and> is_Var (the_elem_term u) \<and> is_Fun_Set (the_set_term u) \<and>
     the_Set (the_Fun (the_set_term u)) = s \<and> the_Var (the_elem_term u) = x \<and> the_check u = a)"
   (is "?A \<longleftrightarrow> ?B")
 proof
   show "?A \<Longrightarrow> ?B" unfolding is_Fun_Set_def by auto
 
   assume B: ?B
   thus ?A
   proof (cases u)
     case (InSet b t t')
     hence "b = a" "t = Var x" "t' = Fun (Set s) []"
       using B by (simp, fastforce, fastforce)
     thus ?thesis using InSet by fast
   qed auto
 qed
 
 lemma Fun_Set_NotInSet_iff:
   "(u = \<langle>Var x not in Fun (Set s) []\<rangle>) \<longleftrightarrow>
    (is_NegChecks u \<and> bvars\<^sub>s\<^sub>s\<^sub>t\<^sub>p u = [] \<and> the_eqs u = [] \<and> length (the_ins u) = 1 \<and>
     is_Var (fst (hd (the_ins u))) \<and> is_Fun_Set (snd (hd (the_ins u)))) \<and>
     the_Set (the_Fun (snd (hd (the_ins u)))) = s \<and> the_Var (fst (hd (the_ins u))) = x"
   (is "?A \<longleftrightarrow> ?B")
 proof
   show "?A \<Longrightarrow> ?B" unfolding is_Fun_Set_def by auto
 
   assume B: ?B
   show ?A
   proof (cases u)
     case (NegChecks X F F')
     hence "X = []" "F = []"
       using B by auto
     moreover have "fst (hd (the_ins u)) = Var x" "snd (hd (the_ins u)) = Fun (Set s) []"
       using B is_Fun_SetE[of "snd (hd (the_ins u))"]
       by (force, fastforce)
     hence "F' = [(Var x, Fun (Set s) [])]"
       using NegChecks B by (cases "the_ins u") auto
     ultimately show ?thesis using NegChecks by fast
   qed (use B in auto)
 qed
 
 lemma is_Fun_Set_exi: "is_Fun_Set x \<longleftrightarrow> (\<exists>s. x = Fun (Set s) [])"
 by (metis prot_fun.collapse(2) term.collapse(2) prot_fun.disc(11) term.disc(2)
           term.sel(2,4) is_Fun_Set_def un_Fun1_def)
 
 lemma is_Fun_Set_subst:
   assumes "is_Fun_Set S'"
   shows "is_Fun_Set (S' \<cdot> \<sigma>)"
 using assms by (fastforce simp add: is_Fun_Set_def)
 
 lemma is_Update_in_transaction_updates:
   assumes tu: "is_Update t"
   assumes t: "t \<in> set (unlabel (transaction_strand TT))"
   assumes vt: "wellformed_transaction TT"
   shows "t \<in> set (unlabel (transaction_updates TT))"
 using t tu vt unfolding transaction_strand_def wellformed_transaction_def list_all_iff
 by (auto simp add: unlabel_append)
 
 lemma transaction_proj_member:
   assumes "T \<in> set P"
   shows "transaction_proj n T \<in> set (map (transaction_proj n) P)"
 using assms by simp
 
 lemma transaction_strand_proj:
   "transaction_strand (transaction_proj n T) = proj n (transaction_strand T)"
 proof -
   obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
   thus ?thesis
     using transaction_proj.simps[of n A B C D E F]
     unfolding transaction_strand_def proj_def Let_def by auto
 qed
 
 lemma transaction_proj_decl_eq:
   "transaction_decl (transaction_proj n T) = transaction_decl T"
 proof -
   obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
   thus ?thesis
     using transaction_proj.simps[of n A B C D E F]
     unfolding proj_def Let_def by auto
 qed
 
 lemma transaction_proj_fresh_eq:
   "transaction_fresh (transaction_proj n T) = transaction_fresh T"
 proof -
   obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
   thus ?thesis
     using transaction_proj.simps[of n A B C D E F]
     unfolding proj_def Let_def by auto
 qed
 
 lemma transaction_proj_trms_subset:
   "trms_transaction (transaction_proj n T) \<subseteq> trms_transaction T"
 proof -
   obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
   thus ?thesis
     using transaction_proj.simps[of n A B C D E F] trms\<^sub>s\<^sub>s\<^sub>t_proj_subset(1)[of n]
     unfolding transaction_fresh_def Let_def transaction_strand_def by auto
 qed
 
 lemma transaction_proj_vars_subset:
   "vars_transaction (transaction_proj n T) \<subseteq> vars_transaction T"
 proof -
   obtain A B C D E F where "T = Transaction A B C D E F" by (cases T) simp
   thus ?thesis
     using transaction_proj.simps[of n A B C D E F]
           sst_vars_proj_subset(3)[of n "transaction_strand T"]
     unfolding transaction_fresh_def Let_def transaction_strand_def by simp
 qed
 
 lemma transaction_proj_labels:
   fixes T::"('a,'b,'c,'d) prot_transaction"
   shows "list_all (\<lambda>a. has_LabelN l a \<or> has_LabelS a) (transaction_strand (transaction_proj l T))"
 proof -
   define h where "h \<equiv> \<lambda>a::('a,'b,'c,'d) prot_strand_step. has_LabelN l a \<or> has_LabelS a"
   let ?f = "filter h"
   let ?g = "list_all h"
 
   obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T) simp
 
   note 0 = transaction_proj.simps[unfolded Let_def, of l T1 T2 T3 T4 T5 T6]
 
   show ?thesis using T 0 unfolding list_all_iff proj_def by auto
 qed
 
 lemma transaction_proj_ident_iff:
   fixes T::"('a,'b,'c,'d) prot_transaction"
   shows "list_all (\<lambda>a. has_LabelN l a \<or> has_LabelS a) (transaction_strand T) \<longleftrightarrow>
          transaction_proj l T = T"
     (is "?A \<longleftrightarrow> ?B")
 proof
   obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T) simp
   hence "transaction_strand T = T3@T4@T5@T6" unfolding transaction_strand_def by simp
   thus "?A \<Longrightarrow> ?B"
     using T transaction_proj.simps[unfolded Let_def, of l T1 T2 T3 T4 T5 T6]
     unfolding list_all_iff proj_def by auto
 
   show "?B \<Longrightarrow> ?A" using transaction_proj_labels[of l T] by presburger
 qed
 
 lemma transaction_proj_idem:
   fixes T::"('a,'b,'c,'d) prot_transaction"
   shows "transaction_proj l (transaction_proj l T) = transaction_proj l T"
 by (meson transaction_proj_ident_iff transaction_proj_labels)
 
 lemma transaction_proj_ball_subst:
   assumes
     "set Ps = (\<lambda>n. map (transaction_proj n) P) ` set L"
     "\<forall>p \<in> set Ps. Q p"
   shows "\<forall>l \<in> set L. Q (map (transaction_proj l) P)"
 using assms by auto
 
 lemma transaction_star_proj_has_star_labels:
   "list_all has_LabelS (transaction_strand (transaction_star_proj T))"
 proof -
   let ?f = "filter has_LabelS"
 
   obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T) simp
   hence T': "transaction_strand (transaction_star_proj T) = ?f T3@?f T4@?f T5@?f T6"
     using transaction_star_proj.simps[unfolded Let_def, of T1 T2 T3 T4 T5 T6]
     unfolding transaction_strand_def by auto
 
   show ?thesis using Ball_set unfolding T' by fastforce
 qed
 
 lemma transaction_star_proj_ident_iff:
   "list_all has_LabelS (transaction_strand T) \<longleftrightarrow> transaction_star_proj T = T" (is "?A \<longleftrightarrow> ?B")
 proof
   obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T) simp
   hence T': "transaction_strand T = T3@T4@T5@T6" unfolding transaction_strand_def by simp
 
   show "?A \<Longrightarrow> ?B" using T T' unfolding list_all_iff by auto
   show "?B \<Longrightarrow> ?A" using transaction_star_proj_has_star_labels[of T] by auto
 qed
 
 lemma transaction_star_proj_negates_transaction_proj:
   "transaction_star_proj (transaction_proj l T) = transaction_star_proj T" (is "?A l T")
   "k \<noteq> l \<Longrightarrow> transaction_proj k (transaction_proj l T) = transaction_star_proj T" (is "?B \<Longrightarrow> ?B'")
 proof -
   show "?A l T" for l T
   proof -
     obtain T1 T2 T3 T4 T5 T6 where T: "T = Transaction T1 T2 T3 T4 T5 T6" by (cases T) simp
     thus ?thesis
       by (metis dbproj_def transaction_proj.simps transaction_star_proj.simps proj_dbproj(2))
   qed
   thus "?B \<Longrightarrow> ?B'"
     by (metis (no_types) has_LabelS_proj_iff_not_has_LabelN proj_elims_label
         transaction_star_proj_ident_iff transaction_strand_proj)
 qed
 
 lemma transaction_updates_send_ex_iff:
   fixes T::"('a,'b,'c,'d) prot_transaction"
   assumes "list_all is_Receive (unlabel (transaction_receive T))"
           "list_all is_Check_or_Assignment (unlabel (transaction_checks T))"
           "list_all is_Update (unlabel (transaction_updates T))"
           "list_all is_Send (unlabel (transaction_send T))"
   shows "transaction_updates T \<noteq> [] \<or> transaction_send T \<noteq> [] \<longleftrightarrow>
          list_ex (\<lambda>a. is_Send (snd a) \<or> is_Update (snd a)) (transaction_strand T)"
 proof -
   define f where "f \<equiv> \<lambda>a::('a,'b,'c,'d) prot_strand_step. is_Send (snd a) \<or> is_Update (snd a)"
 
   have 0: "list_all (\<lambda>a. \<not>(f a)) (transaction_receive T)"
           "list_all (\<lambda>a. \<not>(f a)) (transaction_checks T)"
           "list_all (\<lambda>a. (f a)) (transaction_updates T)"
           "list_all (\<lambda>a. (f a)) (transaction_send T)"
     using assms unfolding list_all_iff unlabel_def f_def by auto
 
   have 1:
       "list_ex f (transaction_strand T) \<longleftrightarrow>
        list_ex f (transaction_updates T) \<or> list_ex f (transaction_send T)"
     using 0 unfolding list_all_iff list_ex_iff transaction_strand_def by auto
 
   have 2: "A \<noteq> [] \<longleftrightarrow> list_ex f A" when "list_all f A" for A
     using that by (induct A) auto
 
   thus ?thesis
     using 1 2[OF 0(3)] 2[OF 0(4)] unfolding list_all_iff list_ex_iff f_def[symmetric] by meson
 qed
 
 end
diff --git a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
--- a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
+++ b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
@@ -1,898 +1,898 @@
 (*
   File:   Banach_Steinhaus_Missing.thy
   Author: Dominique Unruh, University of Tartu
   Author: Jose Manuel Rodriguez Caballero, University of Tartu
 *)
 section \<open>Missing results for the proof of Banach-Steinhaus theorem\<close>
 
 theory Banach_Steinhaus_Missing
   imports
     "HOL-Analysis.Bounded_Linear_Function"
     "HOL-Analysis.Line_Segment"
 
 begin
 subsection \<open>Results missing for the proof of Banach-Steinhaus theorem\<close>
 text \<open>
   The results proved here are preliminaries for the proof of Banach-Steinhaus theorem using Sokal's 
   approach, but they do not explicitly appear in Sokal's paper \<^cite>\<open>sokal2011really\<close>.
 \<close>
 
 text\<open>Notation for the norm\<close>
 bundle notation_norm begin
 notation norm ("\<parallel>_\<parallel>")
 end
 
 bundle no_notation_norm begin
 no_notation norm ("\<parallel>_\<parallel>")
 end
 
 unbundle notation_norm
 
 text\<open>Notation for apply bilinear function\<close>
 bundle notation_blinfun_apply begin
 notation blinfun_apply (infixr "*\<^sub>v" 70)
 end
 
 bundle no_notation_blinfun_apply begin
 no_notation blinfun_apply (infixr "*\<^sub>v" 70)
 end
 
 unbundle notation_blinfun_apply
 
 lemma bdd_above_plus:
   fixes f::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>bdd_above (f ` S)\<close> and \<open>bdd_above (g ` S)\<close> 
   shows \<open>bdd_above ((\<lambda> x. f x + g x) ` S)\<close>
   text \<open>
   Explanation: If the images of two real-valued functions \<^term>\<open>f\<close>,\<^term>\<open>g\<close> are bounded above on a 
   set \<^term>\<open>S\<close>, then the image of their sum is bounded on \<^term>\<open>S\<close>.
 \<close>
 proof-
   obtain M where \<open>\<And> x. x\<in>S \<Longrightarrow> f x \<le> M\<close>
     using \<open>bdd_above (f ` S)\<close> unfolding bdd_above_def by blast
   obtain N where \<open>\<And> x. x\<in>S \<Longrightarrow> g x \<le> N\<close>
     using \<open>bdd_above (g ` S)\<close> unfolding bdd_above_def by blast
   have \<open>\<And> x. x\<in>S \<Longrightarrow> f x + g x \<le> M + N\<close>
     using \<open>\<And>x. x \<in> S \<Longrightarrow> f x \<le> M\<close> \<open>\<And>x. x \<in> S \<Longrightarrow> g x \<le> N\<close> by fastforce
   thus ?thesis unfolding bdd_above_def by blast
 qed
 
 text\<open>The maximum of two functions\<close>
 definition pointwise_max:: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
   \<open>pointwise_max f g = (\<lambda>x. max (f x) (g x))\<close>
 
 lemma max_Sup_absorb_left:
   fixes f g::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close> and \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>
   shows \<open>Sup ((pointwise_max f g) ` X) = Sup (f ` X)\<close>
 
   text \<open>Explanation: For real-valued functions \<^term>\<open>f\<close> and \<^term>\<open>g\<close>, if the supremum of \<^term>\<open>f\<close> is 
     greater-equal the supremum of \<^term>\<open>g\<close>, then the supremum of \<^term>\<open>max f g\<close> equals the supremum of
     \<^term>\<open>f\<close>. (Under some technical conditions.)\<close>
 
 proof-
   have y_Sup: \<open>y \<in> ((\<lambda> x. max (f x) (g x)) ` X) \<Longrightarrow> y \<le> Sup (f ` X)\<close> for y
   proof-
     assume \<open>y \<in> ((\<lambda> x. max (f x) (g x)) ` X)\<close>
     then obtain x where \<open>y = max (f x) (g x)\<close> and \<open>x \<in> X\<close>
       by blast
     have \<open>f x \<le> Sup (f ` X)\<close>
       by (simp add:  \<open>x \<in> X\<close> \<open>bdd_above (f ` X)\<close> cSUP_upper) 
     moreover have  \<open>g x \<le> Sup (g ` X)\<close>
       by (simp add:  \<open>x \<in> X\<close> \<open>bdd_above (g ` X)\<close> cSUP_upper) 
     ultimately have \<open>max (f x) (g x) \<le> Sup (f ` X)\<close>
       using  \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close> by auto
     thus ?thesis by (simp add: \<open>y = max (f x) (g x)\<close>) 
   qed
   have y_f_X: \<open>y \<in> f ` X \<Longrightarrow> y \<le> Sup ((\<lambda> x. max (f x) (g x)) ` X)\<close> for y
   proof-
     assume \<open>y \<in> f ` X\<close>
     then obtain x where \<open>x \<in> X\<close> and \<open>y = f x\<close>
       by blast
     have  \<open>bdd_above ((\<lambda> \<xi>. max (f \<xi>) (g \<xi>)) ` X)\<close>
       by (metis (no_types) \<open>bdd_above (f ` X)\<close> \<open>bdd_above (g ` X)\<close> bdd_above_image_sup sup_max)
     moreover have \<open>e > 0 \<Longrightarrow> \<exists> k \<in> (\<lambda> \<xi>. max (f \<xi>) (g \<xi>)) ` X. y \<le> k + e\<close>
       for e::real
       using \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>
       by (smt (verit, best) \<open>x \<in> X\<close> \<open>y = f x\<close> imageI)
     ultimately show ?thesis
       using \<open>x \<in> X\<close> \<open>y = f x\<close> cSUP_upper by fastforce
   qed
   have \<open>Sup ((\<lambda> x. max (f x) (g x)) ` X) \<le> Sup (f ` X)\<close>
     using y_Sup by (simp add: \<open>X \<noteq> {}\<close> cSup_least) 
   moreover have \<open>Sup ((\<lambda> x. max (f x) (g x)) ` X) \<ge> Sup (f ` X)\<close>
     using y_f_X by (metis (mono_tags) cSup_least calculation empty_is_image)  
   ultimately show ?thesis unfolding pointwise_max_def by simp
 qed
 
 lemma max_Sup_absorb_right:
   fixes f g::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close> and \<open>Sup (f ` X) \<le> Sup (g ` X)\<close>
   shows \<open>Sup ((pointwise_max f g) ` X) = Sup (g ` X)\<close>
   text \<open>
   Explanation: For real-valued functions \<^term>\<open>f\<close> and \<^term>\<open>g\<close> and a nonempty set \<^term>\<open>X\<close>, such that 
   the \<^term>\<open>f\<close> and \<^term>\<open>g\<close> are bounded above on \<^term>\<open>X\<close>, if the supremum of \<^term>\<open>f\<close> on \<^term>\<open>X\<close> is 
   lower-equal the supremum of \<^term>\<open>g\<close> on \<^term>\<open>X\<close>, then the supremum of \<^term>\<open>pointwise_max f g\<close> on \<^term>\<open>X\<close>
   equals the supremum of \<^term>\<open>g\<close>. This is the right analog of @{text max_Sup_absorb_left}.
 \<close>
 proof-
   have \<open>Sup ((pointwise_max g f) ` X) = Sup (g ` X)\<close>
     using  assms by (simp add: max_Sup_absorb_left)     
   moreover have \<open>pointwise_max g f = pointwise_max f g\<close>
     unfolding pointwise_max_def  by auto
   ultimately show ?thesis by simp
 qed
 
 lemma max_Sup:
   fixes f g::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close>
   shows \<open>Sup ((pointwise_max f g) ` X) = max (Sup (f ` X)) (Sup (g ` X))\<close>
   text \<open>
   Explanation: Let \<^term>\<open>X\<close> be a nonempty set. Two supremum over \<^term>\<open>X\<close> of the maximum of two 
   real-value functions is equal to the maximum of their suprema over \<^term>\<open>X\<close>, provided that the
   functions are bounded above on \<^term>\<open>X\<close>.
 \<close>
 proof(cases \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>)
   case True thus ?thesis by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_left)
 next
   case False 
   have f1: "\<not> 0 \<le> Sup (f ` X) + - 1 * Sup (g ` X)"
     using False by linarith
   hence "Sup (Banach_Steinhaus_Missing.pointwise_max f g ` X) = Sup (g ` X)"
     by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_right)
   thus ?thesis
     using f1 by linarith
 qed
 
 
 lemma identity_telescopic:
   fixes x :: \<open>_ \<Rightarrow> 'a::real_normed_vector\<close>
   assumes \<open>x \<longlonglongrightarrow> l\<close>
   shows \<open>(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) \<longlonglongrightarrow> l - x n\<close>
   text\<open>
   Expression of a limit as a telescopic series.
   Explanation: If \<^term>\<open>x\<close> converges to \<^term>\<open>l\<close> then the sum \<^term>\<open>sum (\<lambda> k. x (Suc k) - x k) {n..N}\<close>
   converges to \<^term>\<open>l - x n\<close> as \<^term>\<open>N\<close> goes to infinity.
 \<close>
 proof-
   have \<open>(\<lambda> p. x (p + Suc n)) \<longlonglongrightarrow> l\<close>
     using \<open>x \<longlonglongrightarrow> l\<close> by (rule LIMSEQ_ignore_initial_segment)
   hence \<open>(\<lambda> p. x (Suc n + p)) \<longlonglongrightarrow> l\<close>   
     by (simp add: add.commute)
   hence \<open>(\<lambda> p. x (Suc (n + p))) \<longlonglongrightarrow> l\<close>
     by simp 
   hence \<open>(\<lambda> t. (- (x n)) + (\<lambda> p.  x (Suc (n + p))) t ) \<longlonglongrightarrow> (- (x n))  + l\<close>
     using tendsto_add_const_iff by metis 
   hence f1: \<open>(\<lambda> p. x (Suc (n + p)) - x n)\<longlonglongrightarrow> l - x n\<close>
     by simp
   have \<open>sum (\<lambda> k. x (Suc k) - x k) {n..n+p} = x (Suc (n+p)) - x n\<close> for p
     by (simp add: sum_Suc_diff)
   moreover have \<open>(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (n + t) 
                = (\<lambda> p. sum (\<lambda> k. x (Suc k) - x k) {n..n+p}) t\<close> for t
     by blast
   ultimately have  \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (n + p)) \<longlonglongrightarrow> l - x n\<close>
     using f1 by simp
   hence \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (p + n)) \<longlonglongrightarrow> l - x n\<close>
     by (simp add: add.commute)
   hence  \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) p) \<longlonglongrightarrow> l - x n\<close>
     using Topological_Spaces.LIMSEQ_offset[where f = "(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N})" 
         and a = "l - x n" and k = n] by blast
   hence  \<open>(\<lambda> M. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) M) \<longlonglongrightarrow> l - x n\<close>
     by simp
   thus ?thesis by blast
 qed
 
 lemma bound_Cauchy_to_lim:
   assumes \<open>y \<longlonglongrightarrow> x\<close> and \<open>\<And>n. \<parallel>y (Suc n) - y n\<parallel> \<le> c^n\<close> and \<open>y 0 = 0\<close> and \<open>c < 1\<close>
   shows \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * c ^ n\<close>
   text\<open>
   Inequality about a sequence of approximations assuming that the sequence of differences is bounded
   by a geometric progression.
   Explanation: Let \<^term>\<open>y\<close> be a sequence converging to \<^term>\<open>x\<close>.
   If \<^term>\<open>y\<close> satisfies the inequality \<open>\<parallel>y (Suc n) - y n\<parallel> \<le> c ^ n\<close> for some \<^term>\<open>c < 1\<close> and 
   assuming \<^term>\<open>y 0 = 0\<close> then the inequality \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * c ^ n\<close> holds.
 \<close>
 proof-
   have \<open>c \<ge> 0\<close>
     using \<open>\<And> n. \<parallel>y (Suc n) - y n\<parallel> \<le> c^n\<close>
     by (metis dual_order.trans norm_ge_zero power_one_right)
   have norm_1: \<open>norm (\<Sum>k = Suc n..N. y (Suc k) - y k) \<le> (c ^ Suc n)/(1 - c)\<close> for N
   proof(cases \<open>N < Suc n\<close>)
     case True
     hence \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> = 0\<close>
       by auto
     thus ?thesis  using  \<open>c \<ge> 0\<close> \<open>c < 1\<close> by auto       
   next
     case False
     hence \<open>N \<ge> Suc n\<close>
       by auto
     have \<open>c^(Suc N) \<ge> 0\<close>
       using \<open>c \<ge> 0\<close> by auto
     have \<open>1 - c > 0\<close>
       by (simp add: \<open>c < 1\<close>)
     hence \<open>(1 - c)/(1 - c) = 1\<close>
       by auto
     have \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> \<le> (sum (\<lambda>k. \<parallel>y (Suc k) - y k\<parallel>) {Suc n .. N})\<close>
       by (simp add: sum_norm_le)
     hence \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> \<le> (sum (power c) {Suc n .. N})\<close>
       by (simp add: assms(2) sum_norm_le)
     hence \<open>(1 - c) * \<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel>
                    \<le> (1 - c) * (sum (power c) {Suc n .. N})\<close>
       using \<open>0 < 1 - c\<close> mult_le_cancel_left_pos by blast      
     also have \<open>\<dots> = c^(Suc n) - c^(Suc N)\<close>
       using Set_Interval.sum_gp_multiplied \<open>Suc n \<le> N\<close> by blast
     also have \<open>\<dots> \<le> c^(Suc n)\<close>
       using \<open>c^(Suc N) \<ge> 0\<close> by auto
     finally have \<open>(1 - c) * \<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel> \<le> c ^ Suc n\<close>
       by blast
     hence \<open>((1 - c) * \<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel>)/(1 - c)
                    \<le> (c ^ Suc n)/(1 - c)\<close>
       using \<open>0 < 1 - c\<close> divide_le_cancel by fastforce
     thus \<open>\<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
       using \<open>0 < 1 - c\<close> by auto 
   qed
   have \<open>(\<lambda> N. (sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N})) \<longlonglongrightarrow> x - y (Suc n)\<close>
     by (metis (no_types) \<open>y \<longlonglongrightarrow> x\<close> identity_telescopic)     
   hence \<open>(\<lambda> N. \<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel>) \<longlonglongrightarrow> \<parallel>x - y (Suc n)\<parallel>\<close>
     using tendsto_norm by blast
   hence \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
     using norm_1 Lim_bounded by blast
   hence  \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
     by auto
   moreover have \<open>(c ^ Suc n)/(1 - c) = (c / (1 - c)) * (c ^ n)\<close>
     by (simp add: divide_inverse_commute)    
   ultimately show \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * (c ^ n)\<close> by linarith
 qed
 
 lemma onorm_open_ball:
   includes notation_norm
   shows \<open>\<parallel>f\<parallel> = Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 }\<close>
   text \<open>
   Explanation: Let \<^term>\<open>f\<close> be a bounded linear operator. The operator norm of \<^term>\<open>f\<close> is the
   supremum of \<^term>\<open>norm (f x)\<close> for \<^term>\<open>x\<close> such that \<^term>\<open>norm x < 1\<close>.
 \<close>
 proof(cases \<open>(UNIV::'a set) = 0\<close>)
   case True
   hence \<open>x = 0\<close> for x::'a
     by auto
   hence \<open>f *\<^sub>v x = 0\<close> for x
     by (metis (full_types) blinfun.zero_right)
   hence \<open>\<parallel>f\<parallel> = 0\<close>
     by (simp add: blinfun_eqI zero_blinfun.rep_eq)      
   have \<open>{ \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} = {0}\<close>
     by (smt (verit, ccfv_SIG) Collect_cong \<open>\<And>x. f *\<^sub>v x = 0\<close> norm_zero singleton_conv)      
   hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} = 0\<close>
     by simp    
   thus ?thesis using \<open>\<parallel>f\<parallel> = 0\<close> by auto      
 next
   case False
   hence \<open>(UNIV::'a set) \<noteq> 0\<close>
     by simp
   have nonnegative: \<open>\<parallel>f *\<^sub>v x\<parallel> \<ge> 0\<close> for x
     by simp
   have \<open>\<exists> x::'a. x \<noteq> 0\<close>
     using \<open>UNIV \<noteq> 0\<close> by auto
   then obtain x::'a where \<open>x \<noteq> 0\<close>
     by blast
   hence \<open>\<parallel>x\<parallel> \<noteq> 0\<close>
     by auto
   define y where \<open>y = x /\<^sub>R \<parallel>x\<parallel>\<close>
   have \<open>norm y = \<parallel> x /\<^sub>R \<parallel>x\<parallel> \<parallel>\<close>
     unfolding y_def by auto
   also have \<open>\<dots> = \<parallel>x\<parallel> /\<^sub>R \<parallel>x\<parallel>\<close>
     by auto
   also have \<open>\<dots> = 1\<close>
     using \<open>\<parallel>x\<parallel> \<noteq> 0\<close> by auto
   finally have \<open>\<parallel>y\<parallel> = 1\<close>
     by blast
   hence norm_1_non_empty: \<open>{ \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<noteq> {}\<close>
     by blast
   have norm_1_bounded: \<open>bdd_above { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
     unfolding bdd_above_def apply auto
     by (metis norm_blinfun)
   have norm_less_1_non_empty: \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} \<noteq> {}\<close>
     by (metis (mono_tags, lifting) Collect_empty_eq_bot bot_empty_eq empty_iff norm_zero 
         zero_less_one)   
   have norm_less_1_bounded: \<open>bdd_above {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
   proof-
     have \<open>\<exists>r. \<parallel>a r\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v (a r)\<parallel> \<le> r\<close> for a :: "real \<Rightarrow> 'a"
     proof-
       obtain r :: "('a \<Rightarrow>\<^sub>L 'b) \<Rightarrow> real" where
         "\<And>f x. 0 \<le> r f \<and> (bounded_linear f \<longrightarrow> \<parallel>f *\<^sub>v x\<parallel> \<le> \<parallel>x\<parallel> * r f)"
-        using bounded_linear.nonneg_bounded by moura
+        by (metis mult.commute norm_blinfun norm_ge_zero)
       have \<open>\<not> \<parallel>f\<parallel> < 0\<close>
         by simp          
       hence "(\<exists>r. \<parallel>f\<parallel> * \<parallel>a r\<parallel> \<le> r) \<or> (\<exists>r. \<parallel>a r\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v a r\<parallel> \<le> r)"
         by (meson less_eq_real_def mult_le_cancel_left2) 
       thus ?thesis using dual_order.trans norm_blinfun by blast
     qed
     hence \<open>\<exists> M. \<forall> x. \<parallel>x\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v x\<parallel> \<le> M\<close>
       by metis
     thus ?thesis by auto 
   qed
   have Sup_non_neg: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<ge> 0\<close>
     by (metis (mono_tags, lifting) \<open>\<parallel>y\<parallel> = 1\<close> cSup_upper2 mem_Collect_eq norm_1_bounded norm_ge_zero)
   have \<open>{0::real} \<noteq> {}\<close>
     by simp
   have \<open>bdd_above {0::real}\<close>
     by simp
   show \<open>\<parallel>f\<parallel> = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
   proof(cases \<open>\<forall>x. f *\<^sub>v x = 0\<close>)
     case True
     have \<open>\<parallel>f *\<^sub>v x\<parallel> = 0\<close> for x
       by (simp add: True)
     hence \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } \<subseteq> {0}\<close>
       by blast        
     moreover have \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } \<supseteq> {0}\<close>
       using calculation norm_less_1_non_empty by fastforce                        
     ultimately have \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } = {0}\<close>  
       by blast
     hence Sup1: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } = 0\<close> 
       by simp
     have \<open>\<parallel>f\<parallel> = 0\<close>
       by (simp add: True blinfun_eqI)        
     moreover have \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} = 0\<close>
       using Sup1 by blast
     ultimately show ?thesis by simp
   next
     case False
     have norm_f_eq_leq: \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<Longrightarrow> 
                          y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close> for y
     proof-
       assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       hence \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> \<and> \<parallel>x\<parallel> = 1\<close>
         by blast
       then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> and \<open>\<parallel>x\<parallel> = 1\<close>
         by auto
       define y' where \<open>y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R y\<close> for n
       have \<open>y' n \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close> for n
       proof-
         have \<open>y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R \<parallel>f *\<^sub>v x\<parallel>\<close>
           using y'_def \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> by blast
         also have \<open>... = \<bar>(1 - (inverse (real (Suc n))))\<bar> *\<^sub>R \<parallel>f *\<^sub>v x\<parallel>\<close>
           by (metis (mono_tags, opaque_lifting) \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> abs_1 abs_le_self_iff abs_of_nat 
               abs_of_nonneg add_diff_cancel_left' add_eq_if cancel_comm_monoid_add_class.diff_cancel
               diff_ge_0_iff_ge eq_iff_diff_eq_0 inverse_1 inverse_le_iff_le nat.distinct(1) of_nat_0
               of_nat_Suc of_nat_le_0_iff zero_less_abs_iff zero_neq_one)
         also have \<open>... = \<parallel>f *\<^sub>v ((1 - (inverse (real (Suc n)))) *\<^sub>R  x)\<parallel>\<close>
           by (simp add: blinfun.scaleR_right)            
         finally have y'_1: \<open>y' n = \<parallel>f *\<^sub>v ( (1 - (inverse (real (Suc n)))) *\<^sub>R x)\<parallel>\<close> 
           by blast
         have \<open>\<parallel>(1 - (inverse (Suc n))) *\<^sub>R x\<parallel> = (1 - (inverse (real (Suc n)))) * \<parallel>x\<parallel>\<close>
           by (simp add: linordered_field_class.inverse_le_1_iff)                
         hence \<open>\<parallel>(1 - (inverse (Suc n))) *\<^sub>R x\<parallel> < 1\<close>
           by (simp add: \<open>\<parallel>x\<parallel> = 1\<close>) 
         thus ?thesis using y'_1 by blast 
       qed
       have \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) ) \<longlonglongrightarrow> 1\<close>
         using Limits.LIMSEQ_inverse_real_of_nat_add_minus by simp
       hence \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \<longlonglongrightarrow> 1 *\<^sub>R y\<close>
         using Limits.tendsto_scaleR by blast
       hence \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \<longlonglongrightarrow> y\<close>
         by simp
       hence \<open>(\<lambda>n. y' n) \<longlonglongrightarrow> y\<close>
         using y'_def by simp
       hence \<open>y' \<longlonglongrightarrow> y\<close> 
         by simp
       have \<open>y' n \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close> for n
         using cSup_upper \<open>\<And>n. y' n \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close> norm_less_1_bounded by blast
       hence \<open>y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
         using \<open>y' \<longlonglongrightarrow> y\<close> Topological_Spaces.Sup_lim by (meson LIMSEQ_le_const2)
       thus ?thesis by blast
     qed
     hence \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
       by (metis (lifting) cSup_least norm_1_non_empty)
     have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} \<Longrightarrow> y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close> for y
     proof(cases \<open>y = 0\<close>)
       case True thus ?thesis by (simp add: Sup_non_neg) 
     next
       case False
       hence \<open>y \<noteq> 0\<close> by blast
       assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
       hence \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> \<and> \<parallel>x\<parallel> < 1\<close>
         by blast
       then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> and \<open>\<parallel>x\<parallel> < 1\<close>
         by blast
       have \<open>(1/\<parallel>x\<parallel>) * y = (1/\<parallel>x\<parallel>) * \<parallel>f x\<parallel>\<close>
         by (simp add: \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>)
       also have \<open>... = \<bar>1/\<parallel>x\<parallel>\<bar> * \<parallel>f *\<^sub>v x\<parallel>\<close>
         by simp
       also have \<open>... = \<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R (f *\<^sub>v x)\<parallel>\<close>
         by simp
       also have \<open>... = \<parallel>f *\<^sub>v ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
         by (simp add: blinfun.scaleR_right)          
       finally have \<open>(1/\<parallel>x\<parallel>) * y  = \<parallel>f *\<^sub>v ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
         by blast
       have \<open>x \<noteq> 0\<close>
         using  \<open>y \<noteq> 0\<close> \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> blinfun.zero_right by auto 
       have \<open>\<parallel> (1/\<parallel>x\<parallel>) *\<^sub>R x \<parallel> = \<bar> (1/\<parallel>x\<parallel>) \<bar> * \<parallel>x\<parallel>\<close>
         by simp
       also have \<open>... = (1/\<parallel>x\<parallel>) * \<parallel>x\<parallel>\<close>
         by simp
       finally have  \<open>\<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R x\<parallel> = 1\<close>
         using \<open>x \<noteq> 0\<close> by simp
       hence \<open>(1/\<parallel>x\<parallel>) * y \<in> { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
         using \<open>1 / \<parallel>x\<parallel> * y = \<parallel>f *\<^sub>v (1 / \<parallel>x\<parallel>) *\<^sub>R x\<parallel>\<close> by blast
       hence \<open>(1/\<parallel>x\<parallel>) * y \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
         by (simp add: cSup_upper norm_1_bounded)
       moreover have \<open>y \<le> (1/\<parallel>x\<parallel>) * y\<close>
         by (metis \<open>\<parallel>x\<parallel> < 1\<close> \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> mult_le_cancel_right1 norm_not_less_zero 
             order.strict_implies_order \<open>x \<noteq> 0\<close> less_divide_eq_1_pos zero_less_norm_iff)
       ultimately show ?thesis by linarith 
     qed
     hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       by (smt (verit, del_insts) less_cSupD norm_less_1_non_empty)
     hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} = Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
       using \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> |x. norm x = 1} \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close> by linarith
     have f1: \<open>(SUP x. \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> | x. True}\<close>
       by (simp add: full_SetCompr_eq)
     have \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} \<Longrightarrow> y \<in> { \<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
       for y
     proof-
       assume \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True}\<close> show ?thesis
       proof(cases \<open>y = 0\<close>)
         case True  thus ?thesis by simp 
       next
         case False
         have \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close>
           using \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True}\<close> by auto
         then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close>
           by blast
         hence \<open>y = \<bar>(1/\<parallel>x\<parallel>)\<bar> * \<parallel> f *\<^sub>v x \<parallel>\<close>
           by simp
         hence \<open>y = \<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R (f *\<^sub>v x)\<parallel>\<close>
           by simp
         hence \<open>y = \<parallel>f ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
           by (simp add: blinfun.scaleR_right)            
         moreover have \<open>\<parallel> (1/\<parallel>x\<parallel>) *\<^sub>R x \<parallel> = 1\<close>
           using False \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close> by auto
         ultimately have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close>
           by blast
         thus ?thesis by blast
       qed
     qed
     moreover have \<open>y \<in> {\<parallel>f x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0} \<Longrightarrow> y \<in> {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True}\<close>
       for y
     proof(cases \<open>y = 0\<close>)
       case True thus ?thesis by auto 
     next
       case False
       hence \<open>y \<notin> {0}\<close>
         by simp
       moreover assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
       ultimately have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close>
         by simp
       then obtain x where \<open>\<parallel>x\<parallel> = 1\<close> and \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>
         by auto
       have \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close> using  \<open>\<parallel>x\<parallel> = 1\<close>  \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>
         by simp 
       thus ?thesis by auto 
     qed
     ultimately have \<open>{\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} = {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
       by blast
     hence \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} = Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0})\<close>
       by simp
     have "\<And>r s. \<not> (r::real) \<le> s \<or> sup r s = s"
       by (metis (lifting) sup.absorb_iff1 sup_commute)
     hence \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {(0::real)})
              = max (Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}) (Sup {0::real})\<close>
       using \<open>0 \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close> \<open>bdd_above {0}\<close> \<open>{0} \<noteq> {}\<close> cSup_singleton 
         cSup_union_distrib max.absorb_iff1 sup_commute norm_1_bounded norm_1_non_empty
       by (metis (no_types, lifting) )
     moreover have \<open>Sup {(0::real)} = (0::real)\<close>
       by simp          
     ultimately have \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}) = Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close>
       using Sup_non_neg by linarith
     moreover have \<open>Sup ( {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}) 
                     = max (Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}) (Sup {0}) \<close>
       using Sup_non_neg  \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}) 
         = max (Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}) (Sup {0})\<close> 
       by auto           
     ultimately have f2: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> | x. True} = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       using \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} = Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0})\<close> by linarith
     have \<open>(SUP x. \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       using f1 f2 by linarith
     hence \<open>(SUP x. \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 }\<close>
       by (simp add: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} = Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close>)        
     thus ?thesis apply transfer by (simp add: onorm_def) 
   qed      
 qed
 
 lemma onorm_r:
   includes notation_norm
   assumes \<open>r > 0\<close>
   shows \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r)) / r\<close>
   text \<open>
   Explanation: The norm of \<^term>\<open>f\<close> is \<^term>\<open>1/r\<close> of the supremum of the norm of \<^term>\<open>f *\<^sub>v x\<close> for
   \<^term>\<open>x\<close> in the ball of radius \<^term>\<open>r\<close> centered at the origin.
 \<close>
 proof-
   have \<open>\<parallel>f\<parallel> = Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close>
     using onorm_open_ball by blast
   moreover have *: \<open>{\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1} = (\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 1)\<close>
     unfolding ball_def by auto
   ultimately have onorm_f: \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 1))\<close>
     by simp
   have s2: \<open>x \<in> (\<lambda>t. r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close> for x
   proof-
     assume \<open>x \<in> (\<lambda>t. r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
     hence \<open>\<exists> t. x = r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel> \<and> \<parallel>t\<parallel> < 1\<close>
       by auto
     then obtain t where t: \<open>x = r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>\<close> \<open>\<parallel>t\<parallel> < 1\<close>
       by blast
     define y where \<open>y = x /\<^sub>R r\<close>
     have \<open>x = r * (inverse r * x)\<close>
       using \<open>x = r *\<^sub>R norm (f t)\<close> by auto
     hence \<open>x - (r * (inverse r * x)) \<le> 0\<close>
       by linarith
     hence \<open>x \<le> r * (x /\<^sub>R r)\<close>
       by auto
     have \<open>y \<in> (\<lambda>k. \<parallel>f *\<^sub>v k\<parallel>) ` ball 0 1\<close>
       unfolding y_def using assms t * by fastforce 
     moreover have \<open>x \<le> r * y\<close>          
       using \<open>x \<le> r * (x /\<^sub>R r)\<close> y_def by blast
     ultimately have y_norm_f: \<open>y \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<and> x \<le> r * y\<close>
       by blast
     have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<noteq> {}\<close>
       by simp        
     moreover have \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close>
       by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above 
           bounded_norm_comp) 
     moreover have \<open>\<exists> y. y \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<and> x \<le> r * y\<close>
       using y_norm_f by blast
     ultimately show ?thesis
       by (meson assms cSup_upper dual_order.trans mult_le_cancel_left_pos)
   qed
   have s3: \<open>(\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y) \<Longrightarrow>
          r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1) \<le> y\<close> for y
   proof-
     assume \<open>\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y\<close> 
     have x_leq: \<open>x \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y / r\<close> for x
     proof-
       assume \<open>x \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
       then obtain t where \<open>t \<in> ball (0::'a) 1\<close> and \<open>x = \<parallel>f *\<^sub>v t\<parallel>\<close>
         by auto
       define x' where \<open>x' = r *\<^sub>R x\<close>
       have \<open>x' = r * \<parallel>f *\<^sub>v t\<parallel>\<close>
         by (simp add: \<open>x = \<parallel>f *\<^sub>v t\<parallel>\<close> x'_def)
       hence \<open>x' \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
         using \<open>t \<in> ball (0::'a) 1\<close> by auto
       hence \<open>x' \<le> y\<close>
         using \<open>\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y\<close> by blast        
       thus \<open>x \<le> y / r\<close>
         unfolding x'_def using \<open>r > 0\<close> by (simp add: mult.commute pos_le_divide_eq) 
     qed
     have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<noteq> {}\<close>
       by simp        
     moreover have \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close>
       by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above 
           bounded_norm_comp) 
     ultimately have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1) \<le> y/r\<close>
       using x_leq by (simp add: \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close> cSup_least) 
     thus ?thesis using \<open>r > 0\<close>
       by (simp add: mult.commute pos_le_divide_eq)
   qed
   have norm_scaleR: \<open>norm \<circ> ((*\<^sub>R) r) = ((*\<^sub>R) \<bar>r\<bar>) \<circ> (norm::'a \<Rightarrow> real)\<close>
     by auto
   have f_x1: \<open>f (r *\<^sub>R x) = r *\<^sub>R f x\<close> for x
     by (simp add: blinfun.scaleR_right)    
   have \<open>ball (0::'a) r = ((*\<^sub>R) r) ` (ball 0 1)\<close>
     by (smt assms ball_scale nonzero_mult_div_cancel_left right_inverse_eq scale_zero_right)
   hence \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) = Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (((*\<^sub>R) r) ` (ball 0 1)))\<close>
     by simp
   also have \<open>\<dots> = Sup (((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) \<circ> ((*\<^sub>R) r)) ` (ball 0 1))\<close>
     using Sup.SUP_image by auto
   also have \<open>\<dots> = Sup ((\<lambda>t. \<parallel>f *\<^sub>v (r *\<^sub>R t)\<parallel>) ` (ball 0 1))\<close>
     using f_x1 by (simp add: comp_assoc) 
   also have \<open>\<dots> = Sup ((\<lambda>t. \<bar>r\<bar> *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
     using norm_scaleR f_x1 by auto 
   also have \<open>\<dots> = Sup ((\<lambda>t. r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
     using \<open>r > 0\<close> by auto
   also have \<open>\<dots> = r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
     apply (rule cSup_eq_non_empty) apply simp using s2 apply auto using s3 by auto
   also have \<open>\<dots> = r * \<parallel>f\<parallel>\<close>
     using onorm_f by auto
   finally have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 r) = r * \<parallel>f\<parallel>\<close>
     by blast    
   thus \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r)) / r\<close> using \<open>r > 0\<close> by simp
 qed
 
 text\<open>Pointwise convergence\<close>
 definition pointwise_convergent_to :: 
   \<open>( nat \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) ) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool\<close> 
   (\<open>((_)/ \<midarrow>pointwise\<rightarrow> (_))\<close> [60, 60] 60) where
   \<open>pointwise_convergent_to x l = (\<forall> t::'a. (\<lambda> n. (x n) t) \<longlonglongrightarrow> l t)\<close>
 
 lemma linear_limit_linear:
   fixes f :: \<open>_ \<Rightarrow> ('a::real_vector \<Rightarrow> 'b::real_normed_vector)\<close>
   assumes  \<open>\<And>n. linear (f n)\<close> and \<open>f \<midarrow>pointwise\<rightarrow> F\<close>
   shows \<open>linear F\<close>
   text\<open>
   Explanation: If a family of linear operators converges pointwise, then the limit is also a linear
   operator.
 \<close>
 proof
   show "F (x + y) = F x + F y" for x y
   proof-
     have "\<forall>a. F a = lim (\<lambda>n. f n a)"
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by (metis (full_types) limI)
     moreover have "\<forall>f b c g. (lim (\<lambda>n. g n + f n) = (b::'b) + c \<or> \<not> f \<longlonglongrightarrow> c) \<or> \<not> g \<longlonglongrightarrow> b"
       by (metis (no_types) limI tendsto_add)
     moreover have "\<And>a. (\<lambda>n. f n a) \<longlonglongrightarrow> F a"
       using assms(2) pointwise_convergent_to_def by force
     ultimately have 
       lim_sum: \<open>lim (\<lambda> n. (f n) x + (f n) y) = lim (\<lambda> n. (f n) x) + lim (\<lambda> n. (f n) y)\<close>
       by metis
     have \<open>(f n) (x + y) = (f n) x + (f n) y\<close> for n
       using \<open>\<And> n.  linear (f n)\<close> unfolding linear_def using Real_Vector_Spaces.linear_iff assms(1) 
       by auto
     hence \<open>lim (\<lambda> n. (f n) (x + y)) = lim (\<lambda> n. (f n) x + (f n) y)\<close>
       by simp
     hence \<open>lim (\<lambda> n. (f n) (x + y)) = lim (\<lambda> n. (f n) x) + lim (\<lambda> n. (f n) y)\<close>
       using lim_sum by simp
     moreover have \<open>(\<lambda> n. (f n) (x + y)) \<longlonglongrightarrow> F (x + y)\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     moreover have \<open>(\<lambda> n. (f n) x) \<longlonglongrightarrow> F x\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     moreover have \<open>(\<lambda> n. (f n) y) \<longlonglongrightarrow> F y\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     ultimately show ?thesis
       by (metis limI) 
   qed
   show "F (r *\<^sub>R x) = r *\<^sub>R F x" for r and x
   proof-
     have \<open>(f n) (r *\<^sub>R x) = r *\<^sub>R (f n) x\<close> for n
       using  \<open>\<And> n.  linear (f n)\<close> 
       by (simp add: Real_Vector_Spaces.linear_def real_vector.linear_scale)
     hence \<open>lim (\<lambda> n. (f n) (r *\<^sub>R x)) = lim (\<lambda> n. r *\<^sub>R (f n) x)\<close>
       by simp
     have \<open>convergent (\<lambda> n. (f n) x)\<close>
       by (metis assms(2) convergentI pointwise_convergent_to_def)
     moreover have \<open>isCont (\<lambda> t::'b. r *\<^sub>R t) tt\<close> for tt
       by (simp add: bounded_linear_scaleR_right)
     ultimately have \<open>lim (\<lambda> n. r *\<^sub>R ((f n) x)) =  r *\<^sub>R lim (\<lambda> n. (f n) x)\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def 
       by (metis (mono_tags) isCont_tendsto_compose limI)
     hence \<open>lim (\<lambda> n.  (f n) (r *\<^sub>R x)) = r *\<^sub>R lim (\<lambda> n. (f n) x)\<close> 
       using \<open>lim (\<lambda> n. (f n) (r *\<^sub>R x)) = lim (\<lambda> n. r *\<^sub>R (f n) x)\<close> by simp
     moreover have \<open>(\<lambda> n. (f n) x) \<longlonglongrightarrow> F x\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     moreover have \<open>(\<lambda> n.  (f n) (r *\<^sub>R x)) \<longlonglongrightarrow> F (r *\<^sub>R x)\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     ultimately show ?thesis
       by (metis limI) 
   qed
 qed
 
 
 lemma non_Cauchy_unbounded:
   fixes a ::\<open>_ \<Rightarrow> real\<close> 
   assumes \<open>\<And>n. a n \<ge> 0\<close> and \<open>e > 0\<close> 
     and \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
   shows \<open>(\<lambda>n. (sum a  {0..n})) \<longlonglongrightarrow> \<infinity>\<close>
   text\<open>
   Explanation: If the sequence of partial sums of nonnegative terms is not Cauchy, then it converges
   to infinite.
 \<close>
 proof-
   define S::"ereal set" where \<open>S = range (\<lambda>n. sum a  {0..n})\<close>
   have \<open>\<exists>s\<in>S.  k*e \<le> s\<close> for k::nat
   proof(induction k)
     case 0
     from \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
     obtain m n where \<open>m \<ge> 0\<close> and \<open>n \<ge> 0\<close> and \<open>m > n\<close> and \<open>sum a {Suc n..m} \<ge> e\<close> by blast
     have \<open>n < Suc n\<close>
       by simp
     hence \<open>{0..n} \<union> {Suc n..m} = {0..m}\<close>
       using Set_Interval.ivl_disj_un(7) \<open>n < m\<close> by auto
     moreover have \<open>finite {0..n}\<close>
       by simp
     moreover have \<open>finite {Suc n..m}\<close>
       by simp
     moreover have \<open>{0..n} \<inter> {Suc n..m} = {}\<close>
       by simp
     ultimately have \<open>sum a {0..n} + sum a {Suc n..m} = sum a {0..m}\<close>
       by (metis sum.union_disjoint) 
     moreover have \<open>sum a {Suc n..m} > 0\<close>
       using \<open>e > 0\<close> \<open>sum a {Suc n..m} \<ge> e\<close> by linarith
     moreover have \<open>sum a {0..n} \<ge> 0\<close>
       by (simp add: assms(1) sum_nonneg)
     ultimately have \<open>sum a {0..m} > 0\<close>
       by linarith      
     moreover have \<open>sum a {0..m} \<in> S\<close>
       unfolding S_def by blast
     ultimately have \<open>\<exists>s\<in>S. 0 \<le> s\<close>
       using ereal_less_eq(5) by fastforce    
     thus ?case
       by (simp add: zero_ereal_def)  
   next
     case (Suc k)
     assume \<open>\<exists>s\<in>S. k*e \<le> s\<close>
     then obtain s where \<open>s\<in>S\<close> and \<open>ereal (k * e) \<le> s\<close>
       by blast
     have \<open>\<exists>N. s = sum a {0..N}\<close>
       using \<open>s\<in>S\<close> unfolding S_def by blast
     then obtain N where \<open>s = sum a {0..N}\<close>
       by blast
     from \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
     obtain m n where \<open>m \<ge> Suc N\<close> and \<open>n \<ge> Suc N\<close> and \<open>m > n\<close> and \<open>sum a {Suc n..m} \<ge> e\<close>
       by blast
     have \<open>finite {Suc N..n}\<close>
       by simp
     moreover have \<open>finite {Suc n..m}\<close>
       by simp
     moreover have \<open>{Suc N..n} \<union> {Suc n..m} = {Suc N..m}\<close>
       using Set_Interval.ivl_disj_un
       by (metis \<open>Suc N \<le> n\<close> \<open>n < m\<close> atLeastSucAtMost_greaterThanAtMost order_less_imp_le)
     moreover have \<open>{} = {Suc N..n} \<inter> {Suc n..m}\<close>
       by simp
     ultimately have \<open>sum a {Suc N..m} = sum a {Suc N..n} + sum a {Suc n..m}\<close>
       by (metis sum.union_disjoint)
     moreover have \<open>sum a {Suc N..n} \<ge> 0\<close>
       using  \<open>\<And>n. a n \<ge> 0\<close> by (simp add: sum_nonneg) 
     ultimately have \<open>sum a {Suc N..m} \<ge> e\<close>
       using \<open>e \<le> sum a {Suc n..m}\<close> by linarith
     have \<open>finite {0..N}\<close>
       by simp
     have \<open>finite {Suc N..m}\<close>
       by simp
     moreover have \<open>{0..N} \<union> {Suc N..m} = {0..m}\<close>
       using Set_Interval.ivl_disj_un(7) \<open>Suc N \<le> m\<close> by auto          
     moreover have \<open>{0..N} \<inter> {Suc N..m} = {}\<close>
       by simp
     ultimately have \<open>sum a {0..N} + sum a {Suc N..m} =  sum a {0..m}\<close> 
       by (metis \<open>finite {0..N}\<close> sum.union_disjoint)    
     hence \<open>e + k * e \<le> sum a {0..m}\<close>
       using \<open>ereal (real k * e) \<le> s\<close> \<open>s = ereal (sum a {0..N})\<close> \<open>e \<le> sum a {Suc N..m}\<close> by auto 
     moreover have \<open>e + k * e = (Suc k) * e\<close>
       by (simp add: semiring_normalization_rules(3))
     ultimately have \<open>(Suc k) * e \<le> sum a {0..m}\<close>
       by linarith
     hence \<open>ereal ((Suc k) * e) \<le> sum a {0..m}\<close>
       by auto
     moreover have \<open>sum a {0..m}\<in>S\<close>
       unfolding S_def by blast
     ultimately show ?case by blast
   qed
   hence \<open>\<exists>s\<in>S. (real n) \<le> s\<close> for n
     by (meson assms(2) ereal_le_le ex_less_of_nat_mult less_le_not_le)
   hence  \<open>Sup S = \<infinity>\<close>
     using Sup_le_iff Sup_subset_mono dual_order.strict_trans1 leD less_PInf_Ex_of_nat subsetI 
     by metis
   hence Sup: \<open>Sup ((range (\<lambda> n. (sum a  {0..n})))::ereal set) = \<infinity>\<close> using S_def 
     by blast
   have \<open>incseq (\<lambda>n. (sum a  {..<n}))\<close>
     using \<open>\<And>n. a n \<ge> 0\<close> using Extended_Real.incseq_sumI by auto
   hence \<open>incseq (\<lambda>n. (sum a  {..< Suc n}))\<close>
     by (meson incseq_Suc_iff)
   hence \<open>incseq (\<lambda>n. (sum a  {0..n})::ereal)\<close>
     using incseq_ereal by (simp add: atLeast0AtMost lessThan_Suc_atMost) 
   hence \<open>(\<lambda>n. sum a  {0..n}) \<longlonglongrightarrow> Sup (range (\<lambda>n. (sum a  {0..n})::ereal))\<close>
     using LIMSEQ_SUP by auto
   thus ?thesis using Sup PInfty_neq_ereal by auto 
 qed
 
 lemma sum_Cauchy_positive:
   fixes a ::\<open>_ \<Rightarrow> real\<close>
   assumes \<open>\<And>n. a n \<ge> 0\<close> and \<open>\<exists>K. \<forall>n. (sum a  {0..n}) \<le> K\<close>
   shows \<open>Cauchy (\<lambda>n. sum a {0..n})\<close>
   text\<open>
   Explanation: If a series of nonnegative reals is bounded, then the series is 
   Cauchy.
 \<close>
 proof (unfold Cauchy_altdef2, rule, rule)
   fix e::real
   assume \<open>e>0\<close>       
   have \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
   proof(rule classical)
     assume \<open>\<not>(\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e)\<close>
     hence \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> \<not>(sum a {Suc n..m} < e)\<close>
       by blast
     hence \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
       by fastforce
     hence \<open>(\<lambda>n. (sum a  {0..n}) ) \<longlonglongrightarrow> \<infinity>\<close>
       using non_Cauchy_unbounded \<open>0 < e\<close> assms(1) by blast
     from  \<open>\<exists>K. \<forall>n. sum a  {0..n} \<le> K\<close>
     obtain K where  \<open>\<forall>n. sum a {0..n} \<le> K\<close>
       by blast
     from  \<open>(\<lambda>n. sum a {0..n})  \<longlonglongrightarrow> \<infinity>\<close>
     have \<open>\<forall>B. \<exists>N. \<forall>n\<ge>N. (\<lambda> n. (sum a  {0..n}) ) n \<ge> B\<close>
       using Lim_PInfty by simp
     hence  \<open>\<exists>n. (sum a {0..n}) \<ge> K+1\<close>
       using ereal_less_eq(3) by blast        
     thus ?thesis using  \<open>\<forall>n. (sum a  {0..n}) \<le> K\<close> by (smt (verit, best))
   qed
   have \<open>sum a {Suc n..m} = sum a {0..m} - sum a {0..n}\<close>
     if "m > n" for m n
     by (metis add_diff_cancel_left' atLeast0AtMost less_imp_add_positive sum_up_index_split that)
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
     using \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close> by presburger
   then obtain M where \<open>\<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
     by blast
   moreover have \<open>m > n \<Longrightarrow> sum a {0..m} \<ge> sum a {0..n}\<close> for m n
     using \<open>\<And> n. a n \<ge> 0\<close> by (simp add: sum_mono2)
   ultimately have \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
     by auto
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m \<ge> n \<longrightarrow> \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
     by (metis \<open>0 < e\<close> abs_zero cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq' 
         less_irrefl_nat linorder_neqE_nat zero_less_diff)      
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
     by (metis abs_minus_commute nat_le_linear)
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>
     by (simp add: dist_real_def)      
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close> by blast
   thus \<open>\<exists>N. \<forall>n\<ge>N. dist (sum a {0..n}) (sum a {0..N}) < e\<close> by auto
 qed
 
 lemma convergent_series_Cauchy:
   fixes a::\<open>nat \<Rightarrow> real\<close> and \<phi>::\<open>nat \<Rightarrow> 'a::metric_space\<close>
   assumes \<open>\<exists>M. \<forall>n. sum a {0..n} \<le> M\<close> and \<open>\<And>n. dist (\<phi> (Suc n)) (\<phi> n) \<le> a n\<close>
   shows \<open>Cauchy \<phi>\<close>
   text\<open>
   Explanation: Let \<^term>\<open>a\<close> be a real-valued sequence and let \<^term>\<open>\<phi>\<close> be sequence in a metric space.
   If the partial sums of \<^term>\<open>a\<close> are uniformly bounded and the distance between consecutive terms of \<^term>\<open>\<phi>\<close>
   are bounded by the sequence \<^term>\<open>a\<close>, then \<^term>\<open>\<phi>\<close> is Cauchy.\<close>
 proof (unfold Cauchy_altdef2, rule, rule)
   fix e::real
   assume \<open>e > 0\<close>
   have \<open>\<And>k. a k \<ge> 0\<close>
     using \<open>\<And>n. dist (\<phi> (Suc n)) (\<phi> n) \<le> a n\<close> dual_order.trans zero_le_dist by blast
   hence \<open>Cauchy (\<lambda>k. sum a {0..k})\<close>
     using  \<open>\<exists>M. \<forall>n. sum a {0..n} \<le> M\<close> sum_Cauchy_positive by blast
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>
     unfolding Cauchy_def using \<open>e > 0\<close> by blast
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> dist (sum a {0..m}) (sum a {0..n}) < e\<close>
     by blast
   have \<open>dist (sum a {0..m}) (sum a {0..n}) = sum a {Suc n..m}\<close> if \<open>n<m\<close> for m n
   proof -
     have \<open>n < Suc n\<close>
       by simp
     have \<open>finite {0..n}\<close>
       by simp
     moreover have \<open>finite {Suc n..m}\<close>
       by simp
     moreover have \<open>{0..n} \<union> {Suc n..m} = {0..m}\<close>
       using \<open>n < Suc n\<close> \<open>n < m\<close> by auto
     moreover have  \<open>{0..n} \<inter> {Suc n..m} = {}\<close>
       by simp
     ultimately have sum_plus: \<open>(sum a {0..n}) + sum a {Suc n..m} = (sum a {0..m})\<close>
       by (metis sum.union_disjoint)
     have \<open>dist (sum a {0..m}) (sum a {0..n}) = \<bar>(sum a {0..m}) - (sum a {0..n})\<bar>\<close>
       using dist_real_def by blast
     moreover have \<open>(sum a {0..m}) - (sum a {0..n}) = sum a {Suc n..m}\<close>
       using sum_plus by linarith 
     ultimately show ?thesis
       by (simp add: \<open>\<And>k. 0 \<le> a k\<close> sum_nonneg)
   qed
   hence sum_a: \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
     by (metis \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>) 
   obtain M where \<open>\<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
     using sum_a \<open>e > 0\<close> by blast
   hence  \<open>\<forall>m. \<forall>n. Suc m \<ge> Suc M \<and> Suc n \<ge> Suc M \<and> Suc m > Suc n \<longrightarrow> sum a {Suc n..Suc m - 1} < e\<close>
     by simp
   hence  \<open>\<forall>m\<ge>1. \<forall>n\<ge>1. m \<ge> Suc M \<and> n \<ge> Suc M \<and> m > n \<longrightarrow> sum a {n..m - 1} < e\<close>
     by (metis Suc_le_D)
   hence sum_a2: \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {n..m-1} < e\<close>
     by (meson add_leE)
   have \<open>dist (\<phi> (n+p+1)) (\<phi> n) \<le> sum a {n..n+p}\<close> for p n :: nat
   proof(induction p)
     case 0 thus ?case  by (simp add: assms(2))
   next
     case (Suc p) thus ?case
       by (smt(verit, ccfv_SIG) Suc_eq_plus1 add_Suc_right add_less_same_cancel1 assms(2) dist_self dist_triangle2 
           gr_implies_not0 sum.cl_ivl_Suc)  
   qed
   hence \<open>m > n \<Longrightarrow> dist (\<phi> m) (\<phi> n) \<le> sum a {n..m-1}\<close> for m n :: nat
     by (metis Suc_eq_plus1 Suc_le_D diff_Suc_1  gr0_implies_Suc less_eq_Suc_le less_imp_Suc_add 
         zero_less_Suc)
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> dist (\<phi> m) (\<phi> n) < e\<close> 
     using sum_a2 \<open>e > 0\<close> by smt
   thus "\<exists>N. \<forall>n\<ge>N. dist (\<phi> n) (\<phi> N) < e"
     using \<open>0 < e\<close> by fastforce
 qed
 
 unbundle notation_blinfun_apply
 
 unbundle no_notation_norm
 
 end
diff --git a/thys/BenOr_Kozen_Reif/Matrix_Equation_Construction.thy b/thys/BenOr_Kozen_Reif/Matrix_Equation_Construction.thy
--- a/thys/BenOr_Kozen_Reif/Matrix_Equation_Construction.thy
+++ b/thys/BenOr_Kozen_Reif/Matrix_Equation_Construction.thy
@@ -1,884 +1,865 @@
 theory Matrix_Equation_Construction
 
 imports BKR_Algorithm
 begin
 
 section "Results with Sturm's Theorem"
 
 lemma relprime:
   fixes q::"real poly"
   assumes "coprime p q"
   assumes "p \<noteq> 0"
   assumes "q \<noteq> 0"
   shows "changes_R_smods p (pderiv p) = card {x. poly p x = 0 \<and> poly q x > 0} + card {x. poly p x = 0 \<and> poly q x < 0}"
 proof -
   have 1: "{x. poly p x = 0 \<and> poly q x = 0} = {}"
     using assms(1) coprime_poly_0 by auto
   have 2: "changes_R_smods p (pderiv p) = int (card {x . poly p x = 0})" using sturm_R by auto
   have 3: "{x. poly p x = 0 \<and> poly q x > 0} \<inter> {x. poly p x = 0 \<and> poly q x < 0} = {}" by auto
   have "{x . poly p x = 0} =  {x. poly p x = 0 \<and> poly q x > 0} \<union>{x. poly p x = 0 \<and> poly q x < 0} \<union> {x. poly p x = 0 \<and> poly q x = 0}" by force
   then have "{x . poly p x = 0} = {x. poly p x = 0 \<and> poly q x > 0} \<union>{x. poly p x = 0 \<and> poly q x < 0}" using 1 by auto
   then have "(card {x . poly p x = 0}) = (card ({x. poly p x = 0 \<and> poly q x > 0} \<union>{x. poly p x = 0 \<and> poly q x < 0}))" by presburger
   then have 4: "(card {x . poly p x = 0}) =  card {x. poly p x = 0 \<and> poly q x > 0} + card {x. poly p x = 0 \<and> poly q x < 0}" using 3 by (simp add: card_Un_disjoint assms(2) poly_roots_finite)
   show ?thesis  by (simp add: "2" "4")
 qed
 
 (* This is the same proof as card_eq_sum *)
 lemma card_eq_const_sum: 
   fixes k:: real
   assumes "finite A"
   shows "k*card A = sum (\<lambda>x. k) A"
 proof -
   have "plus \<circ> (\<lambda>_. Suc 0) = (\<lambda>_. Suc)"
     by (simp add: fun_eq_iff)
   then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) = Finite_Set.fold (\<lambda>_. Suc)"
     by (rule arg_cong)
   then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) 0 A = Finite_Set.fold (\<lambda>_. Suc) 0 A"
     by (blast intro: fun_cong)
   then show ?thesis
     by (simp add: card.eq_fold sum.eq_fold)
 qed
 
 lemma restate_tarski:
   fixes q::"real poly"
   assumes "coprime p q"
   assumes "p \<noteq> 0"       
   assumes "q \<noteq> 0"
   shows "changes_R_smods p ((pderiv p) * q) = card {x. poly p x = 0 \<and> poly q x > 0} -  int(card {x. poly p x = 0 \<and> poly q x < 0})"
 proof -
   have 3: "taq {x. poly p x=0} q \<equiv> \<Sum>y\<in>{x. poly p x=0}. Sturm_Tarski.sign (poly q y)" by (simp add: taq_def)
   have 4: "{x. poly p x=0} =  {x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0} \<union> {x. poly p x = 0 \<and> poly q x = 0}" by force
   then have 5: "{x. poly p x=0} =  {x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}" using assms(1) coprime_poly_0 by auto
   then have 6: "\<Sum>y\<in>{x. poly p x=0}. Sturm_Tarski.sign (poly q y) \<equiv> \<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}. Sturm_Tarski.sign (poly q y)" by presburger
   then have 12: "taq {x. poly p x=0} q \<equiv> \<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}. Sturm_Tarski.sign (poly q y)"
     by (simp add: "3") 
   have 7: "{x. poly p x = 0 \<and> poly q x > 0} \<inter> {x. poly p x = 0 \<and> poly q x < 0} = {}" by auto
   then have 8: "\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}. Sturm_Tarski.sign (poly q y) \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.Sturm_Tarski.sign (poly q y)) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.Sturm_Tarski.sign(poly q y))" by (simp add: assms(2) poly_roots_finite sum.union_disjoint)
   then have 13: "taq {x. poly p x=0} q \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.Sturm_Tarski.sign (poly q y)) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.Sturm_Tarski.sign(poly q y))"
     by (simp add: "12") 
   then have 9: "taq {x. poly p x = 0} q \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.1) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.(-1))" by simp
   have 10: "(\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.1) =  card {x. poly p x = 0 \<and> poly q x > 0}" using card_eq_sum by auto
   have 11: " (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.(-1)) = -1*card {x. poly p x = 0 \<and> poly q x < 0}" using card_eq_const_sum by simp
   have 14: "taq {x. poly p x = 0} q \<equiv> card {x. poly p x = 0 \<and> poly q x > 0} + -1*card {x. poly p x = 0 \<and> poly q x < 0}" using 9 10 11 by simp
   have 1: "changes_R_smods p (pderiv p * q) = taq {x. poly p x=0} q" using sturm_tarski_R by simp
   then have 15: "changes_R_smods p (pderiv p * q) = card {x. poly p x = 0 \<and> poly q x > 0} + (-1*card {x. poly p x = 0 \<and> poly q x < 0})" using 14 by linarith
   have 16: "(-1*card {x. poly p x = 0 \<and> poly q x < 0}) = - card {x. poly p x = 0 \<and> poly q x < 0}" by auto
   then show ?thesis using 15 by linarith
 qed
 
 lemma restate_tarski2:
   fixes q::"real poly"
   assumes "p \<noteq> 0"
   shows "changes_R_smods p ((pderiv p) * q) =
         int(card {x. poly p x = 0 \<and> poly q x > 0}) -
         int(card {x. poly p x = 0 \<and> poly q x < 0})"
   unfolding sturm_tarski_R[symmetric] taq_def
 proof -
   let ?all = "{x. poly p x=0}"
   let ?lt = "{x. poly p x=0 \<and> poly q x < 0}"
   let ?gt = "{x. poly p x=0 \<and> poly q x > 0}"
   let ?eq = "{x. poly p x=0 \<and> poly q x = 0}"
   have eq: "?all = ?lt \<union> ?gt \<union> ?eq" by force
   from poly_roots_finite[OF assms] have fin: "finite ?all" .
   show  "(\<Sum>x | poly p x = 0. Sturm_Tarski.sign (poly q x)) = int (card ?gt) - int (card ?lt)"
     unfolding eq
     apply (subst sum_Un)
       apply (auto simp add:fin)
     apply (subst sum_Un)
     by (auto simp add:fin)
 qed
 
 lemma coprime_set_prod:
   fixes I:: "real poly set"
   shows "finite I \<Longrightarrow> ((\<forall> q \<in> I. (coprime p q)) \<longrightarrow> (coprime p (\<Prod> I)))"
 proof (induct rule: finite_induct)
   case empty
   then show ?case
     by simp 
 next
   case (insert x F)
   then show ?case using coprime_mult_right_iff
     by simp
 qed
 
 lemma finite_nonzero_set_prod:
   fixes I:: "real poly set"
   shows  nonzero_hyp: "finite I \<Longrightarrow> ((\<forall> q \<in> I. q \<noteq> 0) \<longrightarrow> \<Prod> I \<noteq> 0)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case
     by simp 
 next
   case (insert x F)
   have h: "\<Prod> (insert x F) = x * (\<Prod> F)"
     by (simp add: insert.hyps(1) insert.hyps(2)) 
   have h_xin: "x \<in> insert x F"
     by simp 
   have hq: "(\<forall> q \<in> (insert x F). q \<noteq> 0) \<longrightarrow> x \<noteq> 0" using h_xin
     by blast 
   show ?case using h hq
     using insert.hyps(3) by auto
 qed
 
 section "Setting up the construction: Definitions"
 
 definition characterize_root_list_p:: "real poly \<Rightarrow> real list"
   where "characterize_root_list_p p \<equiv> sorted_list_of_set({x. poly p x = 0}::real set)"
 
 (************** Renegar's N(I); towards defining the RHS of the matrix equation **************)
 
 lemma construct_NofI_prop:
   fixes p:: "real poly"
   fixes I:: "real poly list"
   assumes nonzero: "p\<noteq>0"
   shows "construct_NofI p I =
     rat_of_int (int (card {x. poly p x = 0 \<and> poly (prod_list I) x > 0}) - 
     int (card {x. poly p x = 0 \<and> poly (prod_list I) x < 0}))"
   unfolding construct_NofI_def
   using assms restate_tarski2 nonzero rsquarefree_def
   by (simp add: rsquarefree_def)
 
 definition construct_s_vector:: "real poly \<Rightarrow> real poly list list \<Rightarrow> rat vec"
   where "construct_s_vector p Is = vec_of_list (map (\<lambda> I.(construct_NofI p I)) Is)"
 
 (* Consistent Sturm_Tarski.sign asSturm_Tarski.signments *)
 definition squash::"'a::linordered_field \<Rightarrow> rat"
   where "squash x = (if x > 0 then 1
                     else if x < 0 then -1
                     else 0)"
 
 definition signs_at::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
   where "signs_at qs x \<equiv>
     map (squash \<circ> (\<lambda>q. poly q x)) qs"
 
 definition characterize_consistent_signs_at_roots:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
   where "characterize_consistent_signs_at_roots p qs =
   (remdups (map (signs_at qs) (characterize_root_list_p p)))"
 
 (* An alternate version designed to be used when every polynomial in qs is relatively prime to p*)
 definition consistent_sign_vec_copr::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
   where "consistent_sign_vec_copr qs x \<equiv>
     map (\<lambda> q. if (poly q x > 0) then (1::rat) else (-1::rat)) qs"
 
 definition characterize_consistent_signs_at_roots_copr:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
   where "characterize_consistent_signs_at_roots_copr p qss =
   (remdups (map (consistent_sign_vec_copr qss) (characterize_root_list_p p)))"
 
 lemma csa_list_copr_rel:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   assumes nonzero: "p\<noteq>0"
   assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   shows "characterize_consistent_signs_at_roots p qs = characterize_consistent_signs_at_roots_copr p qs"
 proof - 
   have "\<forall>q \<in> set(qs). \<forall> x \<in> set (characterize_root_list_p p).  poly q x \<noteq> 0"
     using pairwise_rel_prime
     using coprime_poly_0 in_set_member nonzero poly_roots_finite characterize_root_list_p_def by fastforce 
   then have h: "\<forall>q \<in> set(qs). \<forall> x \<in> set (characterize_root_list_p p). squash (poly q x) = (if (poly q x > 0) then (1::rat) else (-1::rat))"
     by (simp add: squash_def)
   have "map (\<lambda>r. map (\<lambda>p. if 0 < poly p r then 1 else - 1) qs) (characterize_root_list_p p) = map (\<lambda>r. map (squash \<circ> (\<lambda>p. poly p r)) qs) (characterize_root_list_p p)"
     by (simp add: h)
   thus ?thesis unfolding characterize_consistent_signs_at_roots_def characterize_consistent_signs_at_roots_copr_def
       signs_at_def consistent_sign_vec_copr_def
     by presburger
 qed
 
 (************** Towards defining Renegar's polynomial function and the LHS of the matrix equation **************)
 
 definition list_constr:: "nat list \<Rightarrow> nat \<Rightarrow> bool"
   where "list_constr L n \<equiv> list_all (\<lambda>x. x < n) L"
 
 definition all_list_constr:: "nat list list \<Rightarrow> nat \<Rightarrow> bool"
   where "all_list_constr L n \<equiv> (\<forall>x. List.member L x \<longrightarrow> list_constr x n)"
 
 (* The first input is the subset; the second input is the consistent Sturm_Tarski.sign asSturm_Tarski.signment.
   We want to map over the first list and pull out all of the elements in the second list with
   corresponding positions, and then multiply those together.
 *)
 definition z:: "nat list \<Rightarrow> rat list \<Rightarrow> rat"
   where "z index_list sign_asg \<equiv> (prod_list (map (nth sign_asg) index_list))"
 
 definition mtx_row:: "rat list list \<Rightarrow> nat list \<Rightarrow> rat list"
   where "mtx_row sign_list index_list \<equiv> (map ( (z index_list)) sign_list)"
 
 definition matrix_A:: "rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat" 
   where "matrix_A sign_list subset_list = 
     (mat_of_rows_list (length sign_list) (map (\<lambda>i .(mtx_row sign_list i)) subset_list))"
 
 definition alt_matrix_A:: "rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat"
   where "alt_matrix_A signs subsets = (mat (length subsets) (length signs) 
     (\<lambda>(i, j). z (subsets ! i) (signs ! j)))"
 
 lemma alt_matrix_char: "alt_matrix_A signs subsets = matrix_A signs subsets"
 proof - 
   have h0: "(\<And>i j. i < length subsets \<Longrightarrow>
             j < length signs \<Longrightarrow>
             map (\<lambda>index_list. map (z index_list) signs) subsets ! i ! j = z (subsets ! i) (signs ! j))"
   proof -
     fix i
     fix j
     assume i_lt: "i < length subsets"
     assume j_lt: "j < length signs"
     show "((map (\<lambda>index_list. map (z index_list) signs) subsets) ! i) ! j = z (subsets ! i) (signs ! j)"
     proof - 
       have h0: "(map (\<lambda>index_list. map (z index_list) signs) subsets) ! i =  map (z (subsets ! i)) signs" 
         using nth_map i_lt
         by blast
       then show ?thesis using nth_map j_lt
         by simp 
     qed
   qed
   have h: " mat (length subsets) (length signs) (\<lambda>(i, j). z (subsets ! i) (signs ! j)) =
     mat (length subsets) (length signs) (\<lambda>(i, y). map (\<lambda>index_list. map (z index_list) signs) subsets ! i ! y)"
     using h0 eq_matI[where A = "mat (length subsets) (length signs) (\<lambda>(i, j). z (subsets ! i) (signs ! j))",
         where B = "mat (length subsets) (length signs) (\<lambda>(i, y). map (\<lambda>index_list. map (z index_list) signs) subsets ! i ! y)"]
     by auto
   show ?thesis unfolding alt_matrix_A_def matrix_A_def mat_of_rows_list_def apply (auto) unfolding mtx_row_def
     using h   by blast
 qed
 
 lemma subsets_are_rows: "\<forall>i < (length subsets). row (alt_matrix_A signs subsets) i  = vec (length signs) (\<lambda>j. z (subsets ! i) (signs ! j))"
   unfolding row_def unfolding alt_matrix_A_def by auto
 
 lemma signs_are_cols: "\<forall>i < (length signs). col (alt_matrix_A signs subsets) i  = vec (length subsets) (\<lambda>j. z (subsets ! j) (signs ! i))"
   unfolding col_def unfolding alt_matrix_A_def 
   by auto
 
 (* ith entry of LHS vector is the number of (distinct) real zeros of p where the Sturm_Tarski.sign vector of the qs  is the ith entry of Sturm_Tarski.signs.*)
 definition construct_lhs_vector:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list  \<Rightarrow> rat vec"
   where "construct_lhs_vector p qs signs \<equiv>
   vec_of_list (map (\<lambda>w.  rat_of_int (int (length (filter (\<lambda>v. v = w) (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)))))) signs)"
 
 (* Putting all of the pieces of the construction together *)
 definition satisfy_equation:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat list list \<Rightarrow> bool"
   where "satisfy_equation p qs subset_list sign_list =
         (mult_mat_vec (matrix_A sign_list subset_list) (construct_lhs_vector p qs sign_list) = (construct_rhs_vector p qs subset_list))"
 
 section "Setting up the construction: Proofs"
 
 (* Some matrix lemmas  *)
 lemma row_mat_of_rows_list:
   assumes "list_all (\<lambda>r. length r = nc) rs"
   assumes "i < length rs"
   shows "row (mat_of_rows_list nc rs) i = vec_of_list (nth rs i)"
   by (smt assms(1) assms(2) dim_col_mat(1) dim_vec_of_list eq_vecI index_row(2) index_vec list_all_length mat_of_rows_list_def row_mat split_conv vec_of_list_index)
 
 
 lemma mult_mat_vec_of_list:
   assumes "length ls = nc"
   assumes "list_all (\<lambda>r. length r = nc) rs"
   shows "mat_of_rows_list nc rs *\<^sub>v vec_of_list ls =
     vec_of_list (map (\<lambda>r. vec_of_list r \<bullet> vec_of_list ls) rs)"
   unfolding mult_mat_vec_def
   using row_mat_of_rows_list assms 
   apply auto
   by (smt dim_row_mat(1) dim_vec dim_vec_of_list eq_vecI index_map_vec(1) index_map_vec(2) index_vec list_all_length mat_of_rows_list_def row_mat_of_rows_list vec_of_list_index)
 
 lemma mtx_row_length:
   "list_all (\<lambda>r. length r = length signs) (map (mtx_row signs) ls)"
   apply (induction ls)
   by (auto simp add: mtx_row_def)
 
 thm construct_lhs_vector_def
 thm  poly_roots_finite
 
 (* Recharacterize the LHS vector *)
 lemma construct_lhs_vector_clean:
   assumes "p \<noteq> 0"
   assumes "i < length signs"
   shows "(construct_lhs_vector p qs signs) $ i =
     card {x. poly p x = 0 \<and> ((consistent_sign_vec_copr qs x) = (nth signs i))}"
 proof -
   from poly_roots_finite[OF assms(1)] have "finite {x. poly p x = 0}" .
   then have eq: "(Collect
        ((\<lambda>v. v = signs ! i) \<circ>
         consistent_sign_vec_copr qs) \<inter>
       set (sorted_list_of_set
             {x. poly p x = 0})) =
     {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = signs ! i}"
     by auto
   show ?thesis
     unfolding construct_lhs_vector_def vec_of_list_index characterize_root_list_p_def
     apply auto
     apply (subst nth_map[OF assms(2)])
     apply auto
     apply (subst distinct_length_filter)
     using eq by auto
 qed
 
 lemma construct_lhs_vector_cleaner:
   assumes "p \<noteq> 0"
   shows "(construct_lhs_vector p qs signs) =
    vec_of_list (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> ((consistent_sign_vec_copr qs x) = s)})) signs)"
   apply (rule eq_vecI)
   apply (auto simp add:  construct_lhs_vector_clean[OF assms] )
   apply (simp add: vec_of_list_index)
   unfolding construct_lhs_vector_def
   using assms construct_lhs_vector_clean construct_lhs_vector_def apply auto[1]
   by simp
 
 (* Show that because our consistent Sturm_Tarski.sign vectors consist of 1 and -1's, z returns 1 or -1 
   when applied to a consistent Sturm_Tarski.sign vector *)
 lemma z_signs:
   assumes "list_all (\<lambda>i. i < length signs) I"
   assumes "list_all (\<lambda>s. s = 1 \<or> s = -1) signs"
   shows "(z I signs = 1) \<or> (z I signs = -1)" using assms
 proof (induction I)
   case Nil
   then show ?case
     by (auto simp add:z_def)
 next
   case (Cons a I)
   moreover have "signs ! a = 1 \<or> signs ! a = -1"
     by (metis (mono_tags, lifting) add_Suc_right calculation(2) calculation(3) gr0_conv_Suc list.size(4) list_all_length nth_Cons_0)
   ultimately show ?case
     by (auto simp add:z_def)
 qed
 
 lemma z_lemma:
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   assumes consistent: "sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)"
   assumes welldefined: "list_constr I (length qs)"
   shows "(z I sign = 1) \<or> (z I sign = -1)"
 proof (rule z_signs)
   have "length sign = length qs" using consistent
     by (auto simp add: characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def)
   thus "list_all (\<lambda>i. i < length sign) I"
     using welldefined
     by (auto simp add: list_constr_def characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def)
   show "list_all (\<lambda>s. s = 1 \<or> s = - 1) sign" using consistent
     apply (auto simp add: list.pred_map  characterize_consistent_signs_at_roots_copr_def  consistent_sign_vec_copr_def)
     using Ball_set
     by force
 qed
 
 (* Show that all consistent sign vectors on roots of polynomials are in characterize_consistent_signs_at_roots_copr  *)
 lemma in_set: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
   assumes welldefined: "list_constr I (length qs)"
   shows "sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)" 
 proof -
   have h1: "consistent_sign_vec_copr qs x \<in>
       set (remdups (map (consistent_sign_vec_copr qs) (sorted_list_of_set {x. poly p x = 0})))" 
     using root_p apply auto apply (subst set_sorted_list_of_set)
     using nonzero poly_roots_finite rsquarefree_def apply blast by auto
   thus ?thesis unfolding characterize_consistent_signs_at_roots_copr_def characterize_root_list_p_def using sign_fix
     by blast
 qed
 
 (* Since all of the polynomials in qs are relatively prime to p, products of subsets of these
     polynomials are also relatively prime to p  *)
 lemma nonzero_product: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   fixes I:: "nat list" 
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes welldefined: "list_constr I (length qs)"
   shows "(poly (prod_list (retrieve_polys qs I)) x > 0) \<or> (poly (prod_list (retrieve_polys qs I)) x < 0)"
 proof -
   have "\<And>x. x \<in> set (retrieve_polys qs I) \<Longrightarrow> coprime p x"
     unfolding retrieve_polys_def
     by (smt in_set_conv_nth in_set_member length_map list_all_length list_constr_def nth_map pairwise_rel_prime_1 welldefined)
   then have coprimeh: "coprime p (prod_list (retrieve_polys qs I))"
     using prod_list_coprime_right by auto
   thus ?thesis using root_p
     using coprime_poly_0 linorder_neqE_linordered_idom by blast 
 qed
 
 (* The next few lemmas relate z to the signs of the product of subsets of polynomials of qs *)
 lemma horiz_vector_helper_pos_ind: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
   shows "(list_constr I (length qs)) \<longrightarrow> (poly (prod_list (retrieve_polys qs I)) x > 0) \<longleftrightarrow> (z I sign = 1)"
 proof (induct I)
   case Nil
   then show ?case
     by (simp add: retrieve_polys_def z_def) 
 next
   case (Cons a I) 
   have welldef: "list_constr (a#I) (length qs) \<longrightarrow> (list_constr I (length qs))" 
     unfolding list_constr_def list_all_def by auto
   have set_hyp: "list_constr I (length qs) \<longrightarrow> sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)" 
     using in_set using nonzero root_p sign_fix by blast 
   have z_hyp: "list_constr I (length qs) \<longrightarrow> ((z I sign = 1) \<or> (z I sign = -1))" 
     using set_hyp z_lemma[where sign="sign", where I = "I", where p="p", where qs="qs"] by blast
   have sign_hyp: "sign = map (\<lambda> q. if (poly q x > 0) then 1 else -1) qs" 
     using sign_fix unfolding consistent_sign_vec_copr_def by blast
   have ind_hyp_1: "list_constr (a#I) (length qs) \<longrightarrow> 
     ((0 < poly (prod_list (retrieve_polys qs I)) x) = (z I sign = 1))"
     using welldef Cons.hyps by auto
   have ind_hyp_2: "list_constr (a#I) (length qs) \<longrightarrow> 
     ((0 > poly (prod_list (retrieve_polys qs I)) x) = (z I sign = -1))"
     using welldef z_hyp Cons.hyps nonzero_product
     using pairwise_rel_prime_1 nonzero root_p by auto 
   have h1: "prod_list (retrieve_polys qs (a # I)) = (nth qs a)*(prod_list (retrieve_polys qs I))"
     by (simp add: retrieve_polys_def)
   have h2: "(z (a # I) sign) = (nth sign a)*(z I sign)"
     by (metis (mono_tags, opaque_lifting) list.simps(9) prod_list.Cons z_def)
   have h3help: "list_constr (a#I) (length qs) \<longrightarrow> a < length qs" unfolding list_constr_def
     by simp 
   then have h3: "list_constr (a#I) (length qs) \<longrightarrow> 
     ((nth sign a) = (if (poly (nth qs a) x > 0) then 1 else -1))" 
     using nth_map sign_hyp by auto
   have h2: "(0 < poly ((nth qs a)*(prod_list (retrieve_polys qs I))) x) \<longleftrightarrow> 
     ((0 < poly (nth qs a) x \<and> (0 < poly (prod_list (retrieve_polys qs I)) x)) \<or>
    (0 > poly (nth qs a) x \<and> (0 > poly (prod_list (retrieve_polys qs I)) x)))"
     by (simp add: zero_less_mult_iff)
   have final_hyp_a: "list_constr (a#I) (length qs) \<longrightarrow> (((0 < poly (nth qs a) x \<and> (0 < poly (prod_list (retrieve_polys qs I)) x)) 
     \<or> (0 > poly (nth qs a) x \<and> (0 > poly (prod_list (retrieve_polys qs I)) x))) = 
     ((nth sign a)*(z I sign) = 1))" 
   proof -
     have extra_hyp_a: "list_constr (a#I) (length qs) \<longrightarrow> (0 < poly (nth qs a) x = ((nth sign a) = 1))" using h3
       by simp 
     have extra_hyp_b: "list_constr (a#I) (length qs) \<longrightarrow>  (0 > poly (nth qs a) x = ((nth sign a) = -1))" 
       using h3 apply (auto) using coprime_poly_0 h3help in_set_member nth_mem pairwise_rel_prime_1 root_p by fastforce 
     have ind_hyp_1: "list_constr (a#I) (length qs) \<longrightarrow> (((0 < poly (nth qs a) x \<and> (z I sign = 1)) \<or> 
     (0 > poly (nth qs a) x \<and> (z I sign = -1)))
       = ((nth sign a)*(z I sign) = 1))" using extra_hyp_a extra_hyp_b
       using zmult_eq_1_iff
       by (simp add: h3)   
     then show ?thesis
       using ind_hyp_1 ind_hyp_2 by (simp add: Cons.hyps welldef)
   qed
   then show ?case 
     using h1 z_def by (simp add: zero_less_mult_iff)  
 qed
 
 lemma horiz_vector_helper_pos: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
   assumes welldefined: "list_constr I (length qs)"
   shows "(poly (prod_list (retrieve_polys qs I)) x > 0) \<longleftrightarrow> (z I sign = 1)"
   using horiz_vector_helper_pos_ind
   using pairwise_rel_prime_1 nonzero  root_p sign_fix welldefined by blast 
 
 lemma horiz_vector_helper_neg: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
   assumes welldefined: "list_constr I (length qs)"
   shows "(poly (prod_list (retrieve_polys qs I)) x < 0) \<longleftrightarrow> (z I sign = -1)"
 proof - 
   have set_hyp: "list_constr I (length qs) \<longrightarrow> sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)" 
     using in_set using nonzero root_p sign_fix by blast 
   have z_hyp: "list_constr I (length qs) \<longrightarrow> ((z I sign = 1) \<or> (z I sign = -1))" 
     using set_hyp  z_lemma[where sign="sign", where I = "I", where p="p", where qs="qs"] by blast
   have poly_hyp: "(poly (prod_list (retrieve_polys qs I)) x > 0) \<or> (poly (prod_list (retrieve_polys qs I)) x < 0)"
     using nonzero_product
     using pairwise_rel_prime_1 nonzero root_p
     using welldefined by blast
   have pos_hyp: "(poly (prod_list (retrieve_polys qs I)) x > 0) \<longleftrightarrow> (z I sign = 1)" using horiz_vector_helper_pos
     using pairwise_rel_prime_1 nonzero root_p sign_fix welldefined by blast
   show ?thesis using z_hyp poly_hyp pos_hyp apply (auto)
     using welldefined by blast
 qed
 
 (* Recharacterize the dot product *)
 lemma vec_of_list_dot_rewrite:
   assumes "length xs = length ys"
   shows "vec_of_list xs \<bullet> vec_of_list ys =
     sum_list (map2 (*) xs ys)"
   using assms
 proof (induction xs arbitrary:ys)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then show ?case apply auto
     by (smt (verit, best) Suc_length_conv list.simps(9) old.prod.case scalar_prod_vCons sum_list.Cons vec_of_list_Cons zip_Cons_Cons)
 qed
 
 lemma lhs_dot_rewrite:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   shows
     "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
    sum_list (map (\<lambda>s. (z I s)  *  rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) signs)"
 proof -
   have "p \<noteq> 0" using nonzero by auto
   from construct_lhs_vector_cleaner[OF this]
   have rhseq: "construct_lhs_vector p qs signs =
     vec_of_list
     (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) signs)" by auto
   have "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =    
     sum_list (map2 (*) (mtx_row signs I) (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) signs))"
     unfolding rhseq
     apply (intro vec_of_list_dot_rewrite)
     by (auto simp add: mtx_row_def)
   thus ?thesis unfolding mtx_row_def
     using map2_map_map 
     by (auto simp add: map2_map_map)
 qed
 
 lemma sum_list_distinct_filter:
   fixes f:: "'a \<Rightarrow> int"
   assumes "distinct xs" "distinct ys"
   assumes "set ys \<subseteq> set xs"
   assumes "\<And>x. x \<in> set xs - set ys \<Longrightarrow> f x = 0"
   shows "sum_list (map f xs) = sum_list (map f ys)"
   by (metis List.finite_set assms(1) assms(2) assms(3) assms(4) sum.mono_neutral_cong_left sum_list_distinct_conv_sum_set)
 
 (* If we have a superset of the signs, we can drop to just the consistent ones *)
 lemma construct_lhs_vector_drop_consistent:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes welldefined: "list_constr I (length qs)"
   shows
     "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
      (vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet>
       (construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs)))"
 proof - 
   have h0: "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_nat (card
                   {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn}) \<longrightarrow> z I sgn = 0"
   proof - 
     have "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_int (card
                   {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn}) \<longrightarrow> {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn} \<noteq> {}" 
       by fastforce
     then show ?thesis
-    proof -
-      { fix iis :: "rat list"
-        have ff1: "0 \<noteq> p"
-          using nonzero rsquarefree_def by blast
-        obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> real" where
-          ff2: "\<And>p. p (rr p) \<or> Collect p = {}"
-          by moura
-        { assume "\<exists>is. is = iis \<and> {r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = is} \<noteq> {}"
-          then have "\<exists>is. consistent_sign_vec_copr qs (rr (\<lambda>r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = is)) = iis \<and> {r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = is} \<noteq> {}"
-            using ff2
-            by (metis (mono_tags, lifting))
-          then have "\<exists>r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = iis"
-            using ff2 by smt
-          then have "iis \<in> consistent_sign_vec_copr qs ` set (sorted_list_of_set {r. poly p r = 0})"
-            using ff1 poly_roots_finite by fastforce }
-        then have "iis \<notin> set signs \<or> iis \<in> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<or> \<not> 0 < rat_of_int (int (card {r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = iis}))"
-          by (metis (no_types) \<open>\<forall>sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_int (int (card {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn})) \<longrightarrow> {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn} \<noteq> {}\<close> characterize_root_list_p_def) }
-      then show ?thesis
-        by fastforce
-    qed
+      using characterize_consistent_signs_at_roots_copr_def in_set nonzero welldefined by auto
   qed
   then have "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<longrightarrow> ((0 = rat_of_nat (card
                   {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn}) \<or> z I sgn = 0))"
     by auto
   then have hyp: "\<forall> s. s \<in> set signs \<and> s \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<longrightarrow> (z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) = 0)"
     by auto
   then have "(\<Sum>s\<in> set(signs). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = 
         (\<Sum>s\<in>(set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
   proof - 
     have "set(signs) =(set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))) \<union>
               (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p)))"
       by blast
     then have sum_rewrite: "(\<Sum>s\<in> set(signs). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =  
           (\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))) \<union>
               (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
       by auto
     then have sum_split: "(\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))) \<union>
               (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))
           = 
 (\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))
 + (\<Sum>s\<in> (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
       by (metis (no_types, lifting) List.finite_set sum.Int_Diff)
     have sum_zero: "(\<Sum>s\<in> (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = 0"   
       using hyp
       by (simp add: hyp)      
     show ?thesis using sum_rewrite sum_split sum_zero by linarith
   qed
   then have set_eq: "set (remdups
            (map (consistent_sign_vec_copr qs)
              (characterize_root_list_p p))) = set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))"
     using all_info
     by (simp add: characterize_consistent_signs_at_roots_copr_def subset_antisym)
   have hyp1: "(\<Sum>s\<leftarrow>signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = 
         (\<Sum>s\<in>set (signs). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
     using distinct_signs sum_list_distinct_conv_sum_set by blast
   have hyp2: "(\<Sum>s\<leftarrow>remdups
            (map (consistent_sign_vec_copr qs)
              (characterize_root_list_p p)). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))
   = (\<Sum>s\<in> set (remdups
            (map (consistent_sign_vec_copr qs)
              (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
     using sum_list_distinct_conv_sum_set by blast 
   have set_sum_eq: "(\<Sum>s\<in>(set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
     (\<Sum>s\<in> set (remdups
            (map (consistent_sign_vec_copr qs)
              (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
     using set_eq by auto
   then have "(\<Sum>s\<leftarrow>signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
     (\<Sum>s\<leftarrow>remdups
            (map (consistent_sign_vec_copr qs)
              (characterize_root_list_p p)). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
     using set_sum_eq hyp1 hyp2
     using \<open>(\<Sum>s\<in>set signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = (\<Sum>s\<in>set signs \<inter> consistent_sign_vec_copr qs ` set (characterize_root_list_p p). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> by linarith
   then have "consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<subseteq> set signs \<Longrightarrow>
     (\<And>p qss.
         characterize_consistent_signs_at_roots_copr p qss =
         remdups (map (consistent_sign_vec_copr qss) (characterize_root_list_p p))) \<Longrightarrow>
     (\<Sum>s\<leftarrow>signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
     (\<Sum>s\<leftarrow>remdups
            (map (consistent_sign_vec_copr qs)
              (characterize_root_list_p p)). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
     by linarith
   then show ?thesis  unfolding lhs_dot_rewrite[OF nonzero]
     apply (auto intro!: sum_list_distinct_filter simp add: distinct_signs  characterize_consistent_signs_at_roots_copr_def)
     using all_info characterize_consistent_signs_at_roots_copr_def by auto[1]
 qed
 
 (* Both matrix_equation_helper_step and matrix_equation_main_step relate the matrix construction 
    to the Tarski queries, i.e. relate the product of a row of the matrix and the LHS vector to a 
    Tarski query on the RHS *)
 lemma matrix_equation_helper_step:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes welldefined: "list_constr I (length qs)"
   assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   shows "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
    rat_of_int (card {x. poly p x = 0 \<and> poly (prod_list (retrieve_polys qs I)) x > 0}) -
    rat_of_int (card {x. poly p x = 0 \<and> poly (prod_list (retrieve_polys qs I)) x < 0})"
 proof -
   have "finite (set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)))" by auto
   let ?gt = "(set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)) \<inter> {s. z I s = 1})"
   let ?lt = "  (set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)) \<inter> {s. z I s = -1})"  
   have eq: "set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)) = ?gt \<union> ?lt"
     apply auto
     by (metis characterize_root_list_p_def horiz_vector_helper_neg horiz_vector_helper_pos_ind nonzero nonzero_product pairwise_rel_prime_1 poly_roots_finite sorted_list_of_set(1) welldefined)
       (* First, drop the signs that are irrelevant *)
   from construct_lhs_vector_drop_consistent[OF assms(1-4)] have
     "vec_of_list (mtx_row signs I) \<bullet> construct_lhs_vector p qs signs =
   vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet>
   construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs)" .
     (* Now we split the sum *)
   from lhs_dot_rewrite[OF assms(1)]
   moreover have "... =
   (\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots_copr p qs.
     z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))" .
   moreover have "... =
   (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)).
     z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))" unfolding characterize_consistent_signs_at_roots_copr_def sum_code[symmetric]
     by (auto)
   ultimately have "... =
   (\<Sum>s\<in>?gt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) +
   (\<Sum>s\<in>?lt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
     apply (subst eq)
     apply (rule sum.union_disjoint)
     by auto
       (* Now recharacterize lt, gt*)
   have setroots: "set (characterize_root_list_p p) = {x. poly p x = 0}" unfolding characterize_root_list_p_def
     using poly_roots_finite nonzero rsquarefree_def set_sorted_list_of_set by blast    
   have *: "\<And>s. {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s} =
         {x \<in>{x. poly p x = 0}. consistent_sign_vec_copr qs x = s}"
     by auto
   have lem_e1: "\<And>x. x \<in> {x. poly p x = 0} \<Longrightarrow>
        card
         {s \<in> consistent_sign_vec_copr  qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}.
          consistent_sign_vec_copr qs x = s} =
        (if 0 < poly (prod_list (retrieve_polys qs I)) x then 1 else 0)"
   proof -
     fix x
     assume rt: "x \<in> {x. poly p x = 0}"
     then have 1: "{s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}. consistent_sign_vec_copr qs x = s} =
       {s. z I s = 1 \<and> consistent_sign_vec_copr qs x = s}"
       by auto
     from horiz_vector_helper_pos[OF assms(1) assms(5) rt]
     have 2: "... = {s. (0 < poly (prod_list (retrieve_polys qs I)) x)  \<and> consistent_sign_vec_copr qs x = s}"
       using welldefined by blast
     have 3: "... = (if (0 < poly (prod_list (retrieve_polys qs I)) x)  then {consistent_sign_vec_copr qs x} else {})"
       by auto
     thus "card {s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}. consistent_sign_vec_copr qs x = s} =
          (if 0 < poly (prod_list (retrieve_polys qs I)) x then 1 else 0) " using 1 2 3 by auto
   qed
   have e1: "(\<Sum>s\<in>consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}.
        card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) =
      (sum (\<lambda>x. if (poly (prod_list (retrieve_polys qs I)) x) > 0 then 1 else 0) {x. poly p x = 0})"
     unfolding * apply (rule sum_multicount_gen)
     using \<open>finite (set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)))\<close> setroots apply auto[1]
     apply (metis List.finite_set setroots)
     using lem_e1 by auto
   have gtchr: "(\<Sum>s\<in>?gt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
     rat_of_int (card {x. poly p x = 0 \<and> 0 < poly (prod_list (retrieve_polys qs I)) x})"
     apply (auto simp add: setroots)
     apply (subst of_nat_sum[symmetric])
     apply (subst of_nat_eq_iff)
     apply (subst e1)
     apply (subst card_eq_sum)
     apply (rule sum.mono_neutral_cong_right)
     apply (metis List.finite_set setroots)
     by auto
   have lem_e2: "\<And>x. x \<in> {x. poly p x = 0} \<Longrightarrow>
        card
         {s \<in> consistent_sign_vec_copr  qs ` {x. poly p x = 0} \<inter> {s. z I s = -1}.
          consistent_sign_vec_copr qs x = s} =
        (if poly (prod_list (retrieve_polys qs I)) x < 0 then 1 else 0)"
   proof -
     fix x
     assume rt: "x \<in> {x. poly p x = 0}"
     then have 1: "{s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = -1}. consistent_sign_vec_copr qs x = s} =
       {s. z I s = -1 \<and> consistent_sign_vec_copr qs x = s}"
       by auto
     from horiz_vector_helper_neg[OF assms(1) assms(5) rt]
     have 2: "... = {s. (0 > poly (prod_list (retrieve_polys qs I)) x)  \<and> consistent_sign_vec_copr qs x = s}"
       using welldefined by blast
     have 3: "... = (if (0 > poly (prod_list (retrieve_polys qs I)) x)  then {consistent_sign_vec_copr qs x} else {})"
       by auto
     thus "card {s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = -1}. consistent_sign_vec_copr qs x = s} =
        (if poly (prod_list (retrieve_polys qs I)) x < 0 then 1 else 0)" using 1 2 3 by auto
   qed
   have e2: " (\<Sum>s\<in>consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = - 1}.
        card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) =
      (sum (\<lambda>x. if (poly (prod_list (retrieve_polys qs I)) x) < 0 then 1 else 0) {x. poly p x = 0})"
     unfolding * apply (rule sum_multicount_gen)
     using \<open>finite (set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)))\<close> setroots apply auto[1]
      apply (metis List.finite_set setroots)
     using lem_e2 by auto
   have ltchr: "(\<Sum>s\<in>?lt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
     - rat_of_int (card {x. poly p x = 0 \<and> 0 > poly (prod_list (retrieve_polys qs I)) x})"
     apply (auto simp add: setroots sum_negf)
     apply (subst of_nat_sum[symmetric])
     apply (subst of_nat_eq_iff)
     apply (subst e2)
     apply (subst card_eq_sum)
     apply (rule sum.mono_neutral_cong_right)
        apply (metis List.finite_set setroots)
     by auto
   show ?thesis using gtchr ltchr
     using \<open>(\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)). z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)) \<inter> {s. z I s = 1}. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) + (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)) \<inter> {s. z I s = - 1}. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> \<open>(\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots_copr p qs. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)). z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> \<open>vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet> construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs) = (\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots_copr p qs. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> \<open>vec_of_list (mtx_row signs I) \<bullet> construct_lhs_vector p qs signs = vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet> construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs)\<close>
     by linarith
 qed
 
 (* A clean restatement of the helper lemma *)
 lemma matrix_equation_main_step:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes welldefined: "list_constr I (length qs)"
   assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   shows "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =  
     construct_NofI p (retrieve_polys qs I)"
     unfolding construct_NofI_prop[OF nonzero]
     using matrix_equation_helper_step[OF assms]
     by linarith
 
 lemma map_vec_vec_of_list_eq_intro:
   assumes "map f xs = map g ys"
   shows "map_vec f (vec_of_list xs) = map_vec g (vec_of_list ys)"
   by (metis assms vec_of_list_map)
 
 (* Shows that as long as we have a "basis" of sign assignments (see assumptions all_info, welldefined), 
   and some other mild assumptions on our inputs (given in nonzero, distinct_signs, pairwise_rel_prime),
   the construction will be satisfied *)
 theorem matrix_equation:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes subsets:: "nat list list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   assumes welldefined: "all_list_constr (subsets) (length qs)"
   shows "satisfy_equation p qs subsets signs"
   unfolding satisfy_equation_def matrix_A_def
     construct_lhs_vector_def construct_rhs_vector_def all_list_constr_def
   apply (subst mult_mat_vec_of_list)
     apply (auto simp add: mtx_row_length intro!: map_vec_vec_of_list_eq_intro)
   using matrix_equation_main_step[OF assms(1-3) _ assms(4), unfolded construct_lhs_vector_def]
   using all_list_constr_def in_set_member welldefined by fastforce
 
 (* Prettifying some theorems*)
 definition roots:: "real poly \<Rightarrow> real set"
   where "roots p = {x. poly p x = 0}"
 
 definition sgn::"'a::linordered_field \<Rightarrow> rat"
   where "sgn x = (if x > 0 then 1
                   else if x < 0 then -1
                   else 0)"
 
 definition sgn_vec::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
   where "sgn_vec qs x \<equiv>  map (sgn \<circ> (\<lambda>q. poly q x)) qs"
 
 definition consistent_signs_at_roots:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list set"
   where "consistent_signs_at_roots p qs =
     (sgn_vec qs) ` (roots p)"
 
 lemma consistent_signs_at_roots_eq:
   assumes "p \<noteq> 0"
   shows "consistent_signs_at_roots p qs =
          set (characterize_consistent_signs_at_roots p qs)"
   unfolding consistent_signs_at_roots_def characterize_consistent_signs_at_roots_def
     characterize_root_list_p_def
   apply auto
   apply (subst set_sorted_list_of_set)
   using assms poly_roots_finite apply blast
   unfolding sgn_vec_def sgn_def signs_at_def squash_def o_def
   using roots_def apply auto[1]
   by (smt Collect_cong assms image_iff poly_roots_finite roots_def sorted_list_of_set(1))
 
 abbreviation w_vec:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list  \<Rightarrow> rat vec"
   where "w_vec \<equiv> construct_lhs_vector"
 
 abbreviation v_vec:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat vec"
   where "v_vec \<equiv> construct_rhs_vector"
 
 abbreviation M_mat:: "rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat"
   where "M_mat \<equiv> matrix_A"
 
 theorem matrix_equation_pretty:
   assumes "p\<noteq>0"
   assumes "\<And>q. q \<in> set qs \<Longrightarrow> coprime p q"
   assumes "distinct signs"
   assumes "consistent_signs_at_roots p qs \<subseteq> set signs"
   assumes "\<And>l i. l \<in> set subsets \<Longrightarrow> i \<in> set l \<Longrightarrow> i < length qs"
   shows "M_mat signs subsets *\<^sub>v w_vec p qs signs = v_vec p qs subsets"
   unfolding satisfy_equation_def[symmetric]
   apply (rule matrix_equation[OF assms(1) assms(3)])
   apply (metis assms(1) assms(2) assms(4) consistent_signs_at_roots_eq csa_list_copr_rel member_def)
   apply (simp add: assms(2) in_set_member)
   using Ball_set all_list_constr_def assms(5) list_constr_def member_def by fastforce
 
 end
\ No newline at end of file
diff --git a/thys/BenOr_Kozen_Reif/More_Matrix.thy b/thys/BenOr_Kozen_Reif/More_Matrix.thy
--- a/thys/BenOr_Kozen_Reif/More_Matrix.thy
+++ b/thys/BenOr_Kozen_Reif/More_Matrix.thy
@@ -1,2007 +1,2007 @@
 theory More_Matrix
   imports "Jordan_Normal_Form.Matrix"
     "Jordan_Normal_Form.DL_Rank"
     "Jordan_Normal_Form.VS_Connect"
     "Jordan_Normal_Form.Gauss_Jordan_Elimination"
 begin
 
 section "Kronecker Product"
 
 definition kronecker_product :: "'a :: ring mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
   "kronecker_product A B =
   (let ra = dim_row A; ca = dim_col A;
        rb = dim_row B; cb = dim_col B
   in
     mat (ra*rb) (ca*cb)
     (\<lambda>(i,j).
       A $$ (i div rb, j div cb) *
       B $$ (i mod rb, j mod cb)
   ))"
 
 lemma arith:
   assumes "d < a"
   assumes "c < b"
   shows "b*d+c < a*(b::nat)"
 proof -
   have "b*d+c < b*(d+1)"
     by (simp add: assms(2))
   thus ?thesis
     by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right assms(1) less_le_trans mult.commute mult_le_cancel2)
 qed
 
 lemma dim_kronecker[simp]:
   "dim_row (kronecker_product A B) = dim_row A * dim_row B"
   "dim_col (kronecker_product A B) = dim_col A * dim_col B"
   unfolding kronecker_product_def Let_def by auto
 
 lemma kronecker_inverse_index:
   assumes "r < dim_row A" "s < dim_col A"
   assumes "v < dim_row B" "w < dim_col B"
   shows "kronecker_product A B $$ (dim_row B*r+v, dim_col B*s+w) = A $$ (r,s) * B $$ (v,w)"
 proof -
   from arith[OF assms(1) assms(3)]
   have "dim_row B*r+v < dim_row A * dim_row B" .
   moreover from arith[OF assms(2) assms(4)]
   have "dim_col B * s + w < dim_col A * dim_col B" .
   ultimately show ?thesis
     unfolding kronecker_product_def Let_def
     using assms by auto
 qed
 
 lemma kronecker_distr_left:
   assumes "dim_row B = dim_row C" "dim_col B = dim_col C"
   shows "kronecker_product A (B+C) = kronecker_product A B + kronecker_product A C"
   unfolding kronecker_product_def Let_def
   using assms apply (auto simp add: mat_eq_iff) 
   by (metis (no_types, lifting) distrib_left index_add_mat(1) mod_less_divisor mult_eq_0_iff neq0_conv not_less_zero)
 
 lemma kronecker_distr_right:
   assumes "dim_row B = dim_row C" "dim_col B = dim_col C"
   shows "kronecker_product (B+C) A = kronecker_product B A + kronecker_product C A"
   unfolding kronecker_product_def Let_def
   using assms by (auto simp add: mat_eq_iff less_mult_imp_div_less distrib_right)
 
 lemma index_mat_mod[simp]: "nr > 0 & nc > 0 \<Longrightarrow> mat nr nc f $$ (i mod nr,j mod nc) = f (i mod nr,j mod nc)"
   by auto
 
 lemma kronecker_assoc:
   shows "kronecker_product A (kronecker_product B C) = kronecker_product (kronecker_product A B) C"
   unfolding kronecker_product_def Let_def
   apply (case_tac "dim_row B * dim_row C > 0 & dim_col B * dim_col C > 0")
    apply (auto simp add: mat_eq_iff less_mult_imp_div_less)
   by (smt (verit, best) div_less_iff_less_mult div_mult2_eq kronecker_inverse_index linordered_semiring_strict_class.mult_pos_pos mod_less_divisor mod_mult2_eq mult.assoc mult.commute mult_div_mod_eq)
 
 lemma sum_sum_mod_div:
   "(\<Sum>ia = 0::nat..<x. \<Sum>ja = 0..<y. f ia ja) =
    (\<Sum>ia = 0..<x*y. f (ia div y) (ia mod y))"
 proof -
   have 1: "inj_on (\<lambda>ia. (ia div y, ia mod y)) {0..<x * y}"
     by (smt (verit, best) Pair_inject div_mod_decomp inj_onI)
   have 21: "{0..<x} \<times> {0..<y} \<subseteq> (\<lambda>ia. (ia div y, ia mod y)) ` {0..<x * y}"
   proof clarsimp
     fix a b
     assume *:"a < x" "b < y"
     have "a * y +  b \<in> {0..<x*y}"
       by (metis arith * atLeastLessThan_iff le0 mult.commute)
     thus "(a, b) \<in> (\<lambda>ia. (ia div y, ia mod y)) ` {0..<x * y}"
       using * by (auto simp add: image_iff)
         (metis \<open>a * y + b \<in> {0..<x * y}\<close> add.commute add.right_neutral div_less div_mult_self1 less_zeroE mod_eq_self_iff_div_eq_0 mod_mult_self1)
   qed
   have 22:"(\<lambda>ia. (ia div y, ia mod y)) ` {0..<x * y} \<subseteq> {0..<x} \<times> {0..<y}"
     using less_mult_imp_div_less apply auto
     by (metis mod_less_divisor mult.commute neq0_conv not_less_zero)
   have 2: "{0..<x} \<times> {0..<y} = (\<lambda>ia. (ia div y, ia mod y)) ` {0..<x * y}"
     using 21 22 by auto
   have *: "(\<Sum>ia = 0::nat..<x. \<Sum>ja = 0..<y. f ia ja) =
         (\<Sum>(x, y)\<in>{0..<x} \<times> {0..<y}. f x y)"
     by (auto simp add: sum.cartesian_product)
   show ?thesis unfolding *
     apply (intro sum.reindex_cong[of "\<lambda>ia. (ia div y, ia mod y)"])
     using 1 2 by auto
 qed
 
 (* Kronecker product distributes over matrix multiplication *)
 lemma kronecker_of_mult:
   assumes "dim_col (A :: 'a :: comm_ring mat) = dim_row C"
   assumes "dim_col B = dim_row D"
   shows "kronecker_product A B * kronecker_product C D = kronecker_product (A * C) (B * D)"
   unfolding kronecker_product_def Let_def mat_eq_iff
 proof clarsimp
   fix i j
   assume ij: "i < dim_row A * dim_row B" "j < dim_col C * dim_col D"
   have 1: "(A * C) $$ (i div dim_row B, j div dim_col D) =
     row A (i div dim_row B) \<bullet> col C (j div dim_col D)"
     using ij less_mult_imp_div_less by (auto intro!: index_mult_mat)
   have 2: "(B * D) $$ (i mod dim_row B, j mod dim_col D) =
     row B (i mod dim_row B) \<bullet> col D (j mod dim_col D)"
     using ij apply (auto intro!: index_mult_mat)
     using gr_implies_not0 apply fastforce
     using gr_implies_not0 by fastforce
   have 3: "\<And>x. x < dim_row C * dim_row D \<Longrightarrow>
          A $$ (i div dim_row B, x div dim_row D) *
          B $$ (i mod dim_row B, x mod dim_row D) *
          (C $$ (x div dim_row D, j div dim_col D) *
           D $$ (x mod dim_row D, j mod dim_col D)) =
          row A (i div dim_row B) $ (x div dim_row D) *
          col C (j div dim_col D) $ (x div dim_row D) *
          (row B (i mod dim_row B) $ (x mod dim_row D) *
           col D (j mod dim_col D) $ (x mod dim_row D))"
   proof -
     fix x
     assume *:"x < dim_row C * dim_row D"
     have 1: "row A (i div dim_row B) $ (x div dim_row D) = A $$ (i div dim_row B, x div dim_row D)"
       by (simp add: * assms(1) less_mult_imp_div_less row_def)
     have 2: "row B (i mod dim_row B) $ (x mod dim_row D) = B $$ (i mod dim_row B, x mod dim_row D)"
       by (metis "*" assms(2) ij(1) index_row(1) mod_less_divisor nat_0_less_mult_iff neq0_conv not_less_zero)
     have 3: "col C (j div dim_col D) $ (x div dim_row D) = C $$ (x div dim_row D, j div dim_col D)"
       by (simp add: "*" ij(2) less_mult_imp_div_less)
     have 4: "col D (j mod dim_col D) $ (x mod dim_row D) = D $$ (x mod dim_row D, j mod dim_col D)"
       by (metis "*" bot_nat_0.not_eq_extremum ij(2) index_col mod_less_divisor mult_zero_right not_less_zero)
     show "A $$ (i div dim_row B, x div dim_row D) *
          B $$ (i mod dim_row B, x mod dim_row D) *
          (C $$ (x div dim_row D, j div dim_col D) *
           D $$ (x mod dim_row D, j mod dim_col D)) =
          row A (i div dim_row B) $ (x div dim_row D) *
          col C (j div dim_col D) $ (x div dim_row D) *
          (row B (i mod dim_row B) $ (x mod dim_row D) *
           col D (j mod dim_col D) $ (x mod dim_row D))" unfolding 1 2 3 4
       by (simp add: mult.assoc mult.left_commute)
   qed
   have *: "(A * C) $$ (i div dim_row B, j div dim_col D) *
         (B * D) $$ (i mod dim_row B, j mod dim_col D) =
     (\<Sum>ia = 0..<dim_row C * dim_row D.
                A $$ (i div dim_row B, ia div dim_row D) *
                B $$ (i mod dim_row B, ia mod dim_row D) *
                (C $$ (ia div dim_row D, j div dim_col D) *
                 D $$ (ia mod dim_row D, j mod dim_col D)))"
     unfolding 1 2 scalar_prod_def sum_product sum_sum_mod_div
     apply (auto simp add: sum_product sum_sum_mod_div intro!: sum.cong)
     using 3 by presburger
   show "vec (dim_col A * dim_col B)
           (\<lambda>j. A $$ (i div dim_row B, j div dim_col B) *
                B $$ (i mod dim_row B, j mod dim_col B)) \<bullet>
        vec (dim_row C * dim_row D)
           (\<lambda>i. C $$ (i div dim_row D, j div dim_col D) *
                D $$ (i mod dim_row D, j mod dim_col D)) =
         (A * C) $$ (i div dim_row B, j div dim_col D) *
         (B * D) $$ (i mod dim_row B, j mod dim_col D)"
     unfolding * scalar_prod_def
     by (auto simp add: assms sum_product sum_sum_mod_div intro!: sum.cong)
 qed
 
 lemma inverts_mat_length:
   assumes "square_mat A" "inverts_mat A B" "inverts_mat B A"
   shows "dim_row B = dim_row A" "dim_col B = dim_col A"
    apply (metis assms(1) assms(3) index_mult_mat(3) index_one_mat(3) inverts_mat_def square_mat.simps)
   by (metis assms(1) assms(2) index_mult_mat(3) index_one_mat(3) inverts_mat_def square_mat.simps)
 
 lemma less_mult_imp_mod_less:
   "m mod i < i" if "m < n * i" for m n i :: nat
   using gr_implies_not_zero that by fastforce
 
 lemma kronecker_one:
   shows "kronecker_product ((1\<^sub>m x)::'a :: ring_1 mat) (1\<^sub>m y) = 1\<^sub>m (x*y)"
   unfolding kronecker_product_def Let_def
   apply  (auto simp add:mat_eq_iff less_mult_imp_div_less less_mult_imp_mod_less)
   by (metis div_mult_mod_eq)
 
 lemma kronecker_invertible:
   assumes "invertible_mat (A :: 'a :: comm_ring_1 mat)" "invertible_mat B"
   shows "invertible_mat (kronecker_product A B)"
 proof -
   obtain Ai where Ai: "inverts_mat A Ai" "inverts_mat Ai A" using assms invertible_mat_def by blast
   obtain Bi where Bi: "inverts_mat B Bi" "inverts_mat Bi B" using assms invertible_mat_def by blast
   have "square_mat (kronecker_product A B)"
     by (metis (no_types, lifting) assms(1) assms(2) dim_col_mat(1) dim_row_mat(1) invertible_mat_def kronecker_product_def square_mat.simps)
   moreover have "inverts_mat (kronecker_product A B) (kronecker_product Ai Bi)"
     using Ai Bi unfolding inverts_mat_def
     by (metis (no_types, lifting) dim_kronecker(1) index_mult_mat(3) index_one_mat(3) kronecker_of_mult kronecker_one)
   moreover have "inverts_mat (kronecker_product Ai Bi) (kronecker_product A B)"
     using Ai Bi unfolding inverts_mat_def
     by (metis (no_types, lifting) dim_kronecker(1) index_mult_mat(3) index_one_mat(3) kronecker_of_mult kronecker_one)
   ultimately show ?thesis unfolding invertible_mat_def by blast
 qed
 
 section "More DL Rank"
 
 (* conjugate matrices *)
 instantiation mat :: (conjugate) conjugate
 begin
 
 definition conjugate_mat :: "'a :: conjugate mat \<Rightarrow> 'a mat"
   where "conjugate m = mat (dim_row m) (dim_col m) (\<lambda>(i,j). conjugate (m $$ (i,j)))"
 
 lemma dim_row_conjugate[simp]: "dim_row (conjugate m) = dim_row m"
   unfolding conjugate_mat_def by auto
 
 lemma dim_col_conjugate[simp]: "dim_col (conjugate m) = dim_col m"
   unfolding conjugate_mat_def by auto
 
 lemma carrier_vec_conjugate[simp]: "m \<in> carrier_mat nr nc \<Longrightarrow> conjugate m \<in> carrier_mat nr nc"
   by (auto)
 
 lemma mat_index_conjugate[simp]:
   shows "i < dim_row m \<Longrightarrow> j < dim_col m \<Longrightarrow> conjugate m  $$ (i,j) = conjugate (m $$ (i,j))"
   unfolding conjugate_mat_def by auto
 
 lemma row_conjugate[simp]: "i < dim_row m \<Longrightarrow> row (conjugate m) i = conjugate (row m i)"
   by (auto)
 
 lemma col_conjugate[simp]: "i < dim_col m \<Longrightarrow> col (conjugate m) i = conjugate (col m i)"
   by (auto)
 
 lemma rows_conjugate: "rows (conjugate m) = map conjugate (rows m)"
   by (simp add: list_eq_iff_nth_eq)
 
 lemma cols_conjugate: "cols (conjugate m) = map conjugate (cols m)"
   by (simp add: list_eq_iff_nth_eq)
 
 instance
 proof
   fix a b :: "'a mat"
   show "conjugate (conjugate a) = a"
     unfolding mat_eq_iff by auto
   let ?a = "conjugate a"
   let ?b = "conjugate b"
   show "conjugate a = conjugate b \<longleftrightarrow> a = b"
     by (metis dim_col_conjugate dim_row_conjugate mat_index_conjugate conjugate_cancel_iff mat_eq_iff)
 qed
 
 end
 
 abbreviation conjugate_transpose :: "'a::conjugate mat  \<Rightarrow> 'a mat"
   where "conjugate_transpose A \<equiv> conjugate (A\<^sup>T)"
 
 notation conjugate_transpose ("(_\<^sup>H)" [1000])
 
 lemma transpose_conjugate:
   shows "(conjugate A)\<^sup>T = A\<^sup>H"
   unfolding conjugate_mat_def
   by auto
 
 lemma vec_module_col_helper:
   fixes A:: "('a :: field) mat"
   shows "(0\<^sub>v (dim_row A) \<in> LinearCombinations.module.span class_ring \<lparr>carrier = carrier_vec (dim_row A), mult = undefined, one = undefined, zero = 0\<^sub>v (dim_row A), add = (+), smult = (\<cdot>\<^sub>v)\<rparr> (set (cols A)))"
 proof -
   have "\<forall>v. (0::'a) \<cdot>\<^sub>v v + v = v"
     by auto
   then show "0\<^sub>v (dim_row A) \<in> LinearCombinations.module.span class_ring \<lparr>carrier = carrier_vec (dim_row A), mult = undefined, one = undefined, zero = 0\<^sub>v (dim_row A), add = (+), smult = (\<cdot>\<^sub>v)\<rparr> (set (cols A))"
     by (metis cols_dim module_vec_def right_zero_vec smult_carrier_vec vec_space.prod_in_span zero_carrier_vec)
 qed
 
 lemma vec_module_col_helper2:
   fixes A:: "('a :: field) mat"
   shows "\<And>a x. x \<in> LinearCombinations.module.span class_ring
                 \<lparr>carrier = carrier_vec (dim_row A), mult = undefined, one = undefined,
                    zero = 0\<^sub>v (dim_row A), add = (+), smult = (\<cdot>\<^sub>v)\<rparr>
                 (set (cols A)) \<Longrightarrow>
            (\<And>a b v. (a + b) \<cdot>\<^sub>v v = a \<cdot>\<^sub>v v + b \<cdot>\<^sub>v v) \<Longrightarrow>
            a \<cdot>\<^sub>v x
            \<in> LinearCombinations.module.span class_ring
                \<lparr>carrier = carrier_vec (dim_row A), mult = undefined, one = undefined,
                   zero = 0\<^sub>v (dim_row A), add = (+), smult = (\<cdot>\<^sub>v)\<rparr>
                (set (cols A))"
 proof -
   fix a :: 'a and x :: "'a vec"
   assume "x \<in> LinearCombinations.module.span class_ring \<lparr>carrier = carrier_vec (dim_row A), mult = undefined, one = undefined, zero = 0\<^sub>v (dim_row A), add = (+), smult = (\<cdot>\<^sub>v)\<rparr> (set (cols A))"
   then show "a \<cdot>\<^sub>v x \<in> LinearCombinations.module.span class_ring \<lparr>carrier = carrier_vec (dim_row A), mult = undefined, one = undefined, zero = 0\<^sub>v (dim_row A), add = (+), smult = (\<cdot>\<^sub>v)\<rparr> (set (cols A))"
     by (metis (full_types) cols_dim idom_vec.smult_in_span module_vec_def)
 qed
 
 lemma vec_module_col: "module (class_ring :: 'a :: field ring)
   (module_vec TYPE('a) 
     (dim_row A)
       \<lparr>carrier :=
          LinearCombinations.module.span
           class_ring (module_vec TYPE('a) (dim_row A)) (set (cols A))\<rparr>)"
 proof -
   interpret abelian_group "module_vec TYPE('a) (dim_row A)
       \<lparr>carrier :=
          LinearCombinations.module.span
           class_ring (module_vec TYPE('a) (dim_row A)) (set (cols A))\<rparr>"
     apply (unfold_locales)
           apply (auto simp add:module_vec_def)
           apply (metis cols_dim module_vec_def partial_object.select_convs(1) ring.simps(2) vec_vs vectorspace.span_add1)
          apply (metis assoc_add_vec cols_dim module_vec_def vec_space.cV vec_vs vectorspace.span_closed)
     using vec_module_col_helper[of A] apply (auto)    
        apply (metis cols_dim left_zero_vec module_vec_def partial_object.select_convs(1) vec_vs vectorspace.span_closed)
       apply (metis cols_dim module_vec_def partial_object.select_convs(1) right_zero_vec vec_vs vectorspace.span_closed)
      apply (metis cols_dim comm_add_vec module_vec_def vec_space.cV vec_vs vectorspace.span_closed)
     unfolding Units_def apply auto
     by (metis (no_types, opaque_lifting) cols_dim comm_add_vec module_vec_def partial_object.select_convs(1) uminus_l_inv_vec vec_space.vec_neg vec_vs vectorspace.span_closed vectorspace.span_neg)
   show ?thesis
     apply (unfold_locales)
     unfolding class_ring_simps apply auto
     unfolding module_vec_simps using add_smult_distrib_vec apply auto
      apply (auto simp add:module_vec_def)
     using vec_module_col_helper2
      apply blast
     by (smt (verit) cols_dim module_vec_def smult_add_distrib_vec vec_space.cV vec_vs vectorspace.span_closed)
 qed
 
 (* The columns of a matrix form a vectorspace *)
 lemma vec_vs_col: "vectorspace (class_ring :: 'a :: field ring)
   (module_vec TYPE('a) (dim_row A)
       \<lparr>carrier :=
          LinearCombinations.module.span
           class_ring
           (module_vec TYPE('a)
             (dim_row A))
           (set (cols A))\<rparr>)"
   unfolding vectorspace_def
   using vec_module_col class_field 
   by (auto simp: class_field_def)
 
 lemma cols_mat_mul_map:
   shows "cols (A * B) = map ((*\<^sub>v) A) (cols B)"
   unfolding list_eq_iff_nth_eq
   by auto
 
 lemma cols_mat_mul:
   shows "set (cols (A * B)) = (*\<^sub>v) A ` set (cols B)"
   by (simp add: cols_mat_mul_map)
 
 lemma set_obtain_sublist:
   assumes "S \<subseteq> set ls"
   obtains ss where "distinct ss" "S = set ss"
   using assms finite_distinct_list infinite_super by blast
 
 lemma mul_mat_of_cols:
   assumes "A \<in> carrier_mat nr n"
   assumes "\<And>j. j < length cs \<Longrightarrow> cs ! j \<in> carrier_vec n"
   shows "A * (mat_of_cols n cs) = mat_of_cols nr (map ((*\<^sub>v) A) cs)"
   unfolding mat_eq_iff
   using assms apply auto
   apply (subst mat_of_cols_index)
   by auto
 
 lemma helper:
   fixes x y z ::"'a :: {conjugatable_ring, comm_ring}"
   shows "x * (y * z) = y * x * z"
   by (simp add: mult.assoc mult.left_commute)
 
 lemma cscalar_prod_conjugate_transpose:
   fixes x y ::"'a :: {conjugatable_ring, comm_ring} vec"
   assumes "A \<in> carrier_mat nr nc"
   assumes "x \<in> carrier_vec nr"
   assumes "y \<in> carrier_vec nc"
   shows "x \<bullet>c (A *\<^sub>v y) = (A\<^sup>H *\<^sub>v x) \<bullet>c y"
   unfolding mult_mat_vec_def scalar_prod_def
   using assms apply (auto simp add: sum_distrib_left sum_distrib_right sum_conjugate conjugate_dist_mul)
   apply (subst sum.swap)
   by (meson helper mult.assoc mult.left_commute sum.cong)
 
 lemma mat_mul_conjugate_transpose_vec_eq_0:                        
   fixes v ::"'a :: {conjugatable_ordered_ring,semiring_no_zero_divisors,comm_ring} vec"
   assumes "A \<in> carrier_mat nr nc"
   assumes "v \<in> carrier_vec nr"
   assumes "A *\<^sub>v (A\<^sup>H *\<^sub>v v) = 0\<^sub>v nr"
   shows "A\<^sup>H *\<^sub>v v = 0\<^sub>v nc"
 proof -
   have "(A\<^sup>H *\<^sub>v v) \<bullet>c (A\<^sup>H *\<^sub>v v) = (A *\<^sub>v (A\<^sup>H *\<^sub>v v)) \<bullet>c v"
     by (metis (mono_tags, lifting) Matrix.carrier_vec_conjugate assms(1) assms(2) assms(3) carrier_matD(2) conjugate_zero_vec cscalar_prod_conjugate_transpose dim_row_conjugate index_transpose_mat(2) mult_mat_vec_def scalar_prod_left_zero scalar_prod_right_zero vec_carrier)
   also have "... = 0"
     by (simp add: assms(2) assms(3))
       (* this step requires real entries *)
   ultimately have "(A\<^sup>H *\<^sub>v v) \<bullet>c (A\<^sup>H *\<^sub>v v) = 0" by auto
   thus ?thesis
     apply (subst conjugate_square_eq_0_vec[symmetric])
     using assms(1) carrier_dim_vec apply fastforce
     by auto
 qed
 
 lemma row_mat_of_cols:
   assumes "i < nr"
   shows "row (mat_of_cols nr ls) i = vec (length ls) (\<lambda>j. (ls ! j) $i)"
   by (simp add: assms mat_of_cols_index vec_eq_iff)
 
 lemma mat_of_cols_cons_mat_vec:
   fixes v ::"'a::comm_ring vec"
   assumes "v \<in> carrier_vec (length ls)"
   assumes "dim_vec a = nr"
   shows
     "mat_of_cols nr (a # ls) *\<^sub>v (vCons m v) =
    m \<cdot>\<^sub>v a + mat_of_cols nr ls *\<^sub>v v"
   unfolding mult_mat_vec_def vec_eq_iff
   using assms by
     (auto simp add: row_mat_of_cols vec_Suc o_def mult.commute)
 
 lemma smult_vec_zero:
   fixes v ::"'a::ring vec"
   shows "0 \<cdot>\<^sub>v v = 0\<^sub>v (dim_vec v)"
   unfolding smult_vec_def vec_eq_iff
   by (auto)
 
 lemma helper2:
   fixes A ::"'a::comm_ring mat"
   fixes v ::"'a vec"
   assumes "v \<in> carrier_vec (length ss)"
   assumes "\<And>x. x \<in> set ls \<Longrightarrow> dim_vec x = nr"
   shows
     "mat_of_cols nr ss *\<^sub>v v =
    mat_of_cols nr (ls @ ss) *\<^sub>v (0\<^sub>v (length ls) @\<^sub>v v)"
   using assms(2)
 proof (induction ls)
   case Nil
   then show ?case by auto
 next
   case (Cons a ls)
   then show ?case apply (auto simp add:zero_vec_Suc)
     apply (subst mat_of_cols_cons_mat_vec)
     by (auto simp add:assms smult_vec_zero)
 qed
 
 lemma mat_of_cols_mult_mat_vec_permute_list:
   fixes v ::"'a::comm_ring list"
   assumes "f permutes {..<length ss}"
   assumes "length ss = length v"
   shows
     "mat_of_cols nr (permute_list f ss) *\<^sub>v vec_of_list (permute_list f v) =
      mat_of_cols nr ss *\<^sub>v vec_of_list v"
   unfolding mat_of_cols_def mult_mat_vec_def vec_eq_iff scalar_prod_def
 proof clarsimp
   fix i
   assume "i < nr"
   from sum.permute[OF assms(1)]
   have "(\<Sum>ia<length ss. ss ! f ia $ i * v ! f ia) =
   sum ((\<lambda>ia. ss ! f ia $ i * v ! f ia) \<circ> f) {..<length ss}" .
   also have "... = (\<Sum>ia = 0..<length v. ss ! f ia $ i * v ! f ia)"
     using assms(2) calculation lessThan_atLeast0 by auto
   ultimately have *: "(\<Sum>ia = 0..<length v.
              ss ! f ia $ i * v ! f ia) =
          (\<Sum>ia = 0..<length v.
              ss ! ia $ i * v ! ia)"
     by (metis (mono_tags, lifting) \<open>\<And>g. sum g {..<length ss} = sum (g \<circ> f) {..<length ss}\<close> assms(2) comp_apply lessThan_atLeast0 sum.cong)
   show "(\<Sum>ia = 0..<length v.
          vec (length ss) (\<lambda>j. permute_list f ss ! j $ i) $ ia *
          vec_of_list (permute_list f v) $ ia) =
          (\<Sum>ia = 0..<length v. vec (length ss) (\<lambda>j. ss ! j $ i) $ ia * vec_of_list v $ ia)"
     using assms * by (auto simp add: permute_list_nth vec_of_list_index)
 qed
 
 (* permute everything in a subset of the indices to the back *)
 lemma subindex_permutation:
   assumes "distinct ss" "set ss \<subseteq> {..<length ls}"
   obtains f where "f permutes {..<length ls}"
     "permute_list f ls = map ((!) ls) (filter (\<lambda>i. i \<notin> set ss) [0..<length ls]) @ map ((!) ls) ss"
 proof -
   have "set [0..<length ls] = set (filter (\<lambda>i. i \<notin> set ss) [0..<length ls] @ ss)"
     using assms unfolding multiset_eq_iff by auto
   then have "mset [0..<length ls] = mset (filter (\<lambda>i. i \<notin> set ss) [0..<length ls] @ ss)"
     apply (subst set_eq_iff_mset_eq_distinct[symmetric])
     using assms by auto  
   then have "mset ls = mset (map ((!) ls)
            (filter (\<lambda>i. i \<notin> set ss)
              [0..<length ls]) @ map ((!) ls) ss)"
     by (metis map_append map_nth mset_map)
   thus ?thesis
     by (metis mset_eq_permutation that)
 qed
 
 lemma subindex_permutation2:
   assumes "distinct ss" "set ss \<subseteq> {..<length ls}"
   obtains f where "f permutes {..<length ls}"
     "ls = permute_list f (map ((!) ls) (filter (\<lambda>i. i \<notin> set ss) [0..<length ls]) @ map ((!) ls) ss)"
   using subindex_permutation
   by (metis assms(1) assms(2) length_permute_list mset_eq_permutation mset_permute_list)
 
 lemma distinct_list_subset_nths:
   assumes "distinct ss" "set ss \<subseteq> set ls"
   obtains ids where "distinct ids" "set ids \<subseteq> {..<length ls}" "ss = map ((!) ls) ids"
 proof -
   let ?ids = "map (\<lambda>i. @j. j < length ls \<and> ls!j = i ) ss"
   have 1: "distinct ?ids" unfolding distinct_map
     using assms apply (auto simp add: inj_on_def)
     by (smt (verit) in_set_conv_nth someI subset_eq)
   have 2: "set ?ids \<subseteq> {..<length ls}"
     using assms apply (auto)
     by (metis (mono_tags, lifting) in_mono in_set_conv_nth tfl_some)
   have 3: "ss = map ((!) ls) ?ids"
     using assms apply (auto simp add: list_eq_iff_nth_eq)
     by (smt (verit, best) in_set_conv_nth someI subsetD)
   show "(\<And>ids. distinct ids \<Longrightarrow>
             set ids \<subseteq> {..<length ls} \<Longrightarrow>
             ss = map ((!) ls) ids \<Longrightarrow> thesis) \<Longrightarrow>
     thesis" using 1 2 3 by blast
 qed
 
 lemma helper3: 
   fixes A ::"'a::comm_ring mat"
   assumes A: "A \<in> carrier_mat nr nc"
   assumes ss:"distinct ss" "set ss \<subseteq> set (cols A)"
   assumes "v \<in> carrier_vec (length ss)"
   obtains c where "mat_of_cols nr ss *\<^sub>v v = A *\<^sub>v c" "dim_vec c = nc"
 proof -
   from distinct_list_subset_nths[OF ss]
   obtain ids where ids: "distinct ids" "set ids \<subseteq> {..<length (cols A)}"
     and ss: "ss = map ((!) (cols A)) ids" by blast
   let ?ls = " map ((!) (cols A)) (filter (\<lambda>i. i \<notin> set ids) [0..<length (cols A)])"
   from subindex_permutation2[OF ids] obtain f where
     f: "f permutes {..<length (cols A)}"
     "cols A = permute_list f (?ls @ ss)" using ss by blast
   have *: "\<And>x. x \<in> set ?ls \<Longrightarrow> dim_vec x = nr"
     using A by auto
   let ?cs1 = "(list_of_vec (0\<^sub>v (length ?ls) @\<^sub>v v))"
   from helper2[OF assms(4) ]
   have "mat_of_cols nr ss *\<^sub>v v = mat_of_cols nr (?ls @ ss) *\<^sub>v vec_of_list (?cs1)"
     using *
     by (metis vec_list)
   also have "... = mat_of_cols nr (permute_list f (?ls @ ss)) *\<^sub>v vec_of_list (permute_list f ?cs1)"
     apply (auto intro!: mat_of_cols_mult_mat_vec_permute_list[symmetric])
      apply (metis cols_length f(1) f(2) length_append length_map length_permute_list)
     using assms(4) by auto
   also have "... =  A *\<^sub>v vec_of_list (permute_list f ?cs1)" using f(2) assms by auto
   ultimately show
     "(\<And>c. mat_of_cols nr ss *\<^sub>v v = A *\<^sub>v c \<Longrightarrow> dim_vec c = nc \<Longrightarrow> thesis) \<Longrightarrow> thesis"
     by (metis A assms(4) carrier_matD(2) carrier_vecD cols_length dim_vec_of_list f(2) index_append_vec(2) index_zero_vec(2) length_append length_list_of_vec length_permute_list)
 qed
 
 lemma mat_mul_conjugate_transpose_sub_vec_eq_0:                        
   fixes A ::"'a :: {conjugatable_ordered_ring,semiring_no_zero_divisors,comm_ring} mat"
   assumes "A \<in> carrier_mat nr nc"
   assumes "distinct ss" "set ss \<subseteq> set (cols (A\<^sup>H))"
   assumes "v \<in> carrier_vec (length ss)"
   assumes "A *\<^sub>v (mat_of_cols nc ss *\<^sub>v v) = 0\<^sub>v nr"
   shows "(mat_of_cols nc ss *\<^sub>v v) = 0\<^sub>v nc"
 proof -
   have "A\<^sup>H \<in> carrier_mat nc nr" using assms(1) by auto
   from  helper3[OF this assms(2-4)]
   obtain c where c: "mat_of_cols nc ss *\<^sub>v v = A\<^sup>H *\<^sub>v c" "dim_vec c = nr" by blast
   have 1: "c \<in> carrier_vec nr"
     using c carrier_vec_dim_vec by blast
   have 2: "A *\<^sub>v (A\<^sup>H *\<^sub>v c) = 0\<^sub>v nr" using c assms(5) by auto
   from mat_mul_conjugate_transpose_vec_eq_0[OF assms(1) 1 2]
   have "A\<^sup>H *\<^sub>v c = 0\<^sub>v nc" .
   thus ?thesis unfolding c(1)[symmetric] .
 qed
 
 lemma Units_invertible:
   fixes A:: "'a::semiring_1 mat"
   assumes "A \<in> Units (ring_mat TYPE('a) n b)"
   shows "invertible_mat A"
   using assms unfolding Units_def invertible_mat_def
   apply (auto simp add: ring_mat_def)
   using inverts_mat_def by blast
 
 lemma invertible_Units:
   fixes A:: "'a::semiring_1 mat"
   assumes "invertible_mat A"
   shows "A \<in> Units (ring_mat TYPE('a) (dim_row A) b)"
   using assms unfolding Units_def invertible_mat_def
   apply (auto simp add: ring_mat_def)
   by (metis assms carrier_mat_triv invertible_mat_def inverts_mat_def inverts_mat_length(1) inverts_mat_length(2))
 
 lemma invertible_det:
   fixes A:: "'a::field mat"
   assumes "A \<in> carrier_mat n n"
   shows "invertible_mat A \<longleftrightarrow> det A \<noteq> 0"
   apply auto
   using invertible_Units unit_imp_det_non_zero apply fastforce
   using assms by (auto intro!: Units_invertible det_non_zero_imp_unit)
 
 context vec_space begin
 
 lemma find_indices_distinct:
   assumes "distinct ss"
   assumes "i < length ss"
   shows "find_indices (ss ! i) ss = [i]"
 proof -
   have "set (find_indices (ss ! i) ss) = {i}"
     using assms apply auto by (simp add: assms(1) assms(2) nth_eq_iff_index_eq)
   thus ?thesis
     by (metis distinct.simps(2) distinct_find_indices empty_iff empty_set insert_iff list.exhaust list.simps(15)) 
 qed
 
 lemma lin_indpt_lin_comb_list:
   assumes "distinct ss"
   assumes "lin_indpt (set ss)"
   assumes "set ss \<subseteq> carrier_vec n"
   assumes "lincomb_list f ss = 0\<^sub>v n"
   assumes "i < length ss"
   shows "f i = 0"
 proof -
   from lincomb_list_as_lincomb[OF assms(3)]
   have "lincomb_list f ss = lincomb (mk_coeff ss f) (set ss)" .
   also have "... = lincomb  (\<lambda>v. sum f (set (find_indices v ss))) (set ss)"
     unfolding mk_coeff_def
     apply (subst R.sumlist_map_as_finsum)
     by (auto simp add: distinct_find_indices)
   ultimately have "lincomb_list f ss = lincomb  (\<lambda>v. sum f (set (find_indices v ss))) (set ss)" by auto
   then have *:"lincomb (\<lambda>v. sum f (set (find_indices v ss))) (set ss) = 0\<^sub>v n"
     using assms(4) by auto
   have "finite (set ss)" by simp
   from not_lindepD[OF assms(2) this _ _ *]
   have "(\<lambda>v. sum f (set (find_indices v ss))) \<in> set ss \<rightarrow> {0}"
     by auto
   from funcset_mem[OF this]
   have "sum f (set (find_indices (nth ss i) ss)) \<in> {0}"
     using assms(5) by auto
   thus ?thesis unfolding find_indices_distinct[OF assms(1) assms(5)]
     by auto
 qed
 
 (* Note: in this locale dim_row A = n, e.g.:
 lemma foo:
   assumes "dim_row A = n"
   shows "rank A = vec_space.rank (dim_row A) A"
   by (simp add: assms) *)
 
 lemma span_mat_mul_subset:
   assumes "A \<in> carrier_mat n d"
   assumes "B \<in> carrier_mat d nc"
   shows "span (set (cols (A * B))) \<subseteq> span (set (cols A))"
 proof -
   have *: "\<And>v. \<exists>ca. lincomb_list v (cols (A * B)) =
               lincomb_list ca  (cols A)"
   proof -
     fix v
     have "lincomb_list v (cols (A * B)) = (A * B) *\<^sub>v vec nc v"
       apply (subst lincomb_list_as_mat_mult)
        apply (metis assms(1) carrier_dim_vec carrier_matD(1) cols_dim index_mult_mat(2) subset_code(1))
       by (metis assms(1) assms(2) carrier_matD(1) carrier_matD(2) cols_length index_mult_mat(2) index_mult_mat(3) mat_of_cols_cols)
     also have "... = A *\<^sub>v (B *\<^sub>v vec nc v)"
       using assms(1) assms(2) by auto
     also have "... = lincomb_list (\<lambda>i. (B *\<^sub>v vec nc v) $ i) (cols A)"
       apply (subst lincomb_list_as_mat_mult)
       using assms(1) carrier_dim_vec cols_dim apply blast
       by (metis assms(1) assms(2) carrier_matD(1) carrier_matD(2) cols_length dim_mult_mat_vec dim_vec eq_vecI index_vec mat_of_cols_cols)
     ultimately have "lincomb_list v (cols (A * B)) =
               lincomb_list (\<lambda>i. (B *\<^sub>v vec nc v) $ i) (cols A)" by auto
     thus "\<exists>ca. lincomb_list v (cols (A * B)) = lincomb_list ca (cols A)" by auto
   qed
   show ?thesis
     apply (subst span_list_as_span[symmetric])
      apply (metis assms(1) carrier_matD(1) cols_dim index_mult_mat(2))
     apply (subst span_list_as_span[symmetric])
     using assms(1) cols_dim apply blast
     by (auto simp add:span_list_def *)
 qed
 
 lemma rank_mat_mul_right:
   assumes "A \<in> carrier_mat n d"
   assumes "B \<in> carrier_mat d nc"
   shows "rank (A * B) \<le> rank A"
 proof -
   have "subspace class_ring (local.span (set (cols (A*B))))
         (vs (local.span (set (cols A))))"
     unfolding subspace_def
     by (metis assms(1) assms(2) carrier_matD(1) cols_dim index_mult_mat(2) nested_submodules span_is_submodule vec_space.span_mat_mul_subset vec_vs_col)
   from vectorspace.subspace_dim[OF _ this]
   have "vectorspace.dim class_ring
    (vs (local.span (set (cols A)))
     \<lparr>carrier := local.span (set (cols (A * B)))\<rparr>) \<le>
   vectorspace.dim class_ring
       (vs (local.span (set (cols A))))"
     apply auto
     by (metis (no_types) assms(1) carrier_matD(1) fin_dim_span_cols index_mult_mat(2) mat_of_cols_carrier(1) mat_of_cols_cols vec_vs_col)
   thus ?thesis unfolding rank_def
     by auto
 qed
 
 lemma sumlist_drop:
   assumes "\<And>v. v \<in> set ls \<Longrightarrow> dim_vec v = n"
   shows "sumlist ls = sumlist (filter (\<lambda>v. v \<noteq> 0\<^sub>v n) ls)"
   using assms
 proof (induction ls)
   case Nil
   then show ?case by auto
 next
   case (Cons a ls)
   then show ?case using dim_sumlist by auto
 qed
 
 lemma lincomb_list_alt:
   shows "lincomb_list c s =
     sumlist (map2 (\<lambda>i j. i \<cdot>\<^sub>v s ! j) (map (\<lambda>i. c i) [0..<length s]) [0..<length s])"
   unfolding lincomb_list_def
   by (smt (verit, ccfv_SIG) length_map map2_map_map map_nth nth_equalityI nth_map)
 
 lemma lincomb_list_alt2:
   assumes "\<And>v. v \<in> set s \<Longrightarrow> dim_vec v = n"
   assumes "\<And>i. i \<in> set ls \<Longrightarrow> i < length s"
   shows "
     sumlist (map2 (\<lambda>i j. i \<cdot>\<^sub>v s ! j) (map (\<lambda>i. c i) ls) ls) =
     sumlist (map2 (\<lambda>i j. i \<cdot>\<^sub>v s ! j) (map (\<lambda>i. c i) (filter (\<lambda>i. c i \<noteq> 0) ls)) (filter (\<lambda>i. c i \<noteq> 0) ls))"
   using assms(2)
 proof (induction ls)
   case Nil
   then show ?case by auto
 next
   case (Cons a s)
   then show ?case
     apply auto
     apply (subst smult_l_null)
      apply (simp add: assms(1) carrier_vecI)
     apply (subst left_zero_vec)
      apply (subst sumlist_carrier)
       apply auto
     by (metis (no_types, lifting) assms(1) carrier_dim_vec mem_Collect_eq nth_mem set_filter set_zip_rightD)
 qed 
 
 lemma two_set:
   assumes "distinct ls"
   assumes "set ls = set [a,b]"
   assumes "a \<noteq> b"
   shows "ls = [a,b] \<or> ls = [b,a]"
   apply (cases ls)
   using assms(2) apply auto[1]
 proof -
   fix x xs
   assume ls:"ls = x # xs"
   obtain y ys where xs:"xs = y # ys"
     by (metis (no_types) \<open>ls = x # xs\<close> assms(2) assms(3) list.set_cases list.set_intros(1) list.set_intros(2) set_ConsD)
   have 1:"x = a \<or> x = b"
     using \<open>ls = x # xs\<close> assms(2) by auto
   have 2:"y = a \<or> y = b"
     using \<open>ls = x # xs\<close> \<open>xs = y # ys\<close> assms(2) by auto
   have 3:"ys = []"
     by (metis (no_types) \<open>ls = x # xs\<close> \<open>xs = y # ys\<close> assms(1) assms(2) distinct.simps(2) distinct_length_2_or_more in_set_member member_rec(2) neq_Nil_conv set_ConsD)
   show "ls = [a, b] \<or> ls = [b, a]" using ls xs 1 2 3 assms
     by auto
 qed
 
 lemma filter_disj_inds:
   assumes "i < length ls" "j < length ls" "i \<noteq> j"
   shows "filter (\<lambda>ia. ia \<noteq> j \<longrightarrow> ia = i) [0..<length ls] = [i, j] \<or>
   filter (\<lambda>ia. ia \<noteq> j \<longrightarrow> ia = i) [0..<length ls] = [j,i]"
 proof -
   have 1: "distinct (filter (\<lambda>ia. ia = i \<or> ia = j) [0..<length ls])"
     using distinct_filter distinct_upt by blast
   have 2:"set (filter (\<lambda>ia. ia = i \<or> ia = j) [0..<length ls]) = {i, j}"
     using assms by auto
   show ?thesis using two_set[OF 1]
     using assms(3) empty_set filter_cong list.simps(15)
     by (smt(verit, ccfv_SIG) "2" assms(3) empty_set filter_cong list.simps(15))
 qed
 
 lemma lincomb_list_indpt_distinct:
   assumes "\<And>v. v \<in> set ls \<Longrightarrow> dim_vec v = n"
   assumes
     "\<And>c. lincomb_list c ls = 0\<^sub>v n \<Longrightarrow> (\<forall>i. i < (length ls) \<longrightarrow> c i = 0)"
   shows "distinct ls"
   unfolding distinct_conv_nth
 proof clarsimp
   fix i j
   assume ij: "i < length ls" "j < length ls" "i \<noteq> j" 
   assume lsij: "ls ! i = ls ! j"
   have "lincomb_list (\<lambda>k. if k = i then 1 else if k = j then -1 else 0) ls =
      (ls ! i) - (ls ! j)"
     unfolding lincomb_list_alt
     apply (subst lincomb_list_alt2[OF assms(1)])
       apply auto
     using  filter_disj_inds[OF ij]
     apply auto
     using ij(3) apply force
     using assms(1) ij(2) apply auto[1]
     using ij(3) apply blast
     using assms(1) ij(2) by auto
   also have "...  = 0\<^sub>v n" unfolding lsij
     apply (rule minus_cancel_vec)
     using \<open>j < length ls\<close> assms(1)
     using carrier_vec_dim_vec nth_mem by blast
   ultimately have "lincomb_list (\<lambda>k. if k = i then 1 else if k = j then -1 else 0) ls = 0\<^sub>v n" by auto
   from assms(2)[OF this]
   show False
     using \<open>i < length ls\<close> by auto
 qed
 
 end
 
 locale conjugatable_vec_space = vec_space f_ty n for
   f_ty::"'a::conjugatable_ordered_field itself"
   and n
 begin                                                           
 
 lemma transpose_rank_mul_conjugate_transpose:
   fixes A :: "'a mat"
   assumes "A \<in> carrier_mat n nc"
   shows "vec_space.rank nc A\<^sup>H \<le> rank (A * A\<^sup>H)"
 proof -
   have 1: "A\<^sup>H \<in> carrier_mat nc n" using assms by auto
   have 2: "A * A\<^sup>H \<in> carrier_mat n n" using assms by auto
       (* S is a maximal linearly independent set of rows A (or cols A\<^sup>T) *)
   let ?P = "(\<lambda>T. T \<subseteq> set (cols A\<^sup>H) \<and> module.lin_indpt class_ring (module_vec TYPE('a) nc) T)"
   have *:"\<And>A. ?P A \<Longrightarrow> finite A \<and> card A \<le> n"
   proof clarsimp
     fix S
     assume S: "S \<subseteq> set (cols A\<^sup>H)"
     have "card S \<le> card (set (cols A\<^sup>H))" using S
       using card_mono by blast
     also have "... \<le> length (cols A\<^sup>H)" using card_length by blast
     also have "... \<le> n" using assms by auto
     ultimately show "finite S \<and> card S \<le> n"
       by (meson List.finite_set S dual_order.trans finite_subset)
   qed
   have **:"?P {}"
     apply (subst module.lin_dep_def)
     by (auto simp add: vec_module)
   from maximal_exists[OF *]
   obtain S where S: "maximal S ?P" using **
     by (metis (no_types, lifting)) 
       (* Some properties of S *)
   from vec_space.rank_card_indpt[OF 1 S]
   have rankeq: "vec_space.rank nc A\<^sup>H = card S" .
 
   have s_hyp: "S \<subseteq> set (cols A\<^sup>H)"
     using S unfolding maximal_def by simp
   have modhyp: "module.lin_indpt class_ring (module_vec TYPE('a) nc) S" 
     using S unfolding maximal_def by simp
 
 (* switch to a list representation *)
   obtain ss where ss: "set ss = S" "distinct ss"
     by (metis (mono_tags) S maximal_def set_obtain_sublist)
   have ss2: "set (map ((*\<^sub>v) A) ss) = (*\<^sub>v) A ` S"
     by (simp add: ss(1))
   have rw_hyp: "cols (mat_of_cols n (map ((*\<^sub>v) A) ss)) = cols  (A * mat_of_cols nc ss)" 
     unfolding cols_def apply (auto)
     using mat_vec_as_mat_mat_mult[of A n nc]
     by (metis (no_types, lifting) "1" assms carrier_matD(1) cols_dim mul_mat_of_cols nth_mem s_hyp ss(1) subset_code(1))
   then have rw: "mat_of_cols n (map ((*\<^sub>v) A) ss) = A * mat_of_cols nc ss"
     by (metis assms carrier_matD(1) index_mult_mat(2) mat_of_cols_carrier(2) mat_of_cols_cols) 
   have indpt: "\<And>c. lincomb_list c (map ((*\<^sub>v) A) ss) = 0\<^sub>v n \<Longrightarrow>
       \<forall>i. (i < (length ss) \<longrightarrow> c i = 0)"
   proof clarsimp
     fix c i
     assume *: "lincomb_list c (map ((*\<^sub>v) A) ss) = 0\<^sub>v n"
     assume i: "i < length ss"
     have "\<forall>w\<in>set (map ((*\<^sub>v) A) ss). dim_vec w = n"
       using assms by auto
     from lincomb_list_as_mat_mult[OF this]
     have "A * mat_of_cols nc ss *\<^sub>v  vec (length ss) c = 0\<^sub>v n"
       using * rw by auto
     then have hq: "A *\<^sub>v (mat_of_cols nc ss *\<^sub>v vec (length ss) c) =  0\<^sub>v n"
       by (metis assms assoc_mult_mat_vec mat_of_cols_carrier(1) vec_carrier)
 
     then have eq1: "(mat_of_cols nc ss *\<^sub>v vec (length ss) c) =  0\<^sub>v nc"
       apply (intro mat_mul_conjugate_transpose_sub_vec_eq_0)
       using assms ss s_hyp by auto
 
 (* Rewrite the inner vector back to a lincomb_list *)
     have dim_hyp2: "\<forall>w\<in>set ss. dim_vec w = nc"
       using ss(1) s_hyp
       by (metis "1" carrier_matD(1) carrier_vecD cols_dim subsetD) 
     from vec_module.lincomb_list_as_mat_mult[OF this, symmetric]
     have "mat_of_cols nc ss *\<^sub>v vec (length ss) c = module.lincomb_list (module_vec TYPE('a) nc) c ss" .
     then have "module.lincomb_list (module_vec TYPE('a) nc) c ss = 0\<^sub>v nc" using eq1 by auto
     from vec_space.lin_indpt_lin_comb_list[OF ss(2) _ _ this i]
     show "c i = 0" using modhyp ss s_hyp
       using "1" cols_dim by blast
   qed
   have distinct: "distinct (map ((*\<^sub>v) A) ss)"
     by (metis (no_types, lifting) assms carrier_matD(1) dim_mult_mat_vec imageE indpt length_map lincomb_list_indpt_distinct ss2)
   then have 3: "card S = card ((*\<^sub>v) A ` S)"
     by (metis ss distinct_card image_set length_map)
   then have 4: "(*\<^sub>v) A ` S \<subseteq> set (cols (A * A\<^sup>H))"
     using cols_mat_mul \<open>S \<subseteq> set (cols A\<^sup>H)\<close> by blast
   have 5: "lin_indpt ((*\<^sub>v) A ` S)"
   proof clarsimp
     assume ld:"lin_dep ((*\<^sub>v) A ` S)"
     have *: "finite ((*\<^sub>v) A ` S)"
       by (metis List.finite_set ss2)
     have **: "(*\<^sub>v) A ` S \<subseteq> carrier_vec n"
       using "2" "4" cols_dim by blast
     from finite_lin_dep[OF * ld **]
     obtain a v where
       a: "lincomb a ((*\<^sub>v) A ` S) = 0\<^sub>v n" and
       v: "v \<in> (*\<^sub>v) A ` S" "a v \<noteq> 0" by blast
     obtain i where i:"v = map ((*\<^sub>v) A) ss ! i" "i < length ss"
       using v unfolding ss2[symmetric]
       using find_first_le nth_find_first by force
     from ss2[symmetric]
     have "set (map ((*\<^sub>v) A) ss)\<subseteq> carrier_vec n" using ** ss2 by auto
     from lincomb_as_lincomb_list_distinct[OF this distinct] have
       "lincomb_list
      (\<lambda>i. a (map ((*\<^sub>v) A) ss ! i))  (map ((*\<^sub>v) A) ss) = 0\<^sub>v n"
       using a ss2 by auto
     from indpt[OF this]
     show False using v i by simp
   qed
   from rank_ge_card_indpt[OF 2 4 5]
   have "card ((*\<^sub>v) A ` S) \<le> rank (A * A\<^sup>H)" .
   thus ?thesis using rankeq 3 by linarith
 qed
 
 lemma conjugate_transpose_rank_le:
   assumes "A \<in> carrier_mat n nc"
   shows "vec_space.rank nc (A\<^sup>H) \<le> rank A"
   by (metis assms carrier_matD(2) carrier_mat_triv dim_row_conjugate dual_order.trans index_transpose_mat(2) rank_mat_mul_right transpose_rank_mul_conjugate_transpose)
 
 lemma conjugate_finsum:
   assumes f: "f : U \<rightarrow> carrier_vec n"
   shows "conjugate (finsum V f U) = finsum V (conjugate \<circ> f) U"
   using f
 proof (induct U rule: infinite_finite_induct)
   case (infinite A)
   then show ?case by auto
 next
   case empty
   then show ?case by auto
 next
   case (insert u U)
   hence f: "f : U \<rightarrow> carrier_vec n" "f u : carrier_vec n"  by auto
   then have cf: "conjugate \<circ> f : U \<rightarrow> carrier_vec n"
     "(conjugate \<circ> f) u : carrier_vec n"
      apply (simp add: Pi_iff)
     by (simp add: f(2))
   then show ?case
     unfolding finsum_insert[OF insert(1) insert(2) f]
     unfolding finsum_insert[OF insert(1) insert(2) cf ]
     apply (subst conjugate_add_vec[of _ n])
     using f(2) apply blast
     using M.finsum_closed f(1) apply blast
     by (simp add: comp_def f(1) insert.hyps(3))
 qed
 
 lemma rank_conjugate_le:
   assumes A:"A \<in> carrier_mat n d"
   shows "rank (conjugate (A)) \<le> rank A"
 proof -
   (* S is a maximal linearly independent set of (conjugate A) *)
   let ?P = "(\<lambda>T. T \<subseteq> set (cols (conjugate A)) \<and> lin_indpt T)"
   have *:"\<And>A. ?P A \<Longrightarrow> finite A \<and> card A \<le> d"
     by (metis List.finite_set assms card_length card_mono carrier_matD(2) cols_length dim_col_conjugate dual_order.trans rev_finite_subset)
   have **:"?P {}"
     by (simp add: finite_lin_indpt2)
   from maximal_exists[OF *]
   obtain S where S: "maximal S ?P" using **
     by (metis (no_types, lifting))
   have s_hyp: "S \<subseteq> set (cols (conjugate A))" "lin_indpt S"
     using S unfolding maximal_def
      apply blast
     by (metis (no_types, lifting) S maximal_def)
   from rank_card_indpt[OF _ S, of d]
   have rankeq: "rank (conjugate A) = card S" using assms by auto 
   have 1:"conjugate ` S \<subseteq> set (cols A)"
     using S apply auto
     by (metis (no_types, lifting) cols_conjugate conjugate_id image_eqI in_mono list.set_map s_hyp(1))
   have 2: "lin_indpt (conjugate ` S)"
     apply (rule ccontr)
     apply (auto simp add: lin_dep_def)
   proof -
     fix T c v
     assume T: "T \<subseteq> conjugate ` S" "finite T" and
       lc:"lincomb c T = 0\<^sub>v n" and "v \<in> T"  "c v \<noteq> 0"
     let ?T = "conjugate ` T"
     let ?c = "conjugate \<circ> c \<circ> conjugate"
     have 1: "finite ?T"  using T by auto
     have 2: "?T \<subseteq> S"  using T by auto
     have 3: "?c \<in> ?T \<rightarrow> UNIV" by auto
     have "lincomb ?c ?T = (\<Oplus>\<^bsub>V\<^esub>x\<in>T. conjugate (c x) \<cdot>\<^sub>v conjugate x)"
       unfolding lincomb_def
       apply (subst finsum_reindex)
         apply auto
        apply (metis "2" carrier_vec_conjugate assms carrier_matD(1) cols_dim image_eqI s_hyp(1) subsetD)
       by (meson conjugate_cancel_iff inj_onI)
     also have "... = (\<Oplus>\<^bsub>V\<^esub>x\<in>T. conjugate (c x \<cdot>\<^sub>v x)) "
       by (simp add: conjugate_smult_vec)
     also have "... = conjugate (\<Oplus>\<^bsub>V\<^esub>x\<in>T. (c x \<cdot>\<^sub>v x))"
       apply(subst conjugate_finsum[of "\<lambda>x.(c x \<cdot>\<^sub>v x)" T])
        apply (auto simp add:o_def)
       by (smt (verit, ccfv_SIG) Matrix.carrier_vec_conjugate Pi_I' T(1) assms carrier_matD(1) cols_dim dim_row_conjugate imageE s_hyp(1) smult_carrier_vec subset_eq) 
     also have "... = conjugate (lincomb c T)"
       using lincomb_def by presburger
     ultimately have "lincomb ?c ?T = conjugate (lincomb c T)" by auto
     then have 4:"lincomb ?c ?T = 0\<^sub>v n" using lc by auto
     from not_lindepD[OF s_hyp(2) 1 2 3 4]
     have "conjugate \<circ> c \<circ> conjugate \<in> conjugate ` T \<rightarrow> {0}" .
     then have "c v = 0"
       by (simp add: Pi_iff \<open>v \<in> T\<close>)
     thus False using \<open>c v \<noteq> 0\<close> by auto
   qed
   from rank_ge_card_indpt[OF A 1 2]
   have 3:"card (conjugate ` S) \<le> rank A" .
   have 4: "card (conjugate ` S) = card S"
     apply (auto intro!: card_image)
     by (meson conjugate_cancel_iff inj_onI)
   show ?thesis using rankeq 3 4 by auto
 qed
 
 lemma rank_conjugate:
   assumes "A \<in> carrier_mat n d"
   shows "rank (conjugate A) = rank A"
   using  rank_conjugate_le
   by (metis carrier_vec_conjugate assms conjugate_id dual_order.antisym)
 
 end (* exit the context *)
 
 lemma conjugate_transpose_rank:
   fixes A::"'a::{conjugatable_ordered_field} mat"
   shows "vec_space.rank (dim_row A) A = vec_space.rank (dim_col A) (A\<^sup>H)"
   using  conjugatable_vec_space.conjugate_transpose_rank_le
   by (metis (no_types, lifting) Matrix.transpose_transpose carrier_matI conjugate_id dim_col_conjugate dual_order.antisym index_transpose_mat(2) transpose_conjugate)
 
 lemma transpose_rank:
   fixes A::"'a::{conjugatable_ordered_field} mat"
   shows "vec_space.rank (dim_row A) A = vec_space.rank (dim_col A) (A\<^sup>T)"
   by (metis carrier_mat_triv conjugatable_vec_space.rank_conjugate conjugate_transpose_rank index_transpose_mat(2))
 
 lemma rank_mat_mul_left:
   fixes A::"'a::{conjugatable_ordered_field} mat"
   assumes "A \<in> carrier_mat n d"
   assumes "B \<in> carrier_mat d nc"
   shows "vec_space.rank n (A * B) \<le> vec_space.rank d B"
   by (metis (no_types, lifting) Matrix.transpose_transpose assms(1) assms(2) carrier_matD(1) carrier_matD(2) carrier_mat_triv conjugatable_vec_space.rank_conjugate conjugate_transpose_rank index_mult_mat(3) index_transpose_mat(3) transpose_mult vec_space.rank_mat_mul_right)
 
 section "Results on Invertibility"
 
 (* Extract specific columns of a matrix  *)
 definition take_cols :: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
   where "take_cols A inds = mat_of_cols (dim_row A) (map ((!) (cols A)) (filter ((>) (dim_col A)) inds))"
 
 definition take_cols_var :: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
   where "take_cols_var A inds = mat_of_cols (dim_row A) (map ((!) (cols A)) (inds))"
 
 definition take_rows :: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
   where "take_rows A inds = mat_of_rows (dim_col A) (map ((!) (rows A)) (filter ((>) (dim_row A)) inds))"
 
 lemma cong1:
   "x = y \<Longrightarrow>  mat_of_cols n x = mat_of_cols n y"
   by auto
 
 lemma nth_filter:
   assumes "j < length (filter P ls)"
   shows "P  ((filter P ls) ! j)"
   by (simp add: assms list_ball_nth)
 
 lemma take_cols_mat_mul:
   assumes "A \<in> carrier_mat nr n"
   assumes "B \<in> carrier_mat n nc"
   shows "A * take_cols B inds = take_cols (A * B) inds"
 proof -
   have "\<And>j. j < length (map ((!) (cols B)) (filter ((>) nc) inds)) \<Longrightarrow>
       (map ((!) (cols B)) (filter ((>) nc) inds)) ! j \<in> carrier_vec n"
     using assms apply auto
     apply (subst cols_nth)
     using nth_filter by auto
   from mul_mat_of_cols[OF assms(1) this]
   have "A *  take_cols B inds = mat_of_cols nr (map (\<lambda>x. A *\<^sub>v cols B ! x) (filter ((>) (dim_col B)) inds))"
     unfolding take_cols_def using assms by (auto simp add: o_def)
   also have "... = take_cols (A * B) inds"
     unfolding take_cols_def using assms by (auto intro!: cong1)
   ultimately show ?thesis by auto
 qed
 
 lemma take_cols_carrier_mat:
   assumes "A \<in> carrier_mat nr nc"
   obtains n where "take_cols A inds \<in> carrier_mat nr n"
   unfolding take_cols_def
   using assms
   by fastforce
 
 lemma take_cols_carrier_mat_strict:
   assumes "A \<in> carrier_mat nr nc"
   assumes "\<And>i. i \<in> set inds \<Longrightarrow> i < nc"
   shows "take_cols A inds \<in> carrier_mat nr (length inds)"
   unfolding take_cols_def
   using assms by auto
 
 lemma gauss_jordan_take_cols:  
   assumes "gauss_jordan A (take_cols A inds) = (C,D)"
   shows "D = take_cols C inds"
 proof -
   obtain nr nc where A: "A  \<in> carrier_mat nr nc" by auto
   from take_cols_carrier_mat[OF this]
   obtain n where B: "take_cols A inds \<in> carrier_mat nr n" by auto
   from gauss_jordan_transform[OF A B assms, of undefined]
   obtain P where PP:"P\<in>Units (ring_mat TYPE('a) nr undefined)" and
     CD: "C = P * A" "D = P * take_cols A inds" by blast
   have P: "P \<in> carrier_mat nr nr"
     by (metis (no_types, lifting) Units_def PP mem_Collect_eq partial_object.select_convs(1) ring_mat_def)
   from take_cols_mat_mul[OF P A]
   have "P * take_cols A inds = take_cols (P * A) inds" .
   thus ?thesis using CD by blast  
 qed
 
 lemma dim_col_take_cols:
   assumes "\<And>j. j \<in> set inds \<Longrightarrow> j < dim_col A"
   shows "dim_col (take_cols A inds) = length inds"
   unfolding take_cols_def
   using assms by auto
 
 lemma dim_col_take_rows[simp]:
   shows "dim_col (take_rows A inds) = dim_col A"
   unfolding take_rows_def by auto
 
 lemma cols_take_cols_subset:
   shows "set (cols (take_cols A inds)) \<subseteq> set (cols A)"
   unfolding take_cols_def
   apply (subst cols_mat_of_cols)
    apply auto
   using in_set_conv_nth by fastforce
 
 lemma dim_row_take_cols[simp]:
   shows "dim_row (take_cols A ls) = dim_row A"
   by (simp add: take_cols_def)
 
 lemma dim_row_append_rows[simp]:
   shows "dim_row (A @\<^sub>r B) = dim_row A + dim_row B"
   by (simp add: append_rows_def)
 
 lemma rows_inj:
   assumes "dim_col A = dim_col B"
   assumes "rows A = rows B"
   shows "A = B"
   unfolding mat_eq_iff
   apply auto
     apply (metis assms(2) length_rows)
   using assms(1) apply blast
   by (metis assms(1) assms(2) mat_of_rows_rows)
 
 lemma append_rows_index:
   assumes "dim_col A = dim_col B"
   assumes "i < dim_row A + dim_row B"
   assumes "j < dim_col A"
   shows "(A @\<^sub>r B) $$ (i,j) = (if i < dim_row A then A $$ (i,j) else B $$ (i-dim_row A,j))"
   unfolding append_rows_def
   apply (subst index_mat_four_block)
   using assms by auto
 
 lemma row_append_rows:
   assumes "dim_col A = dim_col B"
   assumes "i < dim_row A + dim_row B"
   shows "row (A @\<^sub>r B) i = (if i < dim_row A then row A i else row B (i-dim_row A))"
   unfolding vec_eq_iff
   using assms by (auto simp add: append_rows_def)
 
 lemma append_rows_mat_mul:
   assumes "dim_col A = dim_col B"
   shows "(A @\<^sub>r B) * C = A * C @\<^sub>r B * C"
   unfolding mat_eq_iff
   apply auto
    apply (simp add: append_rows_def)
   apply (subst index_mult_mat)
     apply auto
    apply (simp add: append_rows_def)
   apply (subst  append_rows_index)
      apply auto
     apply (simp add: append_rows_def)
    apply (metis add.right_neutral append_rows_def assms index_mat_four_block(3) index_mult_mat(1) index_mult_mat(3) index_zero_mat(3) row_append_rows trans_less_add1)
   by (metis add_cancel_right_right add_diff_inverse_nat append_rows_def assms index_mat_four_block(3) index_mult_mat(1) index_mult_mat(3) index_zero_mat(3) nat_add_left_cancel_less row_append_rows)
 
 lemma cardlt:
   shows "card  {i. i < (n::nat)} \<le> n"
   by simp
 
 lemma row_echelon_form_zero_rows:
   assumes row_ech: "row_echelon_form A"
   assumes dim_asm: "dim_col A \<ge> dim_row A"
   shows "take_rows A [0..<length (pivot_positions A)] @\<^sub>r  0\<^sub>m (dim_row A - length (pivot_positions A))  (dim_col A) = A"
 proof -
   have ex_pivot_fun: "\<exists> f. pivot_fun A f (dim_col A)" using row_ech unfolding row_echelon_form_def by auto
   have len_help: "length (pivot_positions A) = card {i. i < dim_row A \<and> row A i \<noteq> 0\<^sub>v (dim_col A)}"
     using ex_pivot_fun pivot_positions[where A = "A",where nr = "dim_row A", where nc = "dim_col A"]
     by auto
   then have len_help2: "length (pivot_positions A) \<le> dim_row A"
     by (metis (no_types, lifting) card_mono cardlt finite_Collect_less_nat le_trans mem_Collect_eq subsetI)
   have fileq: "filter (\<lambda>y. y < dim_row A) [0..< length (pivot_positions A)] = [0..<length (pivot_positions A)]"
     apply (rule filter_True)
     using len_help2 by auto
   have "\<forall>n. card {i. i < n  \<and> row A i \<noteq> 0\<^sub>v (dim_col A)} \<le> n"
   proof clarsimp 
     fix n
     have h: "\<forall>x. x \<in> {i. i < n \<and> row A i \<noteq> 0\<^sub>v (dim_col A)} \<longrightarrow> x\<in>{..<n}"
       by simp
     then have h1: "{i. i < n  \<and> row A i \<noteq> 0\<^sub>v (dim_col A)} \<subseteq> {..<n}"
       by blast
     then have h2: "(card {i. i < n  \<and> row A i \<noteq> 0\<^sub>v (dim_col A)}::nat) \<le> (card {..<n}::nat)"
       using card_mono by blast 
     then show "(card {i. i < n \<and> row A i \<noteq> 0\<^sub>v (dim_col A)}::nat) \<le> (n::nat)" using h2 card_lessThan[of n]
       by auto
   qed
   then have pivot_len: "length (pivot_positions A) \<le> dim_row A "  using len_help
     by simp
   have alt_char: "mat_of_rows (dim_col A)
          (map ((!) (rows A)) (filter (\<lambda>y. y < dim_col A) [0..<length (pivot_positions A)])) = 
       mat_of_rows (dim_col A) (map ((!) (rows A))  [0..<length (pivot_positions A)])"
     using pivot_len dim_asm
     by auto
   have h1: "\<And>i j. i < dim_row A \<Longrightarrow>
            j < dim_col A \<Longrightarrow>
            i < dim_row (take_rows A [0..<length (pivot_positions A)]) \<Longrightarrow>
            take_rows A [0..<length (pivot_positions A)] $$ (i, j) = A $$ (i, j)"
   proof - 
     fix i 
     fix j
     assume "i < dim_row A"
     assume j_lt: "j < dim_col A"
     assume i_lt: "i < dim_row (take_rows A [0..<length (pivot_positions A)])" 
     have lt: "length (pivot_positions A) \<le> dim_row A" using pivot_len by auto
     have h1: "take_rows A [0..<length (pivot_positions A)] $$ (i, j) = (row (take_rows A [0..<length (pivot_positions A)]) i)$j"
       by (simp add: i_lt j_lt)
     then have h2: "(row (take_rows A [0..<length (pivot_positions A)]) i)$j = (row A i)$j"
       using lt alt_char i_lt unfolding take_rows_def by auto
     show "take_rows A [0..<length (pivot_positions A)] $$ (i, j) = A $$ (i, j)"
       using h1 h2
       by (simp add: \<open>i < dim_row A\<close> j_lt) 
   qed
   let ?nc = "dim_col A"
   let ?nr = "dim_row A"
   have h2: "\<And>i j. i < dim_row A \<Longrightarrow>
            j < dim_col A \<Longrightarrow>
            \<not> i < dim_row (take_rows A [0..<length (pivot_positions A)]) \<Longrightarrow>
            0\<^sub>m (dim_row A - length (pivot_positions A)) (dim_col A) $$
            (i - dim_row (take_rows A [0..<length (pivot_positions A)]), j) =
            A $$ (i, j)"
   proof - 
     fix i
     fix j
     assume lt_i: "i < dim_row A"
     assume lt_j: "j < dim_col A"
     assume not_lt: "\<not> i < dim_row (take_rows A [0..<length (pivot_positions A)])"
     let ?ip = "i+1"
     have h0: "\<exists>f. pivot_fun A f (dim_col A) \<and> f i = ?nc"
     proof -  
       have half1: "\<exists>f. pivot_fun A f (dim_col A)" using assms unfolding row_echelon_form_def
         by blast
       have half2: "\<forall>f. pivot_fun A f (dim_col A) \<longrightarrow> f i = ?nc " 
       proof clarsimp
         fix f
         assume is_piv: "pivot_fun A f (dim_col A)"
         have len_pp: "length (pivot_positions A) = card {i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc}" using is_piv pivot_positions[of A ?nr ?nc f]
           by auto
         have  "\<forall>i. (i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc) \<longleftrightarrow>  (i < ?nr \<and> f i \<noteq> ?nc)"
           using is_piv pivot_fun_zero_row_iff[of A f ?nc ?nr]
           by blast
         then have len_pp_var: "length (pivot_positions A) = card {i. i < ?nr \<and> f i \<noteq> ?nc}" 
           using len_pp  by auto 
         have allj_hyp: "\<forall>j < ?nr. f j = ?nc \<longrightarrow> ((Suc j) < ?nr \<longrightarrow> f (Suc j) = ?nc)" 
           using is_piv unfolding pivot_fun_def 
           using lt_i
           by (metis le_antisym le_less) 
         have if_then_bad: "f i \<noteq> ?nc \<longrightarrow> (\<forall>j. j \<le> i \<longrightarrow> f j \<noteq> ?nc)"
         proof clarsimp 
           fix j
           assume not_i: "f i \<noteq> ?nc"
           assume j_leq: "j \<le> i"
           assume bad_asm: "f j = ?nc"
           have "\<And>k. k \<ge> j \<Longrightarrow>  k < ?nr \<Longrightarrow> f k = ?nc"
           proof -
             fix k :: nat
             assume a1: "j \<le> k"
             assume a2: "k < dim_row A"
             have f3: "\<And>n. \<not> n < dim_row A \<or> f n \<noteq> f j \<or> \<not> Suc n < dim_row A \<or> f (Suc n) = f j"
               using allj_hyp bad_asm by presburger
             obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> nat" where
               f4: "\<And>n na p nb nc. (\<not> n \<le> na \<or> Suc n \<le> Suc na) \<and> (\<not> p nb \<or> \<not> nc \<le> nb \<or> \<not> p (nn nc nb p) \<or> p nc) \<and> (\<not> p nb \<or> \<not> nc \<le> nb \<or> p nc \<or> p (Suc (nn nc nb p)))"
-              using inc_induct order_refl by moura
+              using inc_induct by (metis Suc_le_mono)
             then have f5: "\<And>p. \<not> p k \<or> p j \<or> p (Suc (nn j k p))"
               using a1 by presburger
             have f6: "\<And>p. \<not> p k \<or> \<not> p (nn j k p) \<or> p j"
               using f4 a1 by meson
             { assume "nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A) < dim_row A \<and> f (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A)) \<noteq> dim_col A"
               moreover
               { assume "(nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A) < dim_row A \<and> f (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A)) \<noteq> dim_col A) \<and> (\<not> j < dim_row A \<or> f j = dim_col A)"
                 then have "\<not> k < dim_row A \<or> f k = dim_col A"
                   using f6
                   by (metis (mono_tags, lifting)) }
               ultimately have "(\<not> j < dim_row A \<or> f j = dim_col A) \<and> (\<not> Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A)) < dim_row A \<or> f (Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A))) = dim_col A) \<or> \<not> k < dim_row A \<or> f k = dim_col A"
                 using bad_asm
                 by blast }
             moreover
             { assume "(\<not> j < dim_row A \<or> f j = dim_col A) \<and> (\<not> Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A)) < dim_row A \<or> f (Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A))) = dim_col A)"
               then have "\<not> k < dim_row A \<or> f k = dim_col A"
                 using f5
               proof -
                 have "\<not> (Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A)) < dim_row A \<and> f (Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A))) \<noteq> dim_col A) \<and> \<not> (j < dim_row A \<and> f j \<noteq> dim_col A)"
                   using \<open>(\<not> j < dim_row A \<or> f j = dim_col A) \<and> (\<not> Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A)) < dim_row A \<or> f (Suc (nn j k (\<lambda>n. n < dim_row A \<and> f n \<noteq> dim_col A))) = dim_col A)\<close> by linarith
                 then have "\<not> (k < dim_row A \<and> f k \<noteq> dim_col A)"
                   by (metis (mono_tags, lifting) a2 bad_asm f5 le_less)
                 then show ?thesis
                   by meson
               qed }
             ultimately show "f k = dim_col A"
               using f3 a2 by (metis (lifting) Suc_lessD bad_asm)
           qed
           then show "False" using lt_i not_i
             using j_leq by blast 
         qed
         have "f i \<noteq> ?nc \<longrightarrow> ({0..<?ip} \<subseteq> {y. y < ?nr \<and> f y \<noteq> dim_col A})"
         proof -
           have h1: "f i \<noteq> dim_col A \<longrightarrow> (\<forall>j\<le>i. j < ?nr \<and> f j \<noteq> dim_col A)"
             using if_then_bad lt_i by auto
           then show ?thesis by auto
         qed
         then have gteq: "f i \<noteq> ?nc \<longrightarrow> (card {i. i < ?nr \<and> f i \<noteq> dim_col A} \<ge> (i+1))"
           using card_lessThan[of ?ip] card_mono[where B = "{i. i < ?nr \<and> f i \<noteq> dim_col A} ", where A = "{0..<?ip}"]
           by auto
         then have clear: "dim_row (take_rows A [0..<length (pivot_positions A)]) = length (pivot_positions A)"
           unfolding take_rows_def using dim_asm fileq by (auto)
         have "i + 1 > length (pivot_positions A)" using not_lt clear by auto
         then show "f i = ?nc" using gteq len_pp_var by auto
       qed
       show ?thesis using half1 half2
         by blast 
     qed
     then have h1a: "row A i =  0\<^sub>v (dim_col A)" 
       using pivot_fun_zero_row_iff[of A _ ?nc ?nr]
       using lt_i by blast
     then have h1: "A $$ (i, j) = 0"
       using index_row(1) lt_i lt_j by fastforce 
     have h2a: "i - dim_row (take_rows A [0..<length (pivot_positions A)]) < dim_row A - length (pivot_positions A)"
       using pivot_len lt_i not_lt
       by (simp add: take_rows_def)
     then have h2: "0\<^sub>m (dim_row A - length (pivot_positions A)) (dim_col A) $$
            (i - dim_row (take_rows A [0..<length (pivot_positions A)]), j) = 0 " 
       unfolding zero_mat_def using pivot_len lt_i lt_j
       using index_mat(1) by blast 
     then show "0\<^sub>m (dim_row A - length (pivot_positions A)) (dim_col A) $$
            (i - dim_row (take_rows A [0..<length (pivot_positions A)]), j) =
            A $$ (i, j)" using h1 h2
       by simp 
   qed
   have h3: "(dim_row (take_rows A [0..<length (pivot_positions A)])::nat) + ((dim_row A::nat) - (length (pivot_positions A)::nat)) =
     dim_row A"
   proof - 
     have h0: "dim_row (take_rows A [0..<length (pivot_positions A)]) = (length (pivot_positions A)::nat)" 
       by (simp add: take_rows_def fileq)
     then show ?thesis using add_diff_inverse_nat  pivot_len
       by linarith
   qed
   have h4: " \<And>i j. i < dim_row A \<Longrightarrow>
            j < dim_col A \<Longrightarrow>
            i < dim_row (take_rows A [0..<length (pivot_positions A)]) +
                (dim_row A - length (pivot_positions A))"
     using pivot_len
     by (simp add: h3) 
   then show ?thesis apply (subst mat_eq_iff)
     using h1 h2 h3 h4 by (auto simp add: append_rows_def)
 qed
 
 lemma length_pivot_positions_dim_row:
   assumes "row_echelon_form A"
   shows "length (pivot_positions A) \<le> dim_row A"
 proof -
   have 1: "A \<in> carrier_mat (dim_row A) (dim_col A)" by auto
   obtain f where 2: "pivot_fun A f (dim_col A)"
     using assms row_echelon_form_def by blast
   from pivot_positions(4)[OF 1 2] have
     "length (pivot_positions A) = card {i. i < dim_row A \<and> row A i \<noteq> 0\<^sub>v (dim_col A)}" .
   also have "... \<le> card {i. i < dim_row A}"
     apply (rule card_mono)
     by auto
   ultimately show ?thesis by auto
 qed
 
 lemma rref_pivot_positions:
   assumes "row_echelon_form R"
   assumes R: "R \<in> carrier_mat nr nc"
   shows "\<And>i j. (i,j) \<in> set (pivot_positions R) \<Longrightarrow> i < nr \<and> j < nc"
 proof -
   obtain f where f: "pivot_fun R f nc"
     using assms(1) assms(2) row_echelon_form_def by blast
   have *: "\<And>i. i < nr \<Longrightarrow> f i \<le> nc" using f
     using R pivot_funD(1) by blast
   from pivot_positions[OF R f]
   have "set (pivot_positions R) = {(i, f i) |i. i < nr \<and> f i \<noteq> nc}" by auto
   then have **: "set (pivot_positions R) = {(i, f i) |i. i < nr \<and> f i < nc}"
     using *
     by fastforce
   fix i j
   assume "(i, j) \<in> set (pivot_positions R)"
   thus "i < nr \<and> j < nc" using **
     by simp
 qed
 
 lemma pivot_fun_monoton: 
   assumes pf: "pivot_fun A f (dim_col A)"
   assumes dr: "dim_row A = nr"
   shows "\<And> i. i < nr \<Longrightarrow> (\<And> k. ((k < nr \<and> i < k) \<longrightarrow> f i \<le> f k))"
 proof -
   fix i
   assume "i < nr"
   show "(\<And> k. ((k < nr \<and> i < k) \<longrightarrow> f i \<le> f k))"
   proof -
     fix k
     show "((k < nr \<and> i < k) \<longrightarrow> f i \<le> f k)"
     proof (induct k)
       case 0
       then show ?case
         by blast 
     next
       case (Suc k)
       then show ?case 
         by (smt (verit, ccfv_SIG) dr le_less_trans less_Suc_eq less_imp_le_nat pf pivot_funD(1) pivot_funD(3))
     qed
   qed
 qed
 
 lemma pivot_positions_contains:
   assumes row_ech: "row_echelon_form A"
   assumes dim_h: "dim_col A \<ge> dim_row A"
   assumes "pivot_fun A f (dim_col A)"
   shows "\<forall>i < (length (pivot_positions A)). (i, f i) \<in> set (pivot_positions A)"
 proof - 
   let ?nr = "dim_row A"
   let ?nc = "dim_col A"
   let ?pp = "pivot_positions A"          
   have i_nr: "\<forall>i < (length ?pp). i < ?nr" using rref_pivot_positions assms
     using length_pivot_positions_dim_row less_le_trans by blast 
   have i_nc: "\<forall>i < (length ?pp). f i < ?nc"
   proof clarsimp 
     fix i
     assume i_lt: "i < length ?pp"
     have fis_nc: "f i = ?nc \<Longrightarrow> (\<forall> k > i. k < ?nr \<longrightarrow> f k = ?nc)"
     proof -
       assume is_nc: "f i = ?nc"
       show "(\<forall> k > i. k < ?nr \<longrightarrow> f k = ?nc)" 
       proof clarsimp
         fix k
         assume k_gt: "k > i"
         assume k_lt: "k < ?nr"
         have fk_lt: "f k \<le> ?nc" using pivot_funD(1)[of A ?nr f ?nc k] k_lt apply (auto)
           using \<open>pivot_fun A f (dim_col A)\<close> by blast 
         show "f k = ?nc"
           using fk_lt is_nc k_gt k_lt assms pivot_fun_monoton[of A f ?nr i k]
           using \<open>pivot_fun A f (dim_col A)\<close> by auto 
       qed
     qed
     have ncimp: "f i = ?nc \<Longrightarrow> (\<forall> k \<ge>i. k \<notin> { i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc})"
     proof -
       assume nchyp: "f i = ?nc"
       show "(\<forall> k \<ge>i. k \<notin> { i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc})"
       proof clarsimp 
         fix k
         assume i_lt: "i \<le> k" 
         assume k_lt: "k < dim_row A"
         show "row A k = 0\<^sub>v (dim_col A) "
           using i_lt k_lt fis_nc
           using pivot_fun_zero_row_iff[of A f ?nc ?nr]
           using \<open>pivot_fun A f (dim_col A)\<close> le_neq_implies_less nchyp by blast 
       qed
     qed
     then have "f i = ?nc \<Longrightarrow> card { i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc} \<le> i"
     proof - 
       assume nchyp: "f i = ?nc"
       have h: "{ i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc} \<subseteq> {0..<i}"
         using atLeast0LessThan le_less_linear nchyp ncimp by blast
       then show " card { i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc} \<le> i"
         using card_lessThan
         using subset_eq_atLeast0_lessThan_card by blast 
     qed
     then show "f i < ?nc" using i_lt pivot_positions(4)[of A ?nr ?nc f]
       apply (auto)
       by (metis \<open>pivot_fun A f (dim_col A)\<close> i_nr le_neq_implies_less not_less pivot_funD(1)) 
   qed
   then show ?thesis
     using pivot_positions(1)
     by (smt (verit, ccfv_SIG) \<open>pivot_fun A f (dim_col A)\<close> carrier_matI i_nr less_not_refl mem_Collect_eq)
 qed
 
 lemma pivot_positions_form_helper_1:
   shows "(a, b) \<in> set (pivot_positions_main_gen z A nr nc i j) \<Longrightarrow> i \<le> a"
 proof  (induct i j rule: pivot_positions_main_gen.induct[of nr nc A z])
   case (1 i j)
   then show ?case using  pivot_positions_main_gen.simps[of z A nr nc i j]
     by (metis Pair_inject Suc_leD emptyE list.set(1) nle_le set_ConsD)
 qed
 
 lemma pivot_positions_form_helper_2:
   shows "sorted_wrt (<) (map fst (pivot_positions_main_gen z A nr nc i j))"
 proof  (induct i j rule: pivot_positions_main_gen.induct[of nr nc A z])
   case (1 i j)
   then show ?case using  pivot_positions_main_gen.simps[of z A nr nc i j] 
     by (auto simp: pivot_positions_form_helper_1 Suc_le_lessD) 
 qed
 
 lemma sorted_pivot_positions:
   shows "sorted_wrt (<) (map fst (pivot_positions A))"
   using pivot_positions_form_helper_2
   by (simp add: pivot_positions_form_helper_2 pivot_positions_gen_def) 
 
 lemma pivot_positions_form:
   assumes row_ech: "row_echelon_form A"
   assumes dim_h: "dim_col A \<ge> dim_row A"
   shows "\<forall> i < (length (pivot_positions A)). fst ((pivot_positions A) ! i) = i"
 proof clarsimp 
   let ?nr = "dim_row A"
   let ?nc = "dim_col A"
   let ?pp = "pivot_positions A :: (nat \<times> nat) list"
   fix i
   assume i_lt: "i < length (pivot_positions A)"
   have "\<exists>f. pivot_fun A f ?nc" using row_ech unfolding row_echelon_form_def
     by blast
   then obtain f where pf:"pivot_fun A f ?nc"
     by blast                  
   have all_f_in: "\<forall>i < (length ?pp). (i, f i) \<in> set ?pp"
     using pivot_positions_contains pf
       assms 
     by blast   
   have sorted_hyp: "\<And> (p::nat) (q::nat). p < (length ?pp) \<Longrightarrow> q < (length ?pp) \<Longrightarrow> p < q \<Longrightarrow> (fst (?pp ! p) < fst (?pp ! q))"
   proof -
     fix p::nat
     fix q::nat
     assume p_lt: "p < q"
     assume p_welldef: "p < (length ?pp)"
     assume q_welldef: "q < (length ?pp)"
     show "fst (?pp ! p) < fst (?pp ! q)"
       using sorted_pivot_positions p_lt p_welldef q_welldef sorted_wrt_nth_less by fastforce
   qed
   have h: "i < (length ?pp) \<longrightarrow> fst (pivot_positions A ! i) = i"
   proof (induct i)
     case 0
     have "\<exists>j. fst (pivot_positions A ! j) = 0"
       by (metis all_f_in fst_conv i_lt in_set_conv_nth length_greater_0_conv list.size(3) not_less0)
     then obtain j where jth:" fst (pivot_positions A ! j) = 0"
       by blast      
     have "j \<noteq> 0 \<longrightarrow> (fst (pivot_positions A ! 0) > 0 \<longrightarrow> j \<le> 0)"
       by (smt (verit, ccfv_SIG) all_f_in fst_conv i_lt in_set_conv_nth less_nat_zero_code not_gr_zero sorted_hyp)
     then show ?case
       using jth neq0_conv by blast
   next
     case (Suc i)
     have ind_h: "i < length (pivot_positions A) \<longrightarrow> fst (pivot_positions A ! i) = i"
       using Suc.hyps by blast 
     have thesis_h: "(Suc i) < length (pivot_positions A) \<Longrightarrow> fst (pivot_positions A ! (Suc i)) = (Suc i)"
     proof - 
       assume suc_i_lt: "(Suc i) < length (pivot_positions A)"
       have fst_i_is: "fst (pivot_positions A ! i) = i" using suc_i_lt ind_h
         using Suc_lessD by blast 
       have "(\<exists>j < (length ?pp). fst (pivot_positions A ! j) = (Suc i))"
         by (metis suc_i_lt all_f_in fst_conv  in_set_conv_nth)
       then obtain j where jth: "j < (length ?pp) \<and> fst (pivot_positions A ! j) = (Suc i)"
         by blast
       have "j > i"
         using sorted_hyp apply (auto)
         by (metis Suc_lessD \<open>fst (pivot_positions A ! i) = i\<close> jth less_not_refl linorder_neqE_nat n_not_Suc_n suc_i_lt)
       have "j > (Suc i) \<Longrightarrow> False"
       proof -
         assume j_gt: "j > (Suc i)"
         then have h1: "fst (pivot_positions A ! (Suc i)) > i"
           using fst_i_is sorted_pivot_positions
           using sorted_hyp suc_i_lt by force
         have "fst (pivot_positions A ! j) > fst (pivot_positions A ! (Suc i))"
           using jth j_gt sorted_hyp apply (auto)
           by fastforce 
         then have h2: "fst (pivot_positions A ! (Suc i)) < (Suc i)" 
           using jth
           by simp   
         show "False" using h1 h2
           using not_less_eq by blast 
       qed
       show "fst (pivot_positions A ! (Suc i)) = (Suc i)"
         using Suc_lessI \<open>Suc i < j \<Longrightarrow> False\<close> \<open>i < j\<close> jth by blast
     qed
     then show ?case
       by blast 
   qed
   then show "fst (pivot_positions A ! i) = i"
     using i_lt by auto
 qed
 
 lemma take_cols_pivot_eq:
   assumes row_ech: "row_echelon_form A"
   assumes dim_h: "dim_col A \<ge> dim_row A"
   shows "take_cols A (map snd (pivot_positions A)) =
     1\<^sub>m (length (pivot_positions A)) @\<^sub>r
     0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))"
 proof - 
   let ?nr = "dim_row A"
   let ?nc = "dim_col A"
   have h1: " dim_col
      (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
       0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))) = (length (pivot_positions A))"
     by (simp add: append_rows_def)
   have len_pivot: "length (pivot_positions A) = card {i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc}"
     using row_ech pivot_positions(4) row_echelon_form_def by blast
   have pp_leq_nc: "\<forall>f. pivot_fun A f ?nc \<longrightarrow> (\<forall>i < ?nr. f i \<le> ?nc)" unfolding pivot_fun_def
     by meson 
   have pivot_set: "\<exists>f. pivot_fun A f ?nc \<and> set (pivot_positions A) = {(i, f i) | i. i < ?nr \<and> f i \<noteq> ?nc}"
     using row_ech row_echelon_form_def pivot_positions(1)
     by (smt (verit) Collect_cong carrier_matI)
   then have pivot_set_alt: "\<exists>f. pivot_fun A f ?nc \<and> set (pivot_positions A) = {(i, f i) | i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc}"
     using pivot_positions pivot_fun_zero_row_iff Collect_cong carrier_mat_triv
     by (smt (verit, best))
   have "\<exists>f. pivot_fun A f ?nc \<and> set (pivot_positions A) = {(i, f i) | i. f i \<le> ?nc \<and> i < ?nr \<and> f i \<noteq> ?nc}"
     using pivot_set pp_leq_nc by auto
   then have pivot_set_var: "\<exists>f. pivot_fun A f ?nc \<and> set (pivot_positions A) = {(i, f i) | i. i < ?nr \<and> f i < ?nc}"
     by auto
   have "length (map snd (pivot_positions A)) = card (set (map snd (pivot_positions A)))" 
     using row_ech row_echelon_form_def pivot_positions(3) distinct_card[where xs = "map snd (pivot_positions A)"]
     by (metis carrier_mat_triv)
   then have "length (map snd (pivot_positions A)) = card (set (pivot_positions A))"
     by (metis card_distinct distinct_card distinct_map length_map) 
   then have "length (map snd (pivot_positions A)) = card {i. i < ?nr \<and> row A i \<noteq> 0\<^sub>v ?nc}"
     using pivot_set_alt
     by (simp add: len_pivot) 
   then have length_asm: "length (map snd (pivot_positions A)) = length (pivot_positions A)"
     using len_pivot by linarith
   then have "\<forall>a. List.member (map snd (pivot_positions A)) a \<longrightarrow> a < dim_col A"
   proof clarsimp 
     fix a
     assume a_in: "List.member (map snd (pivot_positions A)) a"
     have "\<exists>v \<in> set (pivot_positions A). a = snd v" 
       using a_in in_set_member[where xs = "(pivot_positions A)"] apply (auto)
       by (metis in_set_impl_in_set_zip2 in_set_member length_map snd_conv zip_map_fst_snd) 
     then show "a < dim_col A"
       using pivot_set_var in_set_member by auto
   qed
   then have h2b: "(filter (\<lambda>y. y < dim_col A) (map snd (pivot_positions A))) =  (map snd (pivot_positions A))"
     by (meson filter_True in_set_member)
   then have h2a: "length (map ((!) (cols A)) (filter (\<lambda>y. y < dim_col A) (map snd (pivot_positions A)))) = length (pivot_positions A)"
     using length_asm
     by (simp add: h2b) 
   then have h2: "length (pivot_positions A) \<le> dim_row A \<Longrightarrow>
     dim_col (take_cols A (map snd (pivot_positions A))) = (length (pivot_positions A))" 
     unfolding take_cols_def using mat_of_cols_carrier by auto
   have h_len: "length (pivot_positions A) \<le> dim_row A \<Longrightarrow>
     dim_col (take_cols A (map snd (pivot_positions A))) =
     dim_col
      (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
       0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A)))" 
     using h1 h2
     by (simp add: h1 assms length_pivot_positions_dim_row)
   have h2: "\<And>i j. length (pivot_positions A) \<le> dim_row A \<Longrightarrow>
            i < dim_row A \<Longrightarrow>
            j < dim_col
                 (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
                  0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))) \<Longrightarrow>
            take_cols A (map snd (pivot_positions A)) $$ (i, j) =
            (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
             0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))) $$
            (i, j)" 
   proof -
     fix i 
     fix j 
     let ?pp = "(pivot_positions A)"
     assume len_lt: "length (pivot_positions A) \<le> dim_row A" 
     assume i_lt: " i < dim_row A" 
     assume j_lt: "j < dim_col
                 (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
                  0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A)))"
     let ?w = "((map snd (pivot_positions A)) ! j)"
     have breaking_it_down: "mat_of_cols (dim_row A)
      (map ((!) (cols A)) (map snd (pivot_positions A))) $$ (i, j)  
      =  ((cols A) ! ?w) $ i"
       apply (auto)
       by (metis comp_apply h1 i_lt j_lt length_map mat_of_cols_index nth_map) 
     have h1a: "i < (length ?pp) \<Longrightarrow> (mat_of_cols (dim_row A) (map ((!) (cols A)) (map snd (pivot_positions A))) $$ (i, j) 
         = (1\<^sub>m (length (pivot_positions A))) $$ (i, j))"
     proof - 
       (* need to, using row_ech, rely heavily on pivot_fun_def, that num_cols \<ge> num_rows, and row_echelon form*)
       assume "i < (length ?pp)"
       have "\<exists>f. pivot_fun A f ?nc" using row_ech unfolding row_echelon_form_def
         by blast
       then obtain f where "pivot_fun A f ?nc"
         by blast
       have j_nc: "j < (length ?pp)" using j_lt
         by (simp add: h1) 
       then have j_lt_nr: "j < ?nr" using dim_h
         using len_lt by linarith 
       then have is_this_true: "(pivot_positions A) ! j = (j, f j)" 
         using pivot_positions_form pivot_positions(1)[of A ?nr ?nc f]
       proof -
         have "pivot_positions A ! j \<in> set (pivot_positions A)"
           using j_nc nth_mem by blast
         then have "\<exists>n. pivot_positions A ! j = (n, f n) \<and> n < dim_row A \<and> f n \<noteq> dim_col A"
           using \<open>\<lbrakk>A \<in> carrier_mat (dim_row A) (dim_col A); pivot_fun A f (dim_col A)\<rbrakk> \<Longrightarrow> set (pivot_positions A) = {(i, f i) |i. i < dim_row A \<and> f i \<noteq> dim_col A}\<close> \<open>pivot_fun A f (dim_col A)\<close> by blast
         then show ?thesis
           by (metis (no_types) \<open>\<And>A. \<lbrakk>row_echelon_form A; dim_row A \<le> dim_col A\<rbrakk> \<Longrightarrow> \<forall>i<length (pivot_positions A). fst (pivot_positions A ! i) = i\<close> dim_h fst_conv j_nc row_ech)
       qed
       then have w_is: "?w = f j"
         by (metis h1 j_lt nth_map snd_conv)
       have h0: "i = j \<longrightarrow> ((cols A) ! ?w) $ i = 1" using w_is pivot_funD(4)[of A ?nr f ?nc i]
         by (metis \<open>\<forall>a. List.member (map snd (pivot_positions A)) a \<longrightarrow> a < dim_col A\<close> \<open>i < length (pivot_positions A)\<close> \<open>pivot_fun A f (dim_col A)\<close> cols_length i_lt in_set_member length_asm mat_of_cols_cols mat_of_cols_index nth_mem)
       have h1:  "i \<noteq> j \<longrightarrow> ((cols A) ! ?w) $ i = 0" using w_is pivot_funD(5)
         by (metis \<open>\<forall>a. List.member (map snd (pivot_positions A)) a \<longrightarrow> a < dim_col A\<close> \<open>pivot_fun A f (dim_col A)\<close> cols_length h1 i_lt in_set_member j_lt len_lt length_asm less_le_trans mat_of_cols_cols mat_of_cols_index nth_mem)
       show "(mat_of_cols (dim_row A) (map ((!) (cols A)) (map snd (pivot_positions A))) $$ (i, j) 
         = (1\<^sub>m (length (pivot_positions A))) $$ (i, j))" using h0 h1 breaking_it_down
         by (metis \<open>i < length (pivot_positions A)\<close> h2 h_len index_one_mat(1) j_lt len_lt) 
     qed
     have h1b: "i \<ge> (length ?pp) \<Longrightarrow> (mat_of_cols (dim_row A) (map ((!) (cols A)) (map snd (pivot_positions A))) $$ (i, j)  = 0)"
     proof - 
       assume i_gt: "i \<ge> (length ?pp)"
       have h0a: "((cols A) ! ((map snd (pivot_positions A)) ! j)) $ i = (row A i) $ ?w"
         by (metis \<open>\<forall>a. List.member (map snd (pivot_positions A)) a \<longrightarrow> a < dim_col A\<close> cols_length h1 i_lt in_set_member index_row(1) j_lt length_asm mat_of_cols_cols mat_of_cols_index nth_mem)
       have h0b: 
         "take_rows A [0..<length (pivot_positions A)] @\<^sub>r 0\<^sub>m (dim_row A - length (pivot_positions A)) (dim_col A) = A"
         using assms row_echelon_form_zero_rows[of A]
         by blast 
       then have h0c: "(row A i) = 0\<^sub>v (dim_col A)"  using i_gt
         by (smt (verit, best) add_diff_cancel_left' add_diff_cancel_right' add_less_cancel_left dim_col_take_rows 
             dim_row_append_rows i_lt index_zero_mat(2) index_zero_mat(3) le_Suc_ex len_lt nat_less_le nle_le row_append_rows row_zero)
       then show ?thesis using h0a breaking_it_down apply (auto)
         by (metis \<open>\<forall>a. List.member (map snd (pivot_positions A)) a \<longrightarrow> a < dim_col A\<close> h1 in_set_member index_zero_vec(1) j_lt length_asm nth_mem) 
     qed
     have h1: " mat_of_cols (dim_row A)
      (map ((!) (cols A)) (map snd (pivot_positions A))) $$ (i, j) =
            (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
             0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))) $$
            (i, j) " using h1a h1b
       by (smt (verit) add_diff_inverse_nat append_rows_index diff_less_mono h1 i_lt index_one_mat(2) index_one_mat(3) index_zero_mat(1) index_zero_mat(2) index_zero_mat(3) j_lt leD len_lt not_le_imp_less)
     then show "take_cols A (map snd (pivot_positions A)) $$ (i, j) =
            (1\<^sub>m (length (pivot_positions A)) @\<^sub>r
             0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))) $$
            (i, j)" 
       unfolding take_cols_def
       by (simp add: h2b)
   qed
   show ?thesis
     unfolding mat_eq_iff
     using length_pivot_positions_dim_row[OF assms(1)] h_len h2 by auto
 qed
 
 lemma rref_right_mul:
   assumes "row_echelon_form A"
   assumes "dim_col A \<ge> dim_row A"
   shows
     "take_cols A (map snd (pivot_positions A)) * take_rows A [0..<length (pivot_positions A)] = A"
 proof -
   from take_cols_pivot_eq[OF assms] have
     1: "take_cols A (map snd (pivot_positions A)) =
     1\<^sub>m (length (pivot_positions A)) @\<^sub>r
     0\<^sub>m (dim_row A - length (pivot_positions A)) (length (pivot_positions A))" .
   have 2: "take_cols A (map snd (pivot_positions A)) * take_rows A [0..<length (pivot_positions A)] =
     take_rows A [0..<length (pivot_positions A)]  @\<^sub>r 0\<^sub>m (dim_row A - length (pivot_positions A)) (dim_col A)"
     unfolding 1
     apply (simp add: append_rows_mat_mul)
     by (metis (no_types, lifting) "1" add_right_imp_eq assms dim_col_take_rows dim_row_append_rows dim_row_take_cols index_one_mat(2) index_zero_mat(2) left_mult_one_mat' left_mult_zero_mat' row_echelon_form_zero_rows)
   from row_echelon_form_zero_rows[OF assms] have "... = A" .
   thus ?thesis
     by (simp add: "2")
 qed
 
 context conjugatable_vec_space begin
 
 lemma lin_indpt_id:
   shows "lin_indpt (set (cols (1\<^sub>m n)::'a vec list))"
 proof -
   have *: "set (cols (1\<^sub>m n)) = set (rows (1\<^sub>m n))"
     by (metis cols_transpose transpose_one)
   have "det (1\<^sub>m n) \<noteq> 0" using det_one by auto
   from det_not_0_imp_lin_indpt_rows[OF _ this]
   have "lin_indpt (set (rows (1\<^sub>m n)))"
     using one_carrier_mat by blast
   thus ?thesis
     by (simp add: *) 
 qed
 
 lemma lin_indpt_take_cols_id:
   shows "lin_indpt (set (cols (take_cols (1\<^sub>m n) inds)))"
 proof - 
   have subset_h: "set (cols (take_cols (1\<^sub>m n) inds)) \<subseteq> set (cols (1\<^sub>m n)::'a vec list)"
     using cols_take_cols_subset by blast
   then show ?thesis using lin_indpt_id subset_li_is_li by auto
 qed
 
 lemma cols_id_unit_vecs:
   shows "cols (1\<^sub>m d) = unit_vecs d"
   unfolding unit_vecs_def list_eq_iff_nth_eq
   by auto
 
 lemma distinct_cols_id:
   shows "distinct (cols (1\<^sub>m d)::'a vec list)"
   by (simp add: conjugatable_vec_space.cols_id_unit_vecs vec_space.unit_vecs_distinct)
 
 lemma distinct_map_nth:
   assumes "distinct ls"
   assumes "distinct inds"
   assumes "\<And>j. j \<in> set inds \<Longrightarrow> j < length ls"
   shows "distinct (map ((!) ls) inds)"
   by (simp add: assms(1) assms(2) assms(3) distinct_map inj_on_nth)
 
 lemma distinct_take_cols_id:
   assumes "distinct inds"
   shows "distinct (cols (take_cols (1\<^sub>m n) inds) :: 'a vec list)"
   unfolding take_cols_def
   apply (subst cols_mat_of_cols)
    apply (auto intro!:  distinct_map_nth simp add: distinct_cols_id)
   using assms distinct_filter by blast
 
 lemma rank_take_cols:
   assumes "distinct inds"
   shows "rank (take_cols (1\<^sub>m n) inds) = length (filter ((>) n) inds)"
   apply (subst lin_indpt_full_rank[of _ "length (filter ((>) n) inds)"])
      apply (auto simp add: lin_indpt_take_cols_id)
    apply (metis (full_types) index_one_mat(2) index_one_mat(3) length_map mat_of_cols_carrier(1) take_cols_def)
   by (simp add: assms distinct_take_cols_id)
 
 lemma rank_mul_left_invertible_mat:
   fixes A::"'a mat"
   assumes "invertible_mat A"
   assumes "A \<in> carrier_mat n n"
   assumes "B \<in> carrier_mat n nc"
   shows "rank (A * B) = rank B"
 proof -
   obtain C where C: "inverts_mat A C" "inverts_mat C A"
     using assms invertible_mat_def by blast 
   from C have ceq: "C * A = 1\<^sub>m n"
     by (metis assms(2) carrier_matD(2) index_mult_mat(3) index_one_mat(3) inverts_mat_def)
   then have *:"B = C*A*B"
     using assms(3) by auto
   from rank_mat_mul_left[OF assms(2-3)]
   have **: "rank (A*B) \<le> rank B" .
   have 1: "C \<in> carrier_mat n n" using C ceq
     by (metis assms(2) carrier_matD(1) carrier_matI index_mult_mat(3) index_one_mat(3) inverts_mat_def) 
   have 2: "A * B \<in> carrier_mat n nc" using assms by auto  
   have "rank B = rank (C* A * B)" using * by auto
   also have "... \<le> rank (A*B)" using rank_mat_mul_left[OF 1 2]
     using "1" assms(2) assms(3) by auto
   ultimately show ?thesis using ** by auto
 qed
 
 lemma invertible_take_cols_rank:
   fixes A::"'a mat"
   assumes "invertible_mat A"
   assumes "A \<in> carrier_mat n n"
   assumes "distinct inds"
   shows "rank (take_cols A inds) = length (filter ((>) n) inds)"
 proof -
   have " A = A * 1\<^sub>m n" using assms(2) by auto
   then have "take_cols A inds = A * take_cols (1\<^sub>m n) inds"
     by (metis assms(2) one_carrier_mat take_cols_mat_mul)
   then have "rank (take_cols A inds) = rank (take_cols (1\<^sub>m n) inds)"
     by (metis assms(1) assms(2) conjugatable_vec_space.rank_mul_left_invertible_mat one_carrier_mat take_cols_carrier_mat)
   thus ?thesis
     by (simp add: assms(3) conjugatable_vec_space.rank_take_cols)
 qed
 
 lemma rank_take_cols_leq:
   assumes R:"R \<in> carrier_mat n nc"
   shows "rank (take_cols R ls) \<le> rank R"
 proof -
   from take_cols_mat_mul[OF R]
   have "take_cols R ls =  R * take_cols (1\<^sub>m nc) ls"
     by (metis assms one_carrier_mat right_mult_one_mat)
   thus ?thesis
     by (metis assms one_carrier_mat take_cols_carrier_mat vec_space.rank_mat_mul_right)
 qed
 
 lemma rank_take_cols_geq:
   assumes R:"R \<in> carrier_mat n nc"
   assumes t:"take_cols R ls \<in> carrier_mat n r"
   assumes B:"B \<in> carrier_mat r nc"
   assumes "R = (take_cols R ls) * B"
   shows "rank (take_cols R ls) \<ge> rank R"
   by (metis B assms(4) t vec_space.rank_mat_mul_right)
 
 lemma rref_drop_pivots:
   assumes row_ech: "row_echelon_form R"
   assumes dims: "R \<in> carrier_mat n nc"
   assumes order: "nc \<ge> n"
   shows "rank (take_cols R (map snd (pivot_positions R))) = rank R"
 proof -
   let ?B = "take_rows R [0..<length (pivot_positions R)]"
   have equa: "R = take_cols R (map snd (pivot_positions R)) * ?B" using assms rref_right_mul
     by (metis carrier_matD(1) carrier_matD(2))
   have ex_r: "\<exists>r. take_cols R (map snd (pivot_positions R)) \<in> carrier_mat n r \<and> ?B \<in> carrier_mat r nc"
   proof - 
     have h1:
       "take_cols R (map snd (pivot_positions R)) \<in> carrier_mat n (length (pivot_positions R))"
       using assms
       by (metis in_set_impl_in_set_zip2 length_map rref_pivot_positions take_cols_carrier_mat_strict zip_map_fst_snd)
     have "\<exists> f. pivot_fun R f nc" using row_ech unfolding row_echelon_form_def using dims
       by blast
     then have "length (pivot_positions R) = card {i. i < n \<and> row R i \<noteq> 0\<^sub>v nc}"
       using pivot_positions[of R n nc]
       using dims by auto 
     then have "nc \<ge> length (pivot_positions R)" using order
       using carrier_matD(1) dims dual_order.trans length_pivot_positions_dim_row row_ech by blast
     then have "dim_col R \<ge> length (pivot_positions R)" using dims by auto
     then have h2: "?B \<in> carrier_mat (length (pivot_positions R)) nc" unfolding take_rows_def
       using dims 
       by (smt (verit) atLeastLessThan_iff carrier_matD(2) filter_True le_eq_less_or_eq length_map 
           length_pivot_positions_dim_row less_trans map_nth mat_of_cols_carrier(1) row_ech set_upt transpose_carrier_mat transpose_mat_of_rows) 
     show ?thesis using h1 h2
       by blast
   qed
     (* prove the other two dimensionality assumptions *)
   have "rank R  \<le> rank (take_cols R (map snd (pivot_positions R)))"
     using dims ex_r rank_take_cols_geq[where R = "R", where B = "?B", where ls = "(map snd (pivot_positions R))", where nc = "nc"]
     using equa by blast
   thus ?thesis
     using assms(2) conjugatable_vec_space.rank_take_cols_leq le_antisym by blast
 qed
 
 lemma gjs_and_take_cols_var:
   fixes A::"'a mat"
   assumes A:"A \<in> carrier_mat n nc"
   assumes order: "nc \<ge> n"
   shows "(take_cols A (map snd (pivot_positions (gauss_jordan_single A)))) = 
   (take_cols_var A (map snd (pivot_positions (gauss_jordan_single A))))"
 proof -
   let ?gjs = "(gauss_jordan_single A)"
   have "\<forall>x. List.member (map snd (pivot_positions (gauss_jordan_single A))) x \<longrightarrow> x \<le> dim_col A"  
     using rref_pivot_positions gauss_jordan_single(3) carrier_matD(2) gauss_jordan_single(2) in_set_impl_in_set_zip2 in_set_member length_map less_irrefl less_trans not_le_imp_less zip_map_fst_snd
     by (metis (no_types, lifting) carrier_mat_triv)
   then have "(filter (\<lambda>y. y < dim_col A) (map snd (pivot_positions (gauss_jordan_single A)))) = 
     (map snd (pivot_positions (gauss_jordan_single A)))"
     by (metis (no_types, lifting) A carrier_matD(2) filter_True gauss_jordan_single(2) gauss_jordan_single(3) in_set_impl_in_set_zip2 length_map rref_pivot_positions zip_map_fst_snd)
   then show ?thesis unfolding take_cols_def take_cols_var_def
     by simp
 qed
 
 lemma gauss_jordan_single_rank:
   fixes A::"'a mat"
   assumes A:"A \<in> carrier_mat n nc"
   assumes order: "nc \<ge> n"
   shows "rank (take_cols A (map snd (pivot_positions (gauss_jordan_single A)))) = rank A"
 proof -
   let ?R = "gauss_jordan_single A"
   obtain P where P:"P\<in>Units (ring_mat TYPE('a) n undefined)" and
     i: "?R = P * A" using gauss_jordan_transform[OF A]
     by (metis A carrier_matD(1) fst_eqD gauss_jordan_single_def surj_pair zero_carrier_mat)
   have pcarrier: "P \<in> carrier_mat n n" using P unfolding Units_def
     by (auto simp add: ring_mat_def)
   have "invertible_mat P" using P unfolding invertible_mat_def Units_def inverts_mat_def
     apply auto
      apply (simp add: ring_mat_simps(5))
     by (metis index_mult_mat(2) index_one_mat(2) ring_mat_simps(1) ring_mat_simps(3))
   then
   obtain Pi where Pi: "invertible_mat Pi" "Pi * P = 1\<^sub>m n"
   proof -
     assume a1: "\<And>Pi. \<lbrakk>invertible_mat Pi; Pi * P = 1\<^sub>m n\<rbrakk> \<Longrightarrow> thesis"
     have "dim_row P = n"
       by (metis (no_types) A assms(1) carrier_matD(1) gauss_jordan_single(2) i index_mult_mat(2))
     then show ?thesis
       using a1 by (metis (no_types) \<open>invertible_mat P\<close> index_mult_mat(3) index_one_mat(3) invertible_mat_def inverts_mat_def square_mat.simps)
   qed
   then have pi_carrier:"Pi \<in> carrier_mat n n"
     by (metis carrier_mat_triv index_mult_mat(2) index_one_mat(2) invertible_mat_def square_mat.simps)
   have R1:"row_echelon_form ?R"
     using assms(2) gauss_jordan_single(3) by blast
   have R2: "?R \<in> carrier_mat n nc"
     using A assms(2) gauss_jordan_single(2) by auto
   have Rcm: "take_cols ?R (map snd (pivot_positions ?R))
     \<in> carrier_mat n (length (map snd (pivot_positions ?R)))"
     apply (rule take_cols_carrier_mat_strict[OF R2])
     using rref_pivot_positions[OF R1 R2] by auto
   have "Pi * ?R = A" using i Pi
     by (smt (verit, best) A assoc_mult_mat left_mult_one_mat pcarrier pi_carrier)
   then have "rank (take_cols A (map snd (pivot_positions ?R))) = rank (take_cols (Pi * ?R) (map snd (pivot_positions ?R)))"
     by auto
   also have "... = rank ( Pi * take_cols ?R (map snd (pivot_positions ?R)))"
     by (metis A gauss_jordan_single(2) pi_carrier take_cols_mat_mul)
   also have "... = rank (take_cols ?R (map snd (pivot_positions ?R)))"
     by (intro rank_mul_left_invertible_mat[OF Pi(1) pi_carrier Rcm])
   also have "... = rank ?R"
     using assms(2) conjugatable_vec_space.rref_drop_pivots gauss_jordan_single(3)
     using R1 R2 by blast
   ultimately show ?thesis                                                            
     using A \<open>P \<in> carrier_mat n n\<close> \<open>invertible_mat P\<close> conjugatable_vec_space.rank_mul_left_invertible_mat i
     by auto
 qed
 
 lemma lin_indpt_subset_cols:
   fixes A:: "'a mat"
   fixes B:: "'a vec set"
   assumes "A \<in> carrier_mat n n"
   assumes inv: "invertible_mat A"
   assumes "B \<subseteq> set (cols A)"
   shows "lin_indpt B"
 proof -
   have "det A \<noteq> 0"
     using assms(1) inv invertible_det by blast
   then have "lin_indpt (set (rows A\<^sup>T))"
     using assms(1) idom_vec.lin_dep_cols_imp_det_0 by auto
   thus ?thesis using subset_li_is_li assms(3)
     by auto
 qed
 
 lemma rank_invertible_subset_cols:
   fixes A:: "'a mat"
   fixes B:: "'a vec list"
   assumes inv: "invertible_mat A"
   assumes A_square: "A \<in> carrier_mat n n"
   assumes set_sub: "set (B) \<subseteq> set (cols A)"
   assumes dist_B: "distinct B"
   shows "rank (mat_of_cols n B) = length B"
 proof - 
   let ?B_mat = "(mat_of_cols n B)"
   have h1: "lin_indpt (set(B))" 
     using assms lin_indpt_subset_cols[of A] by auto
   have "set B \<subseteq> carrier_vec n"
     using set_sub A_square cols_dim[of A] by auto
   then have cols_B: "cols (mat_of_cols n B) = B" using cols_mat_of_cols by auto
   then have "maximal (set B) (\<lambda>T. T \<subseteq> set (B) \<and> lin_indpt T)" using h1
     by (simp add: maximal_def subset_antisym)
   then have h2: "maximal (set B) (\<lambda>T. T \<subseteq> set (cols (mat_of_cols n B)) \<and> lin_indpt T)"
     using cols_B by auto
   have h3: "rank (mat_of_cols n B) = card (set B)"
     using h1 h2 rank_card_indpt[of ?B_mat]
     using mat_of_cols_carrier(1) by blast 
   then show ?thesis using assms distinct_card by auto
 qed
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/BenOr_Kozen_Reif/Renegar_Proofs.thy b/thys/BenOr_Kozen_Reif/Renegar_Proofs.thy
--- a/thys/BenOr_Kozen_Reif/Renegar_Proofs.thy
+++ b/thys/BenOr_Kozen_Reif/Renegar_Proofs.thy
@@ -1,2779 +1,2779 @@
 theory Renegar_Proofs
   imports Renegar_Algorithm
     BKR_Proofs
 begin
 
 (* Note that there is significant overlap between Renegar and BKR in general, so there is some
   similarity between this file and BKR_Proofs.thy
   The main difference is that the RHS vector in Renegar is different from the RHS vector in BKR 
   In BKR, all of the qs are assumed to be relatively prime to p. Renegar removes this assumption. 
   In general, the _R's on definition and lemma names in this file are to emphasize that we are 
   working with Renegar style.
 *)
 
 section "Tarski Queries Changed"
 
 lemma construct_NofI_R_relation:
   fixes p:: "real poly"
   fixes I1:: "real poly list"
   fixes I2:: "real poly list"
   shows "construct_NofI_R p I1 I2 =
     construct_NofI (sum_list (map power2 (p # I1))) I2"
   unfolding construct_NofI_R_def construct_NofI_def
   by metis
 
 lemma sum_list_map_power2:
   shows "sum_list (map power2 ls) \<ge> (0::real poly)"
   apply (induct ls)
   by auto
 
 lemma sum_list_map_power2_poly:
   shows "poly (sum_list (map power2 (ls::real poly list))) x \<ge> (0::real)"
   apply (induct ls)
   by auto
 
 lemma construct_NofI_R_prop_helper:
   fixes p:: "real poly"
   fixes I1:: "real poly list"
   fixes I2:: "real poly list"
   assumes nonzero: "p\<noteq>0"
   shows "construct_NofI_R p I1 I2 =
     rat_of_int (int (card {x. poly (sum_list (map (\<lambda>x. x^2) (p # I1))) x = 0 \<and> poly (prod_list I2) x > 0}) - 
     int (card {x. poly (sum_list (map (\<lambda>x. x^2) (p # I1))) x = 0  \<and> poly (prod_list I2) x < 0}))"
 proof -
   show ?thesis unfolding construct_NofI_R_relation[of p I1 I2]
     apply (subst construct_NofI_prop[of _ I2])
      apply auto
     using assms sum_list_map_power2
     by (metis le_add_same_cancel1 power2_less_eq_zero_iff)
 qed
 
 lemma zer_iff:
   fixes p:: "real poly"
   fixes ls:: "real poly list"
   shows "poly (sum_list (map (\<lambda>x. x^2) ls)) x = 0 \<longleftrightarrow> (\<forall>i \<in> set ls. poly i x = 0)"
 proof (induct ls)
   case Nil
   then show ?case by auto
 next
   case (Cons a I1)
   then show ?case
     apply simp
     apply (subst add_nonneg_eq_0_iff)
     using zero_le_power2 apply blast
     using sum_list_map_power2_poly apply presburger
     by simp
 qed
 
 lemma construct_NofI_prop_R:
   fixes p:: "real poly"
   fixes I1:: "real poly list"
   fixes I2:: "real poly list"
   assumes nonzero: "p\<noteq>0"
   shows "construct_NofI_R p I1 I2 =
     rat_of_int (int (card {x. poly p x = 0 \<and> (\<forall>q \<in> set I1. poly q x = 0) \<and> poly (prod_list I2) x > 0}) - 
     int (card {x. poly p x = 0  \<and> (\<forall>q \<in> set I1. poly q x = 0) \<and> poly (prod_list I2) x < 0}))"
   unfolding construct_NofI_R_prop_helper[OF nonzero] 
   using zer_iff
   apply auto
   by (smt (verit, del_insts) Collect_cong sum_list_map_power2_poly zero_le_power2 zero_less_power2)
 
 section "Matrix Equation"
 
 definition map_sgas:: "rat list \<Rightarrow> rat list"
   where "map_sgas l = map (\<lambda>r. (1 - r^2)) l"
 
 definition z_R:: "(nat list*nat list) \<Rightarrow> rat list \<Rightarrow> rat"
   where "z_R index_list sign_asg \<equiv> (prod_list (map (nth (map_sgas sign_asg)) (fst(index_list))))*(prod_list (map (nth sign_asg) (snd(index_list))))"
 
 definition mtx_row_R:: "rat list list \<Rightarrow> (nat list * nat list) \<Rightarrow> rat list"
   where "mtx_row_R sign_list index_list \<equiv> (map ((z_R index_list)) sign_list)"
 
 definition matrix_A_R:: "rat list list \<Rightarrow>  (nat list * nat list) list \<Rightarrow> rat mat" 
   where "matrix_A_R sign_list subset_list = 
     (mat_of_rows_list (length sign_list) (map (\<lambda>i .(mtx_row_R sign_list i)) subset_list))"
 
 definition all_list_constr_R:: "(nat list*nat list) list \<Rightarrow> nat \<Rightarrow> bool"
   where "all_list_constr_R L n \<equiv> (\<forall>x. List.member L x \<longrightarrow> (list_constr (fst x) n \<and> list_constr (snd x) n))"
 
 definition alt_matrix_A_R:: "rat list list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat mat"
   where "alt_matrix_A_R signs subsets = (mat (length subsets) (length signs) 
     (\<lambda>(i, j). z_R (subsets ! i) (signs ! j)))"
 
 lemma alt_matrix_char_R: "alt_matrix_A_R signs subsets = matrix_A_R signs subsets"
 proof - 
   have h0: "(\<And>i j. i < length subsets \<Longrightarrow>
             j < length signs \<Longrightarrow>
             map (\<lambda>index_list. map (z_R index_list) signs) subsets ! i ! j = z_R (subsets ! i) (signs ! j))"
   proof -
     fix i
     fix j
     assume i_lt: "i < length subsets"
     assume j_lt: "j < length signs"
     show "((map (\<lambda>index_list. map (z_R index_list) signs) subsets) ! i) ! j = z_R (subsets ! i) (signs ! j)"
     proof - 
       have h0: "(map (\<lambda>index_list. map (z_R index_list) signs) subsets) ! i =  map (z_R (subsets ! i)) signs" 
         using nth_map i_lt
         by blast
       then show ?thesis using nth_map j_lt
         by simp 
     qed
   qed
   have h: " mat (length subsets) (length signs) (\<lambda>(i, j). z_R (subsets ! i) (signs ! j)) =
     mat (length subsets) (length signs) (\<lambda>(i, y). map (\<lambda>index_list. map (z_R index_list) signs) subsets ! i ! y)"
     using h0 eq_matI[where A = "mat (length subsets) (length signs) (\<lambda>(i, j). z_R (subsets ! i) (signs ! j))",
         where B = "mat (length subsets) (length signs) (\<lambda>(i, y). map (\<lambda>index_list. map (z_R index_list) signs) subsets ! i ! y)"]
     by auto
   show ?thesis unfolding alt_matrix_A_R_def matrix_A_R_def mat_of_rows_list_def apply (auto) unfolding mtx_row_R_def
     using h  by blast
 qed
 
 lemma subsets_are_rows_R: "\<forall>i < (length subsets). row (alt_matrix_A_R signs subsets) i  = vec (length signs) (\<lambda>j. z_R (subsets ! i) (signs ! j))"
   unfolding row_def unfolding alt_matrix_A_R_def by auto
 
 lemma signs_are_cols_R: "\<forall>i < (length signs). col (alt_matrix_A_R signs subsets) i  = vec (length subsets) (\<lambda>j. z_R (subsets ! j) (signs ! i))"
   unfolding col_def unfolding alt_matrix_A_R_def by auto
 
 definition consistent_sign_vec::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
   where "consistent_sign_vec qs x \<equiv>
     map (\<lambda> q. if (poly q x > 0) then (1::rat) else (if (poly q x = 0) then (0::rat) else (-1::rat))) qs"
 
 definition construct_lhs_vector_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list  \<Rightarrow> rat vec"
   where "construct_lhs_vector_R p qs signs \<equiv>                                                           
  vec_of_list (map (\<lambda>w.  rat_of_int (int (length (filter (\<lambda>v. v = w) (map (consistent_sign_vec qs) (characterize_root_list_p p)))))) signs)"
 
 (* The ith entry of LHS vector is the number of (distinct) real zeros of p where the sign vector of 
    the qs is the ith entry of signs.*)
 
 (* Putting all of the pieces of the construction together *)
 definition satisfy_equation_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat list list \<Rightarrow> bool"
   where "satisfy_equation_R p qs subset_list sign_list =
         (mult_mat_vec (matrix_A_R sign_list subset_list) (construct_lhs_vector_R p qs sign_list) = (construct_rhs_vector_R p qs subset_list))"
 
 (* Recharacterize the LHS vector *)
 lemma construct_lhs_vector_clean_R:
   assumes "p \<noteq> 0"
   assumes "i < length signs"
   shows "(construct_lhs_vector_R p qs signs) $ i =
     card {x. poly p x = 0 \<and> ((consistent_sign_vec qs x) = (nth signs i))}"
 proof -
   from poly_roots_finite[OF assms(1)] have "finite {x. poly p x = 0}" .
   then have eq: "(Collect
        ((\<lambda>v. v = signs ! i) \<circ>
         consistent_sign_vec qs) \<inter>
       set (sorted_list_of_set
             {x. poly p x = 0})) =
     {x. poly p x = 0 \<and> consistent_sign_vec qs x = signs ! i}"
     by auto
   show ?thesis
     unfolding construct_lhs_vector_R_def vec_of_list_index characterize_root_list_p_def
     apply auto
     apply (subst nth_map[OF assms(2)])
     apply auto
     apply (subst distinct_length_filter)
      apply (auto) 
     using eq 
     by auto
 qed
 
 lemma construct_lhs_vector_cleaner_R:
   assumes "p \<noteq> 0"
   shows "(construct_lhs_vector_R p qs signs) =
    vec_of_list (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> ((consistent_sign_vec qs x) = s)})) signs)"
   apply (rule eq_vecI)
    apply (auto simp add:  construct_lhs_vector_clean_R[OF assms] )
    apply (simp add: vec_of_list_index)
   unfolding construct_lhs_vector_R_def
   using assms construct_lhs_vector_clean_R construct_lhs_vector_def apply auto[1]
    apply (simp add: construct_lhs_vector_R_def)
   by auto
 
 (* Show that because our consistent sign vectors consist of 1, 0's, and -1's, z returns 1, 0, or -1 
   when applied to a consistent sign vector *)
 lemma z_signs_R2:
   fixes I:: "nat list"
   fixes signs:: "rat list"
   assumes lf: "list_all (\<lambda>i. i < length signs) I"
   assumes la:  "list_all (\<lambda>s. s = 1 \<or> s = 0 \<or> s = -1) signs"
   shows "(prod_list (map (nth signs) I)) = 1 \<or>
   (prod_list (map (nth signs) I)) = 0 \<or>
   (prod_list (map (nth signs) I)) = -1" using assms
 proof (induct I)
   case Nil
   then show ?case by auto
 next
   case (Cons a I)
   moreover have eo: "signs ! a = 1 \<or> signs ! a = 0 \<or> signs ! a = -1" 
     using assms
     by (smt (verit, del_insts) calculation(2) list_all_length list_all_simps(1)) 
   have "prod_list (map ((!) (map_sgas signs)) (a # I)) = (1 - (signs ! a)^2)*prod_list (map ((!) (map_sgas signs)) (I))"
     unfolding map_sgas_def apply (auto)
     using calculation(2) by auto 
   then show ?case using eo
     using Cons.hyps calculation(2) la by auto 
 qed
 
 lemma z_signs_R1:
   fixes I:: "nat list"
   fixes signs:: "rat list"
   assumes lf: "list_all (\<lambda>i. i < length signs) I"
   assumes la:  "list_all (\<lambda>s. s = 1 \<or> s = 0 \<or> s = -1) signs"
   shows "(prod_list (map (nth (map_sgas signs)) I)) = 1 \<or>
 (prod_list (map (nth (map_sgas signs)) I)) = 0" using assms
 proof (induct I)
   case Nil
   then show ?case by auto
 next
   case (Cons a I)
   moreover have "signs ! a = 1 \<or> signs ! a = 0 \<or> signs ! a = -1" 
     using assms
     by (smt (verit, best) calculation(2) list_all_length list_all_simps(1)) 
   then have eo: "1 - (signs ! a)^2 = 1 \<or> 1 - (signs !a)^2 = 0"
     using cancel_comm_monoid_add_class.diff_cancel diff_zero by fastforce
   have "prod_list (map ((!) (map_sgas signs)) (a # I)) = (1 - (signs ! a)^2)*prod_list (map ((!) (map_sgas signs)) (I))"
     unfolding map_sgas_def apply (auto)
     using calculation(2) by auto 
   then show ?case using eo
     using Cons.hyps calculation(2) la by auto 
 qed
 
 lemma z_signs_R:
   fixes I:: "(nat list * nat list)"
   fixes signs:: "rat list"
   assumes lf: "list_all (\<lambda>i. i < length signs) (fst(I))"
   assumes ls: "list_all (\<lambda>i. i < length signs) (snd(I))"
   assumes la:  "list_all (\<lambda>s. s = 1 \<or> s = 0 \<or> s = -1) signs"
   shows "(z_R I signs = 1) \<or> (z_R I signs = 0) \<or> (z_R I signs = -1)" 
   using assms z_signs_R2 z_signs_R1 unfolding z_R_def apply (auto)
   by (metis (no_types, lifting) mult_cancel_left1 mult_minus1_right)
 
 lemma z_lemma_R:
   fixes I:: "nat list * nat list" 
   fixes sign:: "rat list"
   assumes consistent: "sign \<in> set (characterize_consistent_signs_at_roots p qs)"
   assumes welldefined1: "list_constr (fst I) (length qs)"
   assumes welldefined2: "list_constr (snd I) (length qs)"
   shows "(z_R I sign = 1) \<or> (z_R I sign = 0) \<or> (z_R I sign = -1)"
 proof (rule z_signs_R)
   have same: "length sign = length qs" using consistent
     using characterize_consistent_signs_at_roots_def signs_at_def by fastforce
   thus "(list_all (\<lambda>i. i < length sign) (fst I))"
     using welldefined1  
     by (auto simp add: list_constr_def characterize_consistent_signs_at_roots_def consistent_sign_vec_copr_def)
   thus "(list_all (\<lambda>i. i < length sign) (snd I))"
     using same welldefined2  
     by (auto simp add: list_constr_def characterize_consistent_signs_at_roots_def consistent_sign_vec_copr_def)
   show "list_all (\<lambda>s. s = 1 \<or> s = 0 \<or> s = - 1) sign" using consistent
     apply (auto simp add: list.pred_map  characterize_consistent_signs_at_roots_def  consistent_sign_vec_def)
     using Ball_set
     by (simp add: list_all_length signs_at_def squash_def) 
 qed
 
 (* Show that all consistent sign vectors on roots of polynomials are in characterize_consistent_signs_at_roots  *)
 lemma in_set_R: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   shows "sign \<in> set (characterize_consistent_signs_at_roots p qs)" 
 proof -
   have h1: "consistent_sign_vec qs x \<in>
       set (remdups (map (signs_at qs) (sorted_list_of_set {x. poly p x = 0})))" 
     unfolding consistent_sign_vec_def signs_at_def squash_def
     using root_p nonzero poly_roots_finite set_sorted_list_of_set apply (auto)
     by (smt (verit, ccfv_SIG) Collect_cong comp_def image_eqI map_eq_conv mem_Collect_eq poly_roots_finite set_sorted_list_of_set) 
   thus ?thesis unfolding characterize_consistent_signs_at_roots_def characterize_root_list_p_def using sign_fix
     by blast
 qed
 
 lemma consistent_signs_prop_R:
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   shows  "list_all (\<lambda>s. s = 1 \<or> s = 0 \<or> s = -1) sign"
   using assms unfolding consistent_sign_vec_def squash_def apply (auto)
   by (smt (z3) length_map list_all_length nth_map) 
 
 (* The next few lemmas relate z_R to the signs of the product of subsets of polynomials of qs *)
 lemma horiz_vector_helper_pos_ind_R1: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   assumes asm: "list_constr I (length qs)"
   shows "(prod_list (map (nth (map_sgas sign)) I)) = 1 \<longleftrightarrow> 
     (\<forall>p \<in> set (retrieve_polys qs I). poly p x = 0)"
   using asm
 proof (induction "I")
   case Nil
   then show ?case unfolding map_sgas_def apply (auto)
     by (simp add: retrieve_polys_def)
 next
   case (Cons a xa)
   then have same0: "(prod_list (map (nth (map_sgas sign)) xa)) = 1 \<longleftrightarrow> 
     (\<forall>p \<in> set (retrieve_polys qs xa). poly p x = 0)" unfolding list_constr_def by auto
   have welldef: "a < length qs" using Cons.prems assms unfolding list_constr_def by auto
   then have h: "prod_list (map ((!) (map_sgas sign)) (a#xa)) = (1 - (sign ! a)^2)*(prod_list (map ((!) (map_sgas sign)) (xa)))"
     unfolding map_sgas_def using assms apply (auto)
     by (metis (no_types, lifting) consistent_sign_vec_def length_map nth_map) 
   have "list_all (\<lambda>s. s = 1 \<or> s = 0 \<or> s = -1) sign" using sign_fix unfolding consistent_sign_vec_def squash_def
     apply (auto)
     by (smt (z3) length_map list_all_length nth_map) 
   then have eo: "(prod_list (map ((!) (map_sgas sign)) (xa))) = 0 \<or> (prod_list (map ((!) (map_sgas sign)) (xa))) = 1"
     using z_signs_R1 assms Cons.prems consistent_sign_vec_def length_map list_all_simps(1) length_map list_all_length list_constr_def
     by (smt (verit, best))
   have "(sign ! a)^2 = 1 \<or> (sign ! a)^2 = 0" using sign_fix welldef  unfolding consistent_sign_vec_def 
     by auto
   then have s1: "(prod_list (map (nth (map_sgas sign)) (a#xa))) = 1 \<longleftrightarrow> 
     ((sign ! a)^2 = 0 \<and> (prod_list (map ((!) (map_sgas sign)) (xa))) = 1)"
     using eo h
     by (metis (mono_tags, opaque_lifting) cancel_comm_monoid_add_class.diff_cancel diff_zero mult.left_neutral mult_zero_left)
   have "(sign ! a)^2 = 0 \<longleftrightarrow> (poly (qs ! a) x = 0)"
     using sign_fix unfolding consistent_sign_vec_def welldef apply (auto)
      apply (smt (z3) class_field.neg_1_not_0 class_field.zero_not_one nth_map welldef)
     by (smt (z3) nth_map welldef)
   then have same1:"(prod_list (map (nth (map_sgas sign)) (a#xa))) = 1 \<longleftrightarrow> 
     ((poly (qs ! a) x = 0) \<and> (prod_list (map ((!) (map_sgas sign)) (xa))) = 1)" using s1 by auto
   have "set (retrieve_polys qs (a#xa)) = {(qs ! a)} \<union> set (retrieve_polys qs xa)"
     by (metis (no_types, lifting) insert_is_Un list.simps(15) list.simps(9) retrieve_polys_def)
   then have same2:"(\<forall>p \<in> set (retrieve_polys qs (a#xa)). poly p x = 0) = ((poly (qs ! a) x = 0)
       \<and> (\<forall>p \<in> set (retrieve_polys qs (xa)). poly p x = 0))"
     by auto 
   then show ?case using same0 same1 same2 
       assms by auto
 qed
 
 lemma csv_length_same_as_qlist: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   shows "length sign = length qs" 
   using assms unfolding consistent_sign_vec_def by auto
 
 lemma horiz_vector_helper_zer_ind_R2: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   assumes asm: "list_constr I (length qs)"
   shows "(prod_list (map (nth sign) I)) = 0 \<longleftrightarrow> 
     (poly (prod_list (retrieve_polys qs I)) x = 0)"
   using asm
 proof (induction "I")
   case Nil
   then show ?case unfolding map_sgas_def apply (auto) unfolding retrieve_polys_def
     by auto next
   case (Cons a xa)
   have "poly (prod_list (retrieve_polys qs (a # xa))) x = (poly (qs ! a) x)*poly (prod_list (retrieve_polys qs (xa))) x"
     by (simp add: retrieve_polys_def)
   then show ?case using Cons.prems
     by (smt (z3) Cons.IH class_field.neg_1_not_0 class_field.zero_not_one consistent_sign_vec_def list.simps(9) list_all_simps(1) list_constr_def mult_eq_0_iff nth_map prod_list.Cons sign_fix) 
 qed
 
 lemma horiz_vector_helper_pos_ind_R2: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   assumes asm: "list_constr I (length qs)"
   shows "(prod_list (map (nth sign) I)) = 1 \<longleftrightarrow> 
     (poly (prod_list (retrieve_polys qs I)) x > 0)"
   using asm
 proof (induction "I")
   case Nil
   then show ?case unfolding map_sgas_def apply (auto) unfolding retrieve_polys_def
     by auto next
   case (Cons a xa)
   then have ih: "(prod_list (map ((!) sign) xa) = 1) = (0 < poly (prod_list (retrieve_polys qs xa)) x)"
     unfolding list_constr_def by auto
   have lensame: "length sign = length qs" using sign_fix csv_length_same_as_qlist[of p x sign qs]
       nonzero root_p by auto
   have "poly (prod_list (retrieve_polys qs (a # xa))) x = (poly (qs ! a) x)*poly (prod_list (retrieve_polys qs (xa))) x"
     by (simp add: retrieve_polys_def)
   then have iff1: "(poly (prod_list (retrieve_polys qs (a#xa))) x > 0) \<longleftrightarrow> 
       (((poly (qs ! a) x) > 0 \<and> poly (prod_list (retrieve_polys qs (xa))) x > 0) \<or> 
        ((poly (qs ! a) x) < 0 \<and> poly (prod_list (retrieve_polys qs (xa))) x < 0))"
     by (metis zero_less_mult_iff)
   have prodsame: "(prod_list (map (nth sign) (a#xa))) = (sign ! a)* (prod_list (map (nth sign) (xa)))"
     using lensame Cons.prems unfolding list_constr_def by auto
   have sagt: "sign ! a = 1 \<longleftrightarrow> (poly (qs ! a) x) > 0" using assms unfolding consistent_sign_vec_def
     apply (auto)
      apply (smt (verit, best) Cons.prems list_all_simps(1) list_constr_def neg_equal_zero nth_map zero_neq_one)
     by (smt (verit, ccfv_threshold) Cons.prems list_all_simps(1) list_constr_def nth_map)
   have salt: "sign ! a = -1 \<longleftrightarrow> (poly (qs ! a) x) < 0" using assms unfolding consistent_sign_vec_def
     apply (auto)
      apply (smt (verit, ccfv_SIG) Cons.prems less_minus_one_simps(1) less_minus_one_simps(3) list_all_simps(1) list_constr_def neg_0_less_iff_less nth_map)
     by (smt (verit, best) Cons.prems list_all_simps(1) list_constr_def nth_map)  
   have h1: "((poly (qs ! a) x) > 0 \<and> poly (prod_list (retrieve_polys qs (xa))) x > 0) \<longrightarrow>
        (prod_list (map (nth sign) (a#xa))) = 1" 
     using prodsame sagt ih by auto
   have eo: "(prod_list (map ((!) sign) xa) = 1)  \<or> (prod_list (map ((!) sign) xa) = 0) \<or> 
       (prod_list (map ((!) sign) xa) = -1)"
     using Cons.prems consistent_signs_prop_R lensame list_constr_def nonzero root_p sign_fix z_signs_R2 by auto
   have d1:"(prod_list (map ((!) sign) xa) = -1) \<Longrightarrow> (0 > poly (prod_list (retrieve_polys qs xa)) x)"
   proof -
     assume "(prod_list (map ((!) sign) xa) = -1) "
     then show "(0 > poly (prod_list (retrieve_polys qs xa)) x)"
       using prodsame salt ih assms Cons.prems class_field.neg_1_not_0 equal_neg_zero horiz_vector_helper_zer_ind_R2 linorder_neqE_linordered_idom list_all_simps(1) list_constr_def
       apply (auto)
        apply (smt (verit, ccfv_threshold) class_field.neg_1_not_0 list.set_map list_all_length semidom_class.prod_list_zero_iff)
       by (smt (verit, ccfv_threshold) class_field.neg_1_not_0 list.set_map list_all_length semidom_class.prod_list_zero_iff)
   qed
   have d2: "(0 > poly (prod_list (retrieve_polys qs xa)) x) \<longrightarrow> (prod_list (map ((!) sign) xa) = -1)"
     using eo assms horiz_vector_helper_zer_ind_R2[where p = "p", where x = "x", where sign = "sign", where I ="I"]
     apply (auto)
     using ih apply force
     by (metis (full_types, lifting) Cons.prems class_field.neg_1_not_0 horiz_vector_helper_zer_ind_R2 ih imageI list.set_map list_all_simps(1) list_constr_def mem_Collect_eq neg_equal_0_iff_equal semidom_class.prod_list_zero_iff)  
   have "(prod_list (map ((!) sign) xa) = -1) = (0 > poly (prod_list (retrieve_polys qs xa)) x)"
     using d1 d2
     by blast       
   then have h2: "((poly (qs ! a) x) < 0 \<and> poly (prod_list (retrieve_polys qs (xa))) x < 0) \<longrightarrow>
       (prod_list (map (nth sign) (a#xa))) = 1"
     using prodsame salt ih by auto
   have h3: "(prod_list (map (nth sign) (a#xa))) = 1 \<longrightarrow> (((poly (qs ! a) x) > 0 \<and> poly (prod_list (retrieve_polys qs (xa))) x > 0) \<or> 
        ((poly (qs ! a) x) < 0 \<and> poly (prod_list (retrieve_polys qs (xa))) x < 0))"
     using prodsame salt ih assms horiz_vector_helper_zer_ind_R2[where p = "p", where x = "x", where sign = "sign", where I ="I"]
     by (smt (verit, ccfv_threshold) Cons.prems \<open>poly (prod_list (retrieve_polys qs (a # xa))) x = poly (qs ! a) x * poly (prod_list (retrieve_polys qs xa)) x\<close> horiz_vector_helper_zer_ind_R2 mem_Collect_eq mult_cancel_left1 mult_not_zero sagt) 
   then show ?case using h1 h2 h3 iff1 Cons.prems by auto
 qed
 
 lemma horiz_vector_helper_pos_ind_R: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list * nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   assumes asm1: "list_constr (fst I) (length qs)"
   assumes asm2: "list_constr (snd I) (length qs)"
   shows "((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x > 0)) \<longleftrightarrow> (z_R I sign = 1)"
 proof - 
   have len: "length sign = length qs" using sign_fix csv_length_same_as_qlist[of p x sign qs]
       nonzero root_p by auto
   have d1: "((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x > 0)) \<longrightarrow> (z_R I sign = 1)" 
     using assms horiz_vector_helper_pos_ind_R1[where p = "p", where qs = "qs", where sign = "sign", where x = "x", where I = "fst I"]
       horiz_vector_helper_pos_ind_R2[where p = "p", where qs = "qs", where sign = "sign", where x = "x", where I = "snd I"] unfolding z_R_def 
     by auto
   have d2: "(z_R I sign = 1) \<longrightarrow> ((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x > 0))"
   proof - 
     have h1: "(z_R I sign = 1) \<longrightarrow> (\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0)" 
     proof - 
       have "(prod_list (map (nth (map_sgas sign)) (fst I))) = 1 \<or> (prod_list (map (nth (map_sgas sign)) (fst I))) = 0" 
         using len consistent_signs_prop_R[where p = "p", where qs = "qs", where x = "x", where sign = "sign"] z_signs_R1[where signs = "sign", where I = "fst I"] assms 
         unfolding list_constr_def 
         by auto
       then show ?thesis
         using z_signs_R1[where signs = "sign", where I = "fst I"] horiz_vector_helper_pos_ind_R1[where sign = "sign", where I = "fst I", where p = "p", where x = "x"] assms 
         apply (auto)
         by (metis (mono_tags, opaque_lifting) \<open>prod_list (map ((!) (map_sgas sign)) (fst I)) = 1 \<or> prod_list (map ((!) (map_sgas sign)) (fst I)) = 0\<close> mult_zero_left z_R_def) 
     qed
     then have h2: "(z_R I sign = 1) \<longrightarrow> (poly (prod_list (retrieve_polys qs (snd I))) x > 0)" 
       unfolding z_R_def using assms horiz_vector_helper_pos_ind_R2[where p = "p", where x = "x", where sign = "sign", where qs = "qs", where I ="snd I"]
       by (metis horiz_vector_helper_pos_ind_R1 mult.left_neutral)
     show ?thesis using h1 h2 by auto
   qed
   show ?thesis using d1 d2 by blast
 qed
 
 lemma horiz_vector_helper_pos_R: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list*nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   assumes welldefined1: "list_constr (fst I) (length qs)"
   assumes welldefined2: "list_constr (snd I) (length qs)"
   shows "((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x > 0)) \<longleftrightarrow> (z_R I sign = 1)"
   using horiz_vector_helper_pos_ind_R
   using  nonzero  root_p sign_fix welldefined1 welldefined2 by blast
 
 lemma horiz_vector_helper_neg_R: 
   fixes p:: "real poly"
   assumes nonzero: "p\<noteq>0"
   fixes qs:: "real poly list"
   fixes I:: "nat list*nat list" 
   fixes sign:: "rat list"
   fixes x:: "real"
   assumes root_p: "x \<in> {x. poly p x = 0}"
   assumes sign_fix: "sign = consistent_sign_vec qs x"
   assumes welldefined1: "list_constr (fst I) (length qs)"
   assumes welldefined2: "list_constr (snd I) (length qs)"
   shows "((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x < 0)) \<longleftrightarrow> (z_R I sign = -1)"
 proof -
   have set_hyp: "sign \<in> set (characterize_consistent_signs_at_roots p qs)" 
     using in_set_R[of p x sign qs] nonzero root_p sign_fix  by blast 
   have z_hyp: "((z_R I sign = 1) \<or> (z_R I sign = 0) \<or> (z_R I sign = -1))" 
     using welldefined1 welldefined2 set_hyp  z_lemma_R[where sign="sign", where I = "I", where p="p", where qs="qs"] by blast
   have d1: "((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x < 0)) \<Longrightarrow> (z_R I sign = -1)"
     using horiz_vector_helper_pos_R
     using nonzero root_p sign_fix welldefined1 welldefined2
     by (smt (verit, ccfv_threshold) horiz_vector_helper_pos_ind_R1 horiz_vector_helper_zer_ind_R2 mem_Collect_eq mult_eq_0_iff z_R_def z_hyp) 
   have d2: "(z_R I sign = -1) \<Longrightarrow> ((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x < 0))" 
     using horiz_vector_helper_pos_ind_R1 horiz_vector_helper_zer_ind_R2 nonzero root_p sign_fix welldefined1 welldefined2
     by (smt (verit, ccfv_threshold) class_field.neg_1_not_0 consistent_sign_vec_def consistent_signs_prop_R equal_neg_zero horiz_vector_helper_pos_ind_R2 length_map list_all_length list_constr_def mem_Collect_eq mem_Collect_eq mult_cancel_left1 mult_not_zero retrieve_polys_def z_R_def z_signs_R1 zero_neq_one)
   then show ?thesis using d1 d2
     by linarith 
 qed
 
 lemma lhs_dot_rewrite:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list*nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   shows
     "(vec_of_list (mtx_row_R signs I) \<bullet> (construct_lhs_vector_R p qs signs)) =
    sum_list (map (\<lambda>s. (z_R I s)  *  rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) signs)"
 proof -
   have "p \<noteq> 0" using nonzero by auto
   from construct_lhs_vector_cleaner[OF this]
   have rhseq: "construct_lhs_vector_R p qs signs =
     vec_of_list
     (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) signs)"
     using construct_lhs_vector_cleaner_R nonzero by presburger
   have "(vec_of_list (mtx_row_R signs I) \<bullet> (construct_lhs_vector_R p qs signs)) =    
     sum_list (map2 (*) (mtx_row_R signs I) (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) signs))"
     unfolding rhseq 
     apply (intro vec_of_list_dot_rewrite)
     by (auto simp add: mtx_row_R_def)
   thus ?thesis unfolding mtx_row_R_def
     using map2_map_map 
     by (auto simp add: map2_map_map)
 qed
 
 (* If we have a superset of the signs, we can drop to just the consistent ones *)
 lemma construct_lhs_vector_drop_consistent_R:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list*nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes welldefined1: "list_constr (fst I) (length qs)"
   assumes welldefined2: "list_constr (snd I) (length qs)"
   shows
     "(vec_of_list (mtx_row_R signs I) \<bullet> (construct_lhs_vector_R p qs signs)) =
      (vec_of_list (mtx_row_R (characterize_consistent_signs_at_roots p qs) I) \<bullet>
       (construct_lhs_vector_R p qs (characterize_consistent_signs_at_roots p qs)))"
 proof - 
   have h0: "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec qs ` set (characterize_root_list_p p) \<and> 
     0 < rat_of_nat (card  {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = sgn}) \<longrightarrow> z_R I sgn = 0"
   proof - 
     have "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_int (card
                   {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = sgn}) \<longrightarrow> {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = sgn} \<noteq> {}" 
       by fastforce
     then show ?thesis
     proof -
       { fix iis :: "rat list"
         have ff1: "0 \<noteq> p"
           using nonzero rsquarefree_def by blast
         obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> real" where
           ff2: "\<And>p. p (rr p) \<or> Collect p = {}"
-          by moura
+          by (metis Collect_empty_eq)
         { assume "\<exists>is. is = iis \<and> {r. poly p r = 0 \<and> consistent_sign_vec qs r = is} \<noteq> {}"
           then have "\<exists>is. consistent_sign_vec qs (rr (\<lambda>r. poly p r = 0 \<and> consistent_sign_vec qs r = is)) = iis \<and> {r. poly p r = 0 \<and> consistent_sign_vec qs r = is} \<noteq> {}"
             using ff2
             by (metis (mono_tags, lifting))
           then have "\<exists>r. poly p r = 0 \<and> consistent_sign_vec qs r = iis"
             using ff2
             by smt
           then have "iis \<in> consistent_sign_vec qs ` set (sorted_list_of_set {r. poly p r = 0})"
             using ff1 poly_roots_finite
             by (metis (mono_tags) imageI mem_Collect_eq set_sorted_list_of_set) }
         then have "iis \<notin> set signs \<or> iis \<in> consistent_sign_vec qs ` set (characterize_root_list_p p) \<or> \<not> 0 < rat_of_int (int (card {r. poly p r = 0 \<and> consistent_sign_vec qs r = iis}))"
           by (metis (no_types) \<open>\<forall>sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_int (int (card {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = sgn})) \<longrightarrow> {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = sgn} \<noteq> {}\<close> characterize_root_list_p_def) }
       then show ?thesis
         by fastforce
     qed
   qed
   then have "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec qs ` set (characterize_root_list_p p) \<longrightarrow> ((0 = rat_of_nat (card
                   {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = sgn}) \<or> z_R I sgn = 0))"
     by auto
   then have hyp: "\<forall> s. s \<in> set signs \<and> s \<notin> consistent_sign_vec qs ` set (characterize_root_list_p p) \<longrightarrow> (z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) = 0)"
     by auto
   then have "(\<Sum>s\<in> set(signs). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) = 
         (\<Sum>s\<in>(set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
   proof - 
     have "set(signs) =(set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))) \<union>
               (set(signs)-(consistent_sign_vec qs ` set (characterize_root_list_p p)))"
       by blast
     then have sum_rewrite: "(\<Sum>s\<in> set(signs). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) =  
           (\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))) \<union>
               (set(signs)-(consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
       by auto
     then have sum_split: "(\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))) \<union>
               (set(signs)-(consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))
           = 
 (\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))
 + (\<Sum>s\<in> (set(signs)-(consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
       by (metis (no_types, lifting) List.finite_set sum.Int_Diff)
     have sum_zero: "(\<Sum>s\<in> (set(signs)-(consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) = 0"   
       using hyp
       by (simp add: hyp)      
     show ?thesis using sum_rewrite sum_split sum_zero by linarith
   qed
   then have set_eq: "set (remdups
            (map (consistent_sign_vec qs)
              (characterize_root_list_p p))) = set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))"
     using all_info apply (simp add: characterize_consistent_signs_at_roots_def subset_antisym)
     by (smt (z3) Int_subset_iff consistent_sign_vec_def list.set_map map_eq_conv o_apply signs_at_def squash_def subsetI subset_antisym)
   have hyp1: "(\<Sum>s\<leftarrow>signs. z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) = 
         (\<Sum>s\<in>set (signs). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     using distinct_signs sum_list_distinct_conv_sum_set by blast
   have hyp2: "(\<Sum>s\<leftarrow>remdups
            (map (consistent_sign_vec qs)
              (characterize_root_list_p p)). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))
   = (\<Sum>s\<in> set (remdups
            (map (consistent_sign_vec qs)
              (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     using sum_list_distinct_conv_sum_set by blast 
   have set_sum_eq: "(\<Sum>s\<in>(set (signs) \<inter> (consistent_sign_vec qs ` set (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) =
     (\<Sum>s\<in> set (remdups
            (map (consistent_sign_vec qs)
              (characterize_root_list_p p))). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     using set_eq by auto
   then have "(\<Sum>s\<leftarrow>signs. z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) =
     (\<Sum>s\<leftarrow>remdups
            (map (consistent_sign_vec qs)
              (characterize_root_list_p p)). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     using set_sum_eq hyp1 hyp2
     using \<open>(\<Sum>s\<in>set signs. z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) = (\<Sum>s\<in>set signs \<inter> consistent_sign_vec qs ` set (characterize_root_list_p p). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))\<close> by linarith
   then have "consistent_sign_vec qs ` set (characterize_root_list_p p) \<subseteq> set signs \<Longrightarrow>
     (\<And>p qss.
         characterize_consistent_signs_at_roots p qss =
         remdups (map (consistent_sign_vec qss) (characterize_root_list_p p))) \<Longrightarrow>
     (\<Sum>s\<leftarrow>signs. z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) =
     (\<Sum>s\<leftarrow>remdups
            (map (consistent_sign_vec qs)
              (characterize_root_list_p p)). z_R I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     by linarith
   then show ?thesis unfolding lhs_dot_rewrite[OF nonzero]
     apply (auto intro!: sum_list_distinct_filter simp add: distinct_signs  consistent_sign_vec_def characterize_consistent_signs_at_roots_def)
     using all_info consistent_sign_vec_def characterize_consistent_signs_at_roots_def
     by (smt (z3) list.set_map map_eq_conv o_apply set_remdups signs_at_def squash_def) 
 qed
 
 lemma matrix_equation_helper_step_R:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list*nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes welldefined1: "list_constr (fst I) (length qs)"
   assumes welldefined2: "list_constr (snd I) (length qs)"
   shows "(vec_of_list (mtx_row_R signs I) \<bullet> (construct_lhs_vector_R p qs signs)) =
    rat_of_int (card {x. poly p x = 0 \<and> (\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> poly (prod_list (retrieve_polys qs (snd I))) x > 0}) -
    rat_of_int (card {x. poly p x = 0 \<and> (\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> poly (prod_list (retrieve_polys qs (snd I))) x < 0})"
 proof -
   have finset: "finite (set (map (consistent_sign_vec qs)  (characterize_root_list_p p)))" by auto
   let ?gt = "(set (map (consistent_sign_vec qs)  (characterize_root_list_p p)) \<inter> {s. z_R I s = 1})"
   let ?lt = "  (set (map (consistent_sign_vec qs)  (characterize_root_list_p p)) \<inter> {s. z_R I s = -1})"  
   let ?zer = "(set (map (consistent_sign_vec qs)  (characterize_root_list_p p)) \<inter> {s. z_R I s = 0})"
   have eq: "set (map (consistent_sign_vec qs)  (characterize_root_list_p p)) = (?gt \<union> ?lt) \<union> ?zer"
   proof safe
     fix x
     assume h:"x \<in> set (map (consistent_sign_vec qs) (characterize_root_list_p p))"
         "z_R I x \<noteq> 0" "z_R I x \<noteq> - 1" 
     then have "x \<in> set (characterize_consistent_signs_at_roots p qs)"
       unfolding characterize_consistent_signs_at_roots_def
       by (smt (verit, del_insts) characterize_consistent_signs_at_roots_def characterize_root_list_p_def imageE in_set_R nonzero poly_roots_finite set_map sorted_list_of_set(1))
     thus "z_R I x = 1"
       using h welldefined1 welldefined2 z_lemma_R by blast
   qed
   have sumeq: "(\<Sum>s\<in>(?gt\<union>?lt). z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))
   = (\<Sum>s\<in>?gt. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) +
   (\<Sum>s\<in>?lt. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     apply (rule sum.union_disjoint) by auto
       (* First, drop the signs that are irrelevant *)
   from construct_lhs_vector_drop_consistent_R[OF assms(1-5)] have
     "vec_of_list (mtx_row_R signs I) \<bullet> construct_lhs_vector_R p qs signs =
   vec_of_list (mtx_row_R (characterize_consistent_signs_at_roots p qs) I) \<bullet>
   construct_lhs_vector_R p qs (characterize_consistent_signs_at_roots p qs)" .
     (* Now we split the sum *)
   from lhs_dot_rewrite[OF assms(1)]
   moreover have "... =
   (\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots p qs.
     z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))" .
   moreover have "... =
   (\<Sum>s\<in>set (map (consistent_sign_vec qs)  (characterize_root_list_p p)).
     z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))" unfolding characterize_consistent_signs_at_roots_def sum_code[symmetric]
     apply (auto)
     by (smt (verit, best) consistent_sign_vec_def list.set_map map_eq_conv o_apply signs_at_def squash_def sum.set_conv_list) 
   moreover have setc1:"... = 
   (\<Sum>s\<in>(?gt\<union>?lt). z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) +
     (\<Sum>s\<in>?zer. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) "
     apply (subst eq) 
     apply (rule  sum.union_disjoint) by auto
   ultimately have setc: "... =
   (\<Sum>s\<in>?gt. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) +
   (\<Sum>s\<in>?lt. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) +
   (\<Sum>s\<in>?zer. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))"
     using sumeq by auto
   have "\<forall>s \<in> ?zer. (z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) = 0"
     by auto
   then have obvzer: "(\<Sum>s\<in>?zer. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) = 0"
     by auto
   (* Now recharacterize lt, gt*)
   have setroots: "set (characterize_root_list_p p) = {x. poly p x = 0}" unfolding characterize_root_list_p_def
     using poly_roots_finite nonzero rsquarefree_def set_sorted_list_of_set by blast    
   have *: "\<And>s. {x. poly p x = 0 \<and> consistent_sign_vec qs x = s} =
         {x \<in>{x. poly p x = 0}. consistent_sign_vec qs x = s}"
     by auto
   have e1: "(\<Sum>s\<in>consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = 1}.
        card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) =
      (sum (\<lambda>x. if (\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x) > 0 then 1 else 0) {x. poly p x = 0})"
     unfolding * apply (rule sum_multicount_gen)
     using \<open>finite (set (map (consistent_sign_vec qs) (characterize_root_list_p p)))\<close> setroots apply auto[1]
      apply (metis List.finite_set setroots)
   proof safe
     fix x
     assume rt: "poly p x = 0"
     then have 1: "{s \<in> consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = 1}. consistent_sign_vec qs x = s} =
       {s. z_R I s = 1 \<and> consistent_sign_vec qs x = s}"
       by auto
     have 2: "... = {s. (\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (0 < poly (prod_list (retrieve_polys qs (snd I))) x)  \<and> consistent_sign_vec qs x = s}"
       using horiz_vector_helper_pos_R assms welldefined1 welldefined2 rt by blast
     have 3: "... = (if (\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (0 < poly (prod_list (retrieve_polys qs (snd I))) x)  then {consistent_sign_vec qs x} else {})"
       by auto
     then have "card {s \<in> consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = 1}. consistent_sign_vec qs x = s} =
          (if ((\<forall>p \<in> set (retrieve_polys qs (fst I)). poly p x = 0) \<and> 0 < poly (prod_list  (retrieve_polys qs (snd I))) x)
           then 1 else 0)" using 1 2 3 by auto
     thus " card
           {s \<in> consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = 1}.
            consistent_sign_vec qs x = s} =
          (if (\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and>
              0 < poly (prod_list (retrieve_polys qs (snd I))) x
           then 1 else 0)" 
       by auto
   qed
 
   have gtchr: "(\<Sum>s\<in>?gt. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) =
     rat_of_int (card {x. poly p x = 0 \<and> (\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and> 0 < poly (prod_list (retrieve_polys qs (snd I))) x})"
     apply (auto simp add: setroots)
     apply (subst of_nat_sum[symmetric])
     apply (subst of_nat_eq_iff)
     apply (subst e1)
     apply (subst card_eq_sum)
     apply (rule sum.mono_neutral_cong_right)
        apply (metis List.finite_set setroots)
     by auto
   have e2: " (\<Sum>s\<in>consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = - 1}.
        card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) =
      (sum (\<lambda>x. if (\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (poly (prod_list (retrieve_polys qs (snd I))) x) < 0 then 1 else 0) {x. poly p x = 0})"
     unfolding * apply (rule sum_multicount_gen)
     using \<open>finite (set (map (consistent_sign_vec qs) (characterize_root_list_p p)))\<close> setroots apply auto[1]
      apply (metis List.finite_set setroots)
   proof safe
     fix x
     assume rt: "poly p x = 0"
     then have 1: "{s \<in> consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = -1}. consistent_sign_vec qs x = s} =
       {s. z_R I s = -1 \<and> consistent_sign_vec qs x = s}"
       by auto
     have 2: "... = {s. ((\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and> 0 > poly (prod_list (retrieve_polys qs (snd I))) x)  \<and> consistent_sign_vec qs x = s}"
       using horiz_vector_helper_neg_R assms rt welldefined1 welldefined2 by blast
     have 3: "... = (if (\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and> (0 > poly (prod_list (retrieve_polys qs (snd I))) x)  then {consistent_sign_vec qs x} else {})"
       by auto
     thus "card {s \<in> consistent_sign_vec qs ` {x. poly p x = 0} \<inter> {s. z_R I s = -1}. consistent_sign_vec qs x = s} =
          (if (\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and> 0 > poly
                   (prod_list
                     (retrieve_polys qs (snd I)))
                   x
           then 1 else 0)" using 1 2 3 by auto
   qed
   have ltchr: "(\<Sum>s\<in>?lt. z_R I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})) =
     - rat_of_int (card {x. poly p x = 0 \<and> (\<forall>p\<in>set (retrieve_polys qs (fst I)). poly p x = 0) \<and> 0 > poly (prod_list (retrieve_polys qs (snd I))) x})"
     apply (auto simp add: setroots sum_negf)
     apply (subst of_nat_sum[symmetric])
     apply (subst of_nat_eq_iff)
     apply (subst e2)
     apply (subst card_eq_sum)
     apply (rule sum.mono_neutral_cong_right)
        apply (metis List.finite_set setroots)
     by auto
   show ?thesis using gtchr ltchr obvzer setc
     using \<open>(\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots p qs. z_R I s * rat_of_int (int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}))) = (\<Sum>s\<in>set (map (consistent_sign_vec qs) (characterize_root_list_p p)). z_R I s * rat_of_int (int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})))\<close> \<open>vec_of_list (mtx_row_R (characterize_consistent_signs_at_roots p qs) I) \<bullet> construct_lhs_vector_R p qs (characterize_consistent_signs_at_roots p qs) = (\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots p qs. z_R I s * rat_of_int (int (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s})))\<close> \<open>vec_of_list (mtx_row_R signs I) \<bullet> construct_lhs_vector_R p qs signs = vec_of_list (mtx_row_R (characterize_consistent_signs_at_roots p qs) I) \<bullet> construct_lhs_vector_R p qs (characterize_consistent_signs_at_roots p qs)\<close> setc1 by linarith
 qed  
 
 lemma matrix_equation_main_step_R:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes I:: "nat list*nat list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes welldefined1: "list_constr (fst I) (length qs)"
   assumes welldefined2: "list_constr (snd I) (length qs)"
   shows "(vec_of_list (mtx_row_R signs I) \<bullet>
           (construct_lhs_vector_R p qs signs)) =  
     construct_NofI_R p (retrieve_polys qs (fst I)) (retrieve_polys qs (snd I))"
 proof -
   show ?thesis
     unfolding construct_NofI_prop_R[OF nonzero]
     using matrix_equation_helper_step_R[OF assms]
     by linarith
 qed
 
 lemma mtx_row_length_R:
   "list_all (\<lambda>r. length r = length signs) (map (mtx_row_R signs) ls)"
   apply (induction ls)
   by (auto simp add: mtx_row_R_def)
 
 (* Shows that as long as we have a "basis" of sign assignments (see assumptions all_info, welldefined), 
   and some other mild assumptions on our inputs (given in nonzero, distinct_signs), the construction 
   will be satisfied *)
 theorem matrix_equation_R:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   fixes subsets:: "(nat list*nat list) list" 
   fixes signs:: "rat list list"
   assumes nonzero: "p\<noteq>0"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes welldefined: "all_list_constr_R (subsets) (length qs)"
   shows "satisfy_equation_R p qs subsets signs"
   unfolding satisfy_equation_R_def matrix_A_R_def
     construct_lhs_vector_R_def construct_rhs_vector_R_def all_list_constr_R_def
   apply (subst mult_mat_vec_of_list)
     apply (auto simp add: mtx_row_length_R intro!: map_vec_vec_of_list_eq_intro)
   using matrix_equation_main_step_R[OF assms(1-3), unfolded construct_lhs_vector_R_def]
   using all_list_constr_R_def in_set_member welldefined by fastforce
 
 (* Prettifying some theorems*)
 
 lemma consistent_signs_at_roots_eq:
   assumes "p \<noteq> 0"
   shows "consistent_signs_at_roots p qs =
          set (characterize_consistent_signs_at_roots p qs)"
   unfolding consistent_signs_at_roots_def characterize_consistent_signs_at_roots_def
     characterize_root_list_p_def
   apply auto
    apply (subst set_sorted_list_of_set)
   using assms poly_roots_finite apply blast
   unfolding sgn_vec_def sgn_def signs_at_def squash_def o_def
   using roots_def apply auto[1]
     by (smt Collect_cong assms image_iff poly_roots_finite roots_def sorted_list_of_set(1))
 
 abbreviation w_vec_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list  \<Rightarrow> rat vec"
   where "w_vec_R \<equiv> construct_lhs_vector_R"
 
 abbreviation v_vec_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat vec"
   where "v_vec_R \<equiv> construct_rhs_vector_R"
 
 abbreviation M_mat_R:: "rat list list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat mat"
   where "M_mat_R \<equiv> matrix_A_R"
 
 theorem matrix_equation_pretty:
   fixes subsets:: "(nat list*nat list) list"
   assumes "p\<noteq>0"
   assumes "distinct signs"
   assumes "consistent_signs_at_roots p qs \<subseteq> set signs"
   assumes "\<And>a b i. (a, b) \<in> set ( subsets) \<Longrightarrow> (i \<in> set a \<or> i \<in> set b) \<Longrightarrow> i < length qs"
   shows "M_mat_R signs subsets *\<^sub>v w_vec_R p qs signs = v_vec_R p qs subsets"
   unfolding satisfy_equation_R_def[symmetric]
   using matrix_equation_R[of p signs qs subsets] assms 
   using consistent_signs_at_roots_eq unfolding all_list_constr_R_def list_constr_def apply (auto)
   by (metis (no_types, lifting) Ball_set in_set_member)
 
 section "Base Case"
 definition satisfies_properties_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat list list \<Rightarrow> rat mat \<Rightarrow> bool"
   where "satisfies_properties_R p qs subsets signs matrix = 
   ( all_list_constr_R subsets (length qs) \<and> well_def_signs (length qs) signs \<and> distinct signs
   \<and> satisfy_equation_R p qs subsets signs \<and>  invertible_mat matrix  \<and> matrix = matrix_A_R signs subsets
   \<and> set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)
   )"
 
 lemma mat_base_case_R:
   shows "matrix_A_R [[1],[0],[-1]] [([], []),([0], []),([], [0])] = (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]])"
   unfolding matrix_A_R_def mtx_row_R_def z_R_def map_sgas_def apply (auto)
   by (simp add: numeral_3_eq_3)
 
 lemma base_case_sgas_R:
   fixes q p:: "real poly"
   assumes nonzero: "p \<noteq> 0"
   shows "set (characterize_consistent_signs_at_roots p [q]) \<subseteq> {[1],[0], [- 1]}"
   unfolding characterize_consistent_signs_at_roots_def signs_at_def  apply (auto)
   by (meson squash_def) 
 
 lemma base_case_sgas_alt_R:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   assumes len1: "length qs = 1"
   assumes nonzero: "p \<noteq> 0"
   shows "set (characterize_consistent_signs_at_roots p qs) \<subseteq> {[1], [0], [- 1]}"
 proof - 
   have ex_q: "\<exists>(q::real poly). qs = [q]" 
     using len1    
     using length_Suc_conv[of qs 0] by auto
   then show ?thesis using base_case_sgas_R nonzero 
     by auto
 qed
 
 lemma base_case_satisfy_equation_R:
   fixes q p:: "real poly"
   assumes nonzero: "p \<noteq> 0"
   shows "satisfy_equation_R p [q] [([], []),([0], []),([], [0])] [[1],[0],[-1]] "
 proof - 
   have h1: "set (characterize_consistent_signs_at_roots p [q]) \<subseteq> {[1], [0],[- 1]}"
     using base_case_sgas_R assms by auto
   have h2: "all_list_constr_R [([], []),([0], []),([], [0])] (Suc 0)" unfolding all_list_constr_R_def
     by (simp add: list_constr_def member_def)
   then show ?thesis using matrix_equation_R[where p = "p", where qs = "[q]", where signs = "[[1],[0],[-1]] ", where subsets = "[([], []),([0], []),([], [0])]"]
       nonzero h1  h2 by auto
 qed
 
 lemma base_case_satisfy_equation_alt_R:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   assumes len1: "length qs = 1"
   assumes nonzero: "p \<noteq> 0"
   shows "satisfy_equation_R p qs [([], []),([0], []),([], [0])] [[1],[0],[-1]]"
 proof - 
   have ex_q: "\<exists>(q::real poly). qs = [q]" 
     using len1    
     using length_Suc_conv[of qs 0] by auto
   then show ?thesis using base_case_satisfy_equation_R nonzero
     by auto
 qed
 
 lemma base_case_matrix_eq:
   fixes q p:: "real poly"
   assumes nonzero: "p \<noteq> 0"
   shows "(mult_mat_vec (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]) (construct_lhs_vector_R p [q] [[1],[0],[-1]]) = 
     (construct_rhs_vector_R p [q] [([], []),([0], []),([], [0])]))"                      
   using mat_base_case_R base_case_satisfy_equation_R unfolding satisfy_equation_R_def
   by (simp add: nonzero)
 
 lemma less_three: "(n::nat) < Suc (Suc (Suc 0)) \<longleftrightarrow> n = 0 \<or> n = 1 \<or> n = 2"
   by auto
 
 lemma inverse_mat_base_case_R:
   shows "inverts_mat (mat_of_rows_list 3  [[1/2, -1/2, 1/2], [0, 1, 0], [1/2, -1/2, -1/2]]::rat mat) (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]::rat mat)"
   unfolding inverts_mat_def mat_of_rows_list_def mat_eq_iff apply auto
   unfolding less_three by (auto simp add: scalar_prod_def)
 
 lemma inverse_mat_base_case_2_R: 
   shows "inverts_mat (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]::rat mat) (mat_of_rows_list 3  [[1/2, -1/2, 1/2], [0, 1, 0], [1/2, -1/2, -1/2]]:: rat mat)"
   unfolding inverts_mat_def mat_of_rows_list_def mat_eq_iff apply auto
   unfolding less_three by (auto simp add: scalar_prod_def)
 
 lemma base_case_invertible_mat_R: 
   shows "invertible_mat (matrix_A_R [[1],[0], [- 1]] [([], []),([0], []),([], [0])])"
   unfolding invertible_mat_def using inverse_mat_base_case_R inverse_mat_base_case_2_R
   apply (auto)
   apply (simp add: mat_base_case mat_of_rows_list_def)
   using mat_base_case_R by auto 
 
 section "Inductive Step"
 
 (***** Need some properties of smashing; smashing signs is just as it was in BKR *****)
 subsection "Lemmas on smashing subsets "
 
 definition subsets_first_component_list::"(nat list*nat list) list \<Rightarrow> nat list list"
   where "subsets_first_component_list I = map (\<lambda>I. (fst I)) I"
 
 definition subsets_second_component_list::"(nat list*nat list) list \<Rightarrow> nat list list"
   where "subsets_second_component_list I = map (\<lambda>I. (snd I)) I"
 
 definition smash_list_list::"('a list*'a list) list \<Rightarrow>  ('a list*'a list) list \<Rightarrow> ('a list*'a list) list"
   where "smash_list_list s1 s2 = concat (map (\<lambda>l1. map (\<lambda>l2. (fst l1 @ fst l2, snd l1 @ snd l2)) s2) s1)"
 
 lemma smash_list_list_property_set:
   fixes l1 l2 :: "('a list*'a list) list"
   fixes a b:: "nat"
   shows "\<forall> (elem :: ('a list*'a list)). (elem \<in> (set (smash_list_list l1 l2)) \<longrightarrow> 
     (\<exists> (elem1:: ('a list*'a list)). \<exists> (elem2:: ('a list*'a list)). 
       (elem1 \<in> set(l1) \<and> elem2 \<in> set(l2) \<and> elem = (fst elem1@ fst elem2, snd elem1 @ snd elem2))))"
 proof clarsimp 
   fix a b 
   assume assum: "(a, b) \<in> set (smash_list_list l1 l2)"
   show "\<exists>aa ba. (aa, ba) \<in> set l1 \<and> (\<exists>ab bb. (ab, bb) \<in> set l2 \<and> a = aa @ ab \<and> b = ba @ bb)"
     using assum unfolding smash_list_list_def 
     apply (auto) by blast 
 qed
 
 
 lemma subsets_smash_property_R:
   fixes subsets1 subsets2 :: "(nat list*nat list) list"
   fixes n:: "nat"
   shows "\<forall> (elem :: nat list*nat list). (List.member (subsets_smash_R n subsets1 subsets2) elem) \<longrightarrow> 
     (\<exists> (elem1::nat list*nat list). \<exists> (elem2::nat list*nat list).
       (elem1 \<in> set(subsets1) \<and> elem2 \<in> set(subsets2) \<and> elem = ((fst elem1) @ (map ((+) n) (fst elem2)), (snd elem1) @ (map ((+) n) (snd elem2)))))"
 proof -
   let ?fst_component2 = "subsets_first_component_list subsets2"
   let ?snd_component2 = "subsets_second_component_list subsets2"
   let ?new_subsets = "map (\<lambda>I. ((map ((+) n)) (fst I),  (map ((+) n)) (snd I))) subsets2"
     (* a slightly unorthodox use of signs_smash, but it closes the proof *)
   have "subsets_smash_R n subsets1 subsets2 = smash_list_list subsets1 ?new_subsets" 
     unfolding subsets_smash_R_def smash_list_list_def apply (auto)
     by (simp add: comp_def) 
   then show ?thesis using smash_list_list_property_set[of subsets1 ?new_subsets] apply (auto)
     using imageE in_set_member set_map smash_list_list_property_set
     by (smt (z3) prod.exhaust_sel)
 qed
 
 (* If subsets for smaller systems are well-defined, then subsets for combined systems are, too *)
 subsection "Well-defined subsets preserved when smashing"
 
 lemma well_def_step_R: 
   fixes qs1 qs2 :: "real poly list"
   fixes subsets1 subsets2 :: "(nat list*nat list) list"
   assumes well_def_subsets1: "all_list_constr_R (subsets1) (length qs1)"
   assumes well_def_subsets2: "all_list_constr_R (subsets2) (length qs2)"
   shows "all_list_constr_R ((subsets_smash_R (length qs1) subsets1 subsets2))
      (length (qs1 @ qs2))"
 proof - 
   let ?n = "(length qs1)"
   have h1: "\<forall>elem.
      List.member (subsets_smash_R ?n subsets1 subsets2) elem \<longrightarrow>
      (\<exists> (elem1::nat list*nat list). \<exists> (elem2::nat list*nat list).
       (elem1 \<in> set(subsets1) \<and> elem2 \<in> set(subsets2) \<and> elem = ((fst elem1) @ (map ((+) ?n) (fst elem2)), (snd elem1) @ (map ((+) ?n) (snd elem2)))))"
     using subsets_smash_property_R by blast
   have h2: "\<forall>elem1 elem2. (elem1 \<in> set subsets1 \<and> elem2 \<in> set subsets2) \<longrightarrow> list_constr ((fst elem1) @ map ((+) (length qs1)) (fst elem2)) (length (qs1 @ qs2))"
   proof clarsimp 
     fix elem1 b elem2 ba
     assume e1: "(elem1, b) \<in> set subsets1"
     assume e2: "(elem2, ba) \<in> set subsets2"
     have h1: "list_constr elem1  (length qs1 + length qs2) " 
     proof - 
       have h1: "list_constr elem1  (length qs1)"  using e1 well_def_subsets1
         unfolding all_list_constr_R_def
         apply (auto) 
         by (simp add: in_set_member) 
       then show ?thesis unfolding list_constr_def
         by (simp add: list.pred_mono_strong) 
     qed
     have h2: "list_constr (map ((+) (length qs1)) elem2) (length qs1 + length qs2)"
     proof - 
       have h1: "list_constr elem2  (length qs2)"  using e2 well_def_subsets2 
         unfolding all_list_constr_R_def
         by (simp add: in_set_member) 
       then show ?thesis unfolding list_constr_def
         by (simp add: list_all_length)
     qed
     show "list_constr (elem1 @ map ((+) (length qs1)) elem2) (length qs1 + length qs2)" 
       using h1 h2 list_constr_append
       by blast 
   qed
   have h3: "\<forall>elem1 elem2. (elem1 \<in> set subsets1 \<and> elem2 \<in> set subsets2) \<longrightarrow> list_constr ((snd elem1) @ map ((+) (length qs1)) (snd elem2)) (length (qs1 @ qs2))"
   proof clarsimp 
     fix elem1 b elem2 ba
     assume e1: "(b, elem1) \<in> set subsets1"
     assume e2: "(ba, elem2) \<in> set subsets2"
     have h1: "list_constr elem1  (length qs1 + length qs2) " 
     proof - 
       have h1: "list_constr elem1  (length qs1)"  using e1 well_def_subsets1
         unfolding all_list_constr_R_def
         apply (auto) 
         by (simp add: in_set_member) 
       then show ?thesis unfolding list_constr_def
         by (simp add: list.pred_mono_strong) 
     qed
     have h2: "list_constr (map ((+) (length qs1)) elem2) (length qs1 + length qs2)"
     proof - 
       have h1: "list_constr elem2  (length qs2)"  using e2 well_def_subsets2 
         unfolding all_list_constr_R_def
         by (simp add: in_set_member) 
       then show ?thesis unfolding list_constr_def
         by (simp add: list_all_length)
     qed
     show "list_constr (elem1 @ map ((+) (length qs1)) elem2) (length qs1 + length qs2)" 
       using h1 h2 list_constr_append
       by blast 
   qed
   show ?thesis using h1 h2 h3 unfolding all_list_constr_def
     by (metis all_list_constr_R_def fst_conv snd_conv) 
 qed
 
 subsection "Consistent Sign Assignments Preserved When Smashing"
 
 lemma subset_helper_R:
   fixes p:: "real poly"
   fixes qs1 qs2 :: "real poly list"
   fixes signs1 signs2 :: "rat list list"
   shows "\<forall> x \<in> set (characterize_consistent_signs_at_roots p (qs1 @ qs2)). 
         \<exists> x1 \<in> set (characterize_consistent_signs_at_roots p qs1). 
         \<exists> x2 \<in> set (characterize_consistent_signs_at_roots p qs2).
         x = x1@x2"
 proof clarsimp 
   fix x
   assume  x_in: "x \<in> set (characterize_consistent_signs_at_roots p (qs1 @ qs2))" 
   have x_in_csv: "x \<in> set(map (consistent_sign_vec (qs1 @ qs2)) (characterize_root_list_p p))"  
     using x_in unfolding characterize_consistent_signs_at_roots_def
     by (smt (z3) consistent_sign_vec_def map_eq_conv o_apply set_remdups signs_at_def squash_def) 
   have csv_hyp: "\<forall>r. consistent_sign_vec (qs1 @ qs2) r = (consistent_sign_vec qs1 r)@(consistent_sign_vec qs2 r)"
     unfolding consistent_sign_vec_def by auto
   have exr_iff: "(\<exists>r \<in> set (characterize_root_list_p p). x = consistent_sign_vec (qs1 @ qs2) r) \<longleftrightarrow> (\<exists>r \<in> set (characterize_root_list_p p). x = (consistent_sign_vec qs1 r)@(consistent_sign_vec qs2 r))"
     using csv_hyp by auto
   have exr: "x \<in> set(map (consistent_sign_vec (qs1 @ qs2)) (characterize_root_list_p p)) \<longrightarrow> (\<exists>r \<in> set (characterize_root_list_p p). x = consistent_sign_vec (qs1 @ qs2) r)"
     by auto
   have mem_list1: "\<forall> r \<in> set (characterize_root_list_p p). (consistent_sign_vec qs1 r) \<in> set(map (consistent_sign_vec qs1) (characterize_root_list_p p))"
     by simp
   have mem_list2: "\<forall> r \<in> set (characterize_root_list_p p). (consistent_sign_vec qs2 r) \<in> set(map (consistent_sign_vec qs2) (characterize_root_list_p p))"
     by simp
   then show "\<exists>x1\<in>set (characterize_consistent_signs_at_roots p qs1).
             \<exists>x2\<in>set (characterize_consistent_signs_at_roots p qs2). x = x1 @ x2"
     using x_in_csv exr mem_list1 mem_list2 characterize_consistent_signs_at_roots_def exr_iff
     using imageE image_eqI map_append set_map set_remdups signs_at_def x_in
     by auto
 qed
 
 lemma subset_step_R:  
   fixes p:: "real poly"
   fixes qs1 qs2 :: "real poly list"
   fixes signs1 signs2 :: "rat list list"
   assumes csa1: "set (characterize_consistent_signs_at_roots p qs1) \<subseteq> set (signs1)"
   assumes csa2: "set (characterize_consistent_signs_at_roots p qs2) \<subseteq> set (signs2)"  
   shows "set (characterize_consistent_signs_at_roots p
           (qs1 @ qs2))
     \<subseteq> set (signs_smash signs1 signs2)"
 proof - 
   have h0: "\<forall> x \<in> set (characterize_consistent_signs_at_roots p (qs1 @ qs2)). \<exists> x1 \<in> set (characterize_consistent_signs_at_roots p qs1). \<exists> x2 \<in> set (characterize_consistent_signs_at_roots p qs2).
      (x = x1@x2)" using subset_helper_R[of p qs1 qs2]
     by blast 
   then have "\<forall>x \<in> set (characterize_consistent_signs_at_roots p (qs1 @ qs2)). 
           x \<in> set (signs_smash (characterize_consistent_signs_at_roots p qs1) 
           (characterize_consistent_signs_at_roots p qs2))"
     unfolding signs_smash_def apply (auto)
     by fastforce 
   then have "\<forall>x \<in> set (characterize_consistent_signs_at_roots p
           (qs1 @ qs2)). x \<in> set (signs_smash signs1 signs2)"
     using csa1 csa2 subset_smash_signs[of _ signs1 _ signs2] apply (auto)
     by blast 
   thus ?thesis
     by blast 
 qed
 
 subsection "Main Results"
 lemma dim_row_matrix_A_R[simp]:
   shows "dim_row (matrix_A_R signs subsets) = length subsets"
   unfolding matrix_A_R_def by auto
 
 lemma dim_col_matrix_A_R[simp]:
   shows "dim_col (matrix_A_R signs subsets) = length signs"
   unfolding matrix_A_R_def by auto
 
 lemma length_subsets_smash_R:
   shows
     "length (subsets_smash_R n subs1 subs2) = length subs1 * length subs2"
   unfolding subsets_smash_R_def length_concat
   by (auto simp add: o_def sum_list_triv)
 
 lemma z_append_R:
   fixes xs:: "(nat list * nat list)"
   assumes "\<And>i. i \<in> set (fst xs) \<Longrightarrow> i  < length as"
   assumes "\<And>i. i \<in> set (snd xs) \<Longrightarrow> i  < length as"
   shows "z_R ((fst xs) @ (map ((+) (length as)) (fst ys)), (snd xs) @ (map ((+) (length as)) (snd ys))) (as @ bs) = z_R xs as * z_R ys bs"
 proof -
   have 1: "map ((!) (as @ bs)) (fst xs) = map ((!) as) (fst xs)"
     unfolding list_eq_iff_nth_eq
     using assms by (auto simp add:nth_append)
   have 2: "map ((!) (as @ bs) \<circ> (+) (length as)) (fst ys) = map ((!) bs) (fst ys)"
     unfolding list_eq_iff_nth_eq
     using assms by auto
   have 3: "map ((!) (as @ bs)) (snd xs) = map ((!) as) (snd xs)"
     unfolding list_eq_iff_nth_eq
     using assms by (auto simp add:nth_append)
   have 4: "map ((!) (as @ bs) \<circ> (+) (length as)) (snd ys) = map ((!) bs) (snd ys)"
     unfolding list_eq_iff_nth_eq
     using assms by auto
   show ?thesis
     unfolding z_R_def apply auto
     unfolding 1 2 3 4 apply (auto)
     by (smt (z3) assms(1) comp_apply length_map map_append map_eq_conv map_sgas_def nth_append nth_append_length_plus) 
 qed
 
 (* Shows that the matrix of a smashed system is the Kronecker product of the matrices of the two
   systems being combined *)
 lemma matrix_construction_is_kronecker_product_R: 
   fixes qs1 :: "real poly list"
   fixes subs1 subs2 :: "(nat list*nat list) list"
   fixes signs1 signs2 :: "rat list list"
     (* n1 is the number of polynomials in the "1" sets *)
   assumes "\<And>l i. l \<in> set subs1 \<Longrightarrow> (i \<in> set (fst l) \<or> i \<in> set (snd l)) \<Longrightarrow> i < n1"
   assumes "\<And>j. j \<in> set signs1 \<Longrightarrow> length j = n1"
   shows "(matrix_A_R (signs_smash signs1 signs2) (subsets_smash_R n1 subs1 subs2)) =
     kronecker_product (matrix_A_R signs1 subs1) (matrix_A_R signs2 subs2)"
   unfolding mat_eq_iff dim_row_matrix_A_R dim_col_matrix_A_R
     length_subsets_smash_R length_signs_smash dim_kronecker
 proof safe
   fix i j
   assume i: "i < length subs1 * length subs2"
   assume j: "j < length signs1 * length signs2"
 
   have ld: "i div length subs2 < length subs1"
     "j div length signs2 < length signs1"
     using i j less_mult_imp_div_less by auto
   have lm: "i mod length subs2 < length subs2"
     "j mod length signs2 < length signs2"
     using i j less_mult_imp_mod_less by auto
 
   have n1: "n1 = length (signs1 ! (j div length signs2))"
     using assms(2) ld(2) nth_mem by blast
 
   have 1: "matrix_A_R (signs_smash signs1 signs2) (subsets_smash_R n1 subs1 subs2) $$ (i, j) =
     z_R (subsets_smash_R n1 subs1 subs2 ! i) (signs_smash signs1 signs2 ! j)"
     unfolding mat_of_rows_list_def matrix_A_R_def mtx_row_R_def
     using i j by (auto simp add: length_signs_smash length_subsets_smash_R)
   have 2: " ... = z_R ((fst (subs1 ! (i div length subs2)) @ map ((+) n1) (fst(subs2 ! (i mod length subs2)))),
   (snd (subs1 ! (i div length subs2)) @ map ((+) n1) (snd (subs2 ! (i mod length subs2)))))
      (signs1 ! (j div length signs2) @ signs2 ! (j mod length signs2))"
     unfolding signs_smash_def subsets_smash_R_def
     apply (subst length_eq_concat)
     using i apply (auto simp add: mult.commute)
     apply (subst length_eq_concat)
     using j apply (auto simp add: mult.commute)
     using ld lm by auto
   have 3: "... =
   z_R (subs1 ! (i div length subs2)) (signs1 ! (j div length signs2)) *
   z_R (subs2 ! (i mod length subs2)) (signs2 ! (j mod length signs2))"
     unfolding n1
     apply (subst z_append_R)
     apply (auto simp add: n1[symmetric])
     using assms(1) ld(1) nth_mem
     apply blast
     using assms(1) ld(1) nth_mem by blast
   have 4: "kronecker_product (matrix_A_R signs1 subs1) (matrix_A_R signs2 subs2) $$ (i,j) =
     z_R (subs1 ! (i div length subs2))
      (signs1 ! (j div length signs2)) *
     z_R (subs2 ! (i mod length subs2))
      (signs2 ! (j mod length signs2))"
     unfolding kronecker_product_def matrix_A_R_def mat_of_rows_list_def mtx_row_R_def
     using i j apply (auto simp add: Let_def)
     apply (subst index_mat(1)[OF ld])
     apply (subst index_mat(1)[OF lm])
     using ld lm by auto
   show "matrix_A_R (signs_smash signs1 signs2) (subsets_smash_R n1 subs1 subs2) $$ (i, j) =
         kronecker_product (matrix_A_R signs1 subs1) (matrix_A_R signs2 subs2) $$ (i, j)"
     using 1 2 3 4 by auto 
 qed
 
 (* Given that two smaller systems satisfy some mild constraints, show that their combined system
   (after smashing the signs and subsets) satisfies the matrix equation, and that the matrix of the
   combined system is invertible. *)
 lemma inductive_step_R:
   fixes p:: "real poly"
   fixes qs1 qs2 :: "real poly list"
   fixes subsets1 subsets2 :: "(nat list*nat list) list"
   fixes signs1 signs2 :: "rat list list"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes nontriv2: "length qs2 > 0"
   assumes welldefined_signs1: "well_def_signs (length qs1) signs1"
   assumes welldefined_signs2: "well_def_signs (length qs2) signs2"
   assumes distinct_signs1: "distinct signs1"
   assumes distinct_signs2: "distinct signs2"
   assumes all_info1: "set (characterize_consistent_signs_at_roots p qs1) \<subseteq> set(signs1)"
   assumes all_info2: "set (characterize_consistent_signs_at_roots p qs2) \<subseteq> set(signs2)"
   assumes welldefined_subsets1: "all_list_constr_R (subsets1) (length qs1)"
   assumes welldefined_subsets2: "all_list_constr_R (subsets2) (length qs2)"
   assumes invertibleMtx1: "invertible_mat (matrix_A_R signs1 subsets1)"
   assumes invertibleMtx2: "invertible_mat (matrix_A_R signs2 subsets2)"
   shows "satisfy_equation_R p (qs1@qs2) (subsets_smash_R (length qs1) subsets1 subsets2) (signs_smash signs1 signs2) 
         \<and> invertible_mat (matrix_A_R (signs_smash signs1 signs2) (subsets_smash_R (length qs1) subsets1 subsets2))"
 proof - 
   have h1: "invertible_mat (matrix_A_R (signs_smash signs1 signs2) (subsets_smash_R (length qs1) subsets1 subsets2))"
     using matrix_construction_is_kronecker_product_R
       kronecker_invertible invertibleMtx1 invertibleMtx2
       welldefined_subsets1 welldefined_subsets2 unfolding all_list_constr_R_def list_constr_def
     using Ball_set in_set_member well_def_signs_def welldefined_signs1 in_set_conv_nth list_all_length
     apply (auto)
     
     by (smt (z3) Ball_set kronecker_invertible member_def)
   have h2a: "distinct (signs_smash signs1 signs2)" 
     using distinct_signs1 distinct_signs2 welldefined_signs1 welldefined_signs2 nontriv1 nontriv2 
       distinct_step by auto
   have h2c: "all_list_constr_R ((subsets_smash_R (length qs1) subsets1 subsets2)) (length (qs1@qs2))" 
     using well_def_step_R
       welldefined_subsets1 welldefined_subsets2
     by blast
   have h2d: "set (characterize_consistent_signs_at_roots p (qs1@qs2)) \<subseteq> set(signs_smash signs1 signs2)" 
     using subset_step_R all_info1 all_info2
     by simp 
   have h2: "satisfy_equation_R p (qs1@qs2) (subsets_smash_R (length qs1) subsets1 subsets2) (signs_smash signs1 signs2)"
     using matrix_equation_R[where p="p", where qs="qs1@qs2", where subsets = "subsets_smash_R (length qs1) subsets1 subsets2",
         where signs = "signs_smash signs1 signs2"] 
         h2a h2c h2d apply (auto) using nonzero by blast
   show ?thesis using h1 h2 by blast
 qed
 
 section "Reduction Step Proofs"
   (* Some definitions *)
 definition get_matrix_R:: "(rat mat \<times> ((nat list*nat list) list \<times> rat list list)) \<Rightarrow> rat mat"
   where "get_matrix_R data = fst(data)"
 
 definition get_subsets_R:: "(rat mat \<times> ((nat list*nat list) list \<times> rat list list)) \<Rightarrow>  (nat list*nat list) list"
   where "get_subsets_R data = fst(snd(data))"
 
 definition get_signs_R:: "(rat mat \<times> ((nat list*nat list) list \<times> rat list list)) \<Rightarrow> rat list list"
   where "get_signs_R data = snd(snd(data))"
 
 definition reduction_signs_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat mat \<Rightarrow> rat list list" 
   where "reduction_signs_R p qs signs subsets matr = 
     (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets matr)))"
 
 definition reduction_subsets_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat mat \<Rightarrow> (nat list*nat list) list" 
   where "reduction_subsets_R p qs signs subsets matr = 
     (take_indices subsets (rows_to_keep (reduce_mat_cols matr (solve_for_lhs_R p qs subsets matr))))"
 
 (* Some basic lemmas *)
 lemma reduction_signs_is_get_signs_R: "reduction_signs_R p qs signs subsets m =  get_signs_R (reduce_system_R p (qs, (m, (subsets, signs))))"
   unfolding reduction_signs_R_def get_signs_R_def apply (simp)
   using reduction_step_R.elims snd_conv
   by metis 
 
 lemma reduction_subsets_is_get_subsets_R: "reduction_subsets_R p qs signs subsets m =  get_subsets_R (reduce_system_R p (qs, (m, (subsets, signs))))"
   unfolding reduction_subsets_R_def get_subsets_R_def
   using reduce_system.simps reduction_step.elims fst_conv snd_conv
   by (metis reduce_system_R.simps reduction_step_R.simps) 
 
 subsection "Showing sign conditions preserved when reducing"
 
 lemma take_indices_lem_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes arb_list :: "('a list*'a list) list"
   fixes index_list :: "nat list" 
   fixes n:: "nat"
   assumes lest: "n < length (take_indices arb_list index_list)"
   assumes well_def: "\<forall>q.(List.member index_list q \<longrightarrow> q < length arb_list)"
   shows "\<exists>k<length arb_list.
             (take_indices arb_list index_list) ! n =  arb_list ! k"
   using lest well_def unfolding take_indices_def apply (auto)
   by (metis member_def nth_mem)
 
 lemma size_of_mat_R:
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   shows "(matrix_A_R signs subsets) \<in> carrier_mat (length subsets) (length signs)"
   unfolding matrix_A_R_def carrier_mat_def by auto
 
 lemma size_of_lhs_R: 
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes signs :: "rat list list" 
   shows "dim_vec (construct_lhs_vector_R p qs signs) = length signs"
   unfolding construct_lhs_vector_R_def
   by simp
 
 lemma size_of_rhs_R: 
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list" 
   shows "dim_vec (construct_rhs_vector_R p qs subsets) = length subsets"
   unfolding construct_rhs_vector_R_def
   by simp
 
 lemma same_size_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes invertible_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "length subsets = length signs"
   using invertible_mat unfolding invertible_mat_def
   using size_of_mat_R[of signs subsets] size_of_lhs_R[of p qs signs] size_of_rhs_R[of p qs subsets]
   by simp
 
 lemma construct_lhs_matches_solve_for_lhs_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes match: "satisfy_equation_R p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "(construct_lhs_vector_R p qs signs) = solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)"
 proof -
   have matrix_equation_hyp: "(mult_mat_vec (matrix_A_R signs subsets) (construct_lhs_vector_R p qs signs) = (construct_rhs_vector_R p qs subsets))"
     using match unfolding satisfy_equation_R_def by blast
   then have eqn_hyp: " ((matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) *\<^sub>v (mult_mat_vec (matrix_A_R signs subsets) (construct_lhs_vector_R p qs signs)) = 
       mult_mat_vec (matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) (construct_rhs_vector_R p qs subsets))"
     using invertible_mat 
     by (simp add: matrix_equation_hyp) 
   have match_hyp: "length subsets = length signs" using same_size_R invertible_mat by auto 
   then have dim_hyp1: "matrix_A_R signs subsets \<in> carrier_mat (length signs) (length signs)"
     using size_of_mat
     by auto 
   then have dim_hyp2: "matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets)) \<in> carrier_mat (length signs) (length signs)"
     using invertible_mat dim_invertible
     by blast 
   have mult_assoc_hyp: "((matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) *\<^sub>v (mult_mat_vec (matrix_A_R signs subsets) (construct_lhs_vector_R p qs signs)))
     = (((matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) * (matrix_A_R signs subsets)) *\<^sub>v  (construct_lhs_vector_R p qs signs))"
     using mult_assoc dim_hyp1 dim_hyp2 size_of_lhs_R by auto
   have cancel_helper: "(((matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) * (matrix_A_R signs subsets)) *\<^sub>v  (construct_lhs_vector_R p qs signs))
   = (1\<^sub>m (length signs)) *\<^sub>v   (construct_lhs_vector_R p qs signs)"
     using invertible_means_mult_id[where A= "matrix_A_R signs subsets"] dim_hyp1
     by (simp add: invertible_mat match_hyp) 
   then have cancel_hyp: "(((matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) * (matrix_A_R signs subsets)) *\<^sub>v  (construct_lhs_vector_R p qs signs))
   = (construct_lhs_vector_R p qs signs)"
     apply (auto)
     by (metis carrier_vec_dim_vec one_mult_mat_vec size_of_lhs_R)
   then have mult_hyp: "((matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) *\<^sub>v (mult_mat_vec (matrix_A_R signs subsets) (construct_lhs_vector_R p qs signs)))
     = (construct_lhs_vector_R p qs signs)"
     using mult_assoc_hyp cancel_hyp  
     by simp
   then have "(construct_lhs_vector_R p qs signs) =  (mult_mat_vec (matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets))) (construct_rhs_vector_R p qs subsets)) "
     using eqn_hyp
     by simp 
   then show ?thesis
     unfolding solve_for_lhs_R_def
     by (simp add: mat_inverse_same)
 qed
 
 (* Then show that dropping columns doesn't affect the consistent sign assignments *)
 lemma reduction_doesnt_break_things_signs_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(reduction_signs_R p qs signs subsets (matrix_A_R signs subsets))"
 proof - 
   have dim_hyp2: "matr_option (dim_row (matrix_A_R signs subsets))
      (mat_inverse (matrix_A_R signs subsets)) \<in> carrier_mat (length signs) (length signs)"
     using invertible_mat dim_invertible
     using same_size_R by fastforce 
   have "(construct_lhs_vector_R p qs signs) = solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)"
     using construct_lhs_matches_solve_for_lhs_R assms by auto
   then have "(solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) =
    vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) signs))" 
     using construct_lhs_vector_cleaner_R assms
     by (metis (mono_tags, lifting) list.map_cong map_map o_apply of_int_of_nat_eq)
   then have "\<forall> n < (dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))). 
        (((solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) $ n = 0) \<longrightarrow>
        (nth signs n) \<notin> set (characterize_consistent_signs_at_roots p qs))"
   proof - 
     have h0: "\<forall> n < (dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))). 
        (((solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) $ n = 0) \<longrightarrow> 
        rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = (nth signs n)}) = 0)"
       by (metis (mono_tags, lifting) \<open>construct_lhs_vector_R p qs signs = solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)\<close> construct_lhs_vector_clean_R nonzero of_nat_0_eq_iff of_rat_of_nat_eq size_of_lhs_R)
     have h1: "\<forall> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}) = 0 \<longrightarrow> 
         (\<nexists> x. poly p x = 0 \<and> consistent_sign_vec qs x = w))"
     proof clarsimp 
       fix x
       assume card_asm: "card {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = consistent_sign_vec qs x} = 0"
       assume zero_asm: "poly p x = 0"
       have card_hyp: "{xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = consistent_sign_vec qs x} = {}"
         using card_eq_0_iff
         using card_asm nonzero poly_roots_finite
         by (metis (full_types) finite_Collect_conjI)
       have "x \<in> {xa. poly p xa = 0 \<and> consistent_sign_vec qs xa = consistent_sign_vec qs x}"
         using zero_asm by auto
       thus "False" using card_hyp
         by blast
     qed
     have h2: "\<And> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}) = 0 \<Longrightarrow>
        (\<not>List.member (characterize_consistent_signs_at_roots p qs) w))"
     proof clarsimp
       fix w
       assume card_asm: "card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w} = 0"
       assume mem_asm: "List.member (characterize_consistent_signs_at_roots p qs) w"
       have h0: "\<nexists> x. poly p x = 0 \<and> consistent_sign_vec qs x = w" using h1 card_asm
         by (simp add: h1)
       have h1: "\<exists> x. poly p x = 0 \<and> consistent_sign_vec qs x = w" using mem_asm 
         unfolding characterize_consistent_signs_at_roots_def characterize_root_list_p_def
       proof -
         have "w \<in> Collect (List.member (remdups (map (consistent_sign_vec qs) (sorted_list_of_set {r. poly p r = 0}))))"
           using characterize_consistent_signs_at_roots_def mem_asm characterize_root_list_p_def
           by (smt (verit, ccfv_SIG) consistent_sign_vec_def h0 imageE in_set_member list.set_map map_cong mem_Collect_eq nonzero o_apply poly_roots_finite set_remdups set_sorted_list_of_set signs_at_def squash_def)
         then have f1: "w \<in> set (map (consistent_sign_vec qs) (sorted_list_of_set {r. poly p r = 0}))"
           by (metis (no_types) in_set_member mem_Collect_eq set_remdups)
         have "finite {r. poly p r = 0}"
           using nonzero poly_roots_finite by blast
         then show ?thesis
           using f1 by auto
       qed
       show "False" using h0 h1 by auto
     qed
     then have h3: "\<forall> w. rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}) = 0 \<longrightarrow> 
         w \<notin> set (characterize_consistent_signs_at_roots p qs)"
       by (simp add: in_set_member)
     show ?thesis using h0 h3
       by blast 
   qed
   then have "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set (take_indices signs
              (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))"
     using all_info
       reduction_signs_set_helper_lemma[where A = "set (characterize_consistent_signs_at_roots p qs)", where B = "signs",
       where C = "(solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))"]
     using dim_hyp2 solve_for_lhs_R_def by (simp add: mat_inverse_same)
   then show ?thesis unfolding reduction_signs_R_def by auto
 qed
 
 lemma reduction_deletes_bad_sign_conds_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "set (characterize_consistent_signs_at_roots p qs) = set(reduction_signs_R p qs signs subsets (matrix_A_R signs subsets))"
 proof - 
   have dim_hyp2: "matr_option (dim_row (matrix_A_R signs subsets))
        (mat_inverse (matrix_A_R signs subsets)) \<in> carrier_mat (length signs) (length signs)"
     using invertible_mat dim_invertible
     using same_size_R by fastforce 
   have supset: "set (characterize_consistent_signs_at_roots p qs) \<supseteq> set(reduction_signs_R p qs signs subsets (matrix_A_R signs subsets))" 
   proof - 
     have "(construct_lhs_vector_R p qs signs) = solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)"
       using construct_lhs_matches_solve_for_lhs_R assms by auto
     then have "(solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) =
        vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) signs))" 
       using construct_lhs_vector_cleaner_R assms
       by (metis (mono_tags, lifting) list.map_cong map_map o_apply of_int_of_nat_eq)
     then have "\<forall> n < (dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))). 
            (((solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) $ n \<noteq> 0) \<longrightarrow>
            (nth signs n) \<in> set (characterize_consistent_signs_at_roots p qs))"
     proof - 
       have h0: "\<forall> n < (dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))). 
            (((solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) $ n = 0) \<longrightarrow> 
            rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = (nth signs n)}) = 0)"
         by (simp add: \<open>solve_for_lhs_R p qs subsets (M_mat_R signs subsets) = vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) signs))\<close> vec_of_list_index)
       have h1: "\<forall> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}) \<noteq> 0 \<longrightarrow> 
             (\<exists> x. poly p x = 0 \<and> consistent_sign_vec qs x = w))"
       proof clarsimp 
         fix w
         assume card_asm: "0 < card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}"
         show "\<exists>x. poly p x = 0 \<and> consistent_sign_vec qs x = w"
           by (metis (mono_tags, lifting) Collect_empty_eq card_asm card_eq_0_iff gr_implies_not0)
       qed
       have h2: "\<And> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}) \<noteq> 0 \<Longrightarrow>
            (List.member (characterize_consistent_signs_at_roots p qs) w))"
       proof clarsimp 
         fix w
         assume card_asm: " 0 < card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}"
         have h0: "\<exists>x. poly p x = 0 \<and> consistent_sign_vec qs x = w"
           using card_asm
           by (simp add: h1) 
         then show "List.member (characterize_consistent_signs_at_roots p qs) w" 
           unfolding characterize_consistent_signs_at_roots_def
           using in_set_member nonzero poly_roots_finite characterize_root_list_p_def
           by (smt (verit) characterize_consistent_signs_at_roots_def in_set_R mem_Collect_eq)
       qed
       then have h3: "\<forall> w. rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec qs x = w}) \<noteq> 0 \<longrightarrow> 
             w \<in> set (characterize_consistent_signs_at_roots p qs)"
         by (simp add: in_set_member)
       show ?thesis using h0 h3
         by (metis (no_types, lifting) \<open>solve_for_lhs_R p qs subsets (matrix_A_R signs subsets) = vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec qs x = s}) signs))\<close> dim_vec_of_list length_map nth_map vec_of_list_index)
     qed
     then have "set (take_indices signs
                  (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) \<subseteq>
               set (characterize_consistent_signs_at_roots p qs)"
       using all_info
         reduction_signs_set_helper_lemma2[where A = "set (characterize_consistent_signs_at_roots p qs)", where B = "signs",
         where C = "(solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))"]
       using distinct_signs dim_hyp2 solve_for_lhs_R_def
       by (simp add: mat_inverse_same)
     then show ?thesis unfolding reduction_signs_R_def by auto
   qed
   have subset: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(reduction_signs_R p qs signs subsets (matrix_A_R signs subsets))" 
     using reduction_doesnt_break_things_signs_R[of p qs signs subsets] assms
     by blast 
   then show ?thesis using supset subset by auto 
 qed
 
 
 theorem reduce_system_sign_conditions_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "set (get_signs_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs))))) = set (characterize_consistent_signs_at_roots p qs)"
   unfolding get_signs_R_def
   using reduction_deletes_bad_sign_conds_R[of p qs signs subsets] apply (auto)
   apply (simp add: all_info distinct_signs match nonzero reduction_signs_def welldefined_signs1)
   using nonzero invertible_mat snd_conv
   apply (metis reduction_signs_R_def)
   by (metis all_info distinct_signs invertible_mat match nonzero reduction_signs_R_def snd_conv welldefined_signs1)
 
 subsection "Showing matrix equation preserved when reducing"
 
 lemma reduce_system_matrix_equation_preserved_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs: "well_def_signs (length qs) signs"
   assumes welldefined_subsets: "all_list_constr_R (subsets) (length qs)"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "satisfy_equation_R p qs (get_subsets_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
   (get_signs_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))"
 proof - 
   have poly_type_hyp: "p \<noteq> 0" using nonzero by auto
   have distinct_signs_hyp: "distinct (snd (snd (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs))))))" 
   proof - 
     let ?sym = "(find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
     have h1: "\<forall> i < length (take_indices signs ?sym). \<forall>j < length(take_indices signs ?sym).
       i \<noteq> j \<longrightarrow> nth (take_indices signs ?sym) i \<noteq> nth (take_indices signs ?sym) j" 
       using distinct_signs unfolding take_indices_def 
     proof clarsimp 
       fix i
       fix j
       assume "distinct signs"
       assume "i < length
                 (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
       assume "j < length
                 (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
       assume neq_hyp: "i \<noteq> j"
       assume "signs ! (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets 
               (matrix_A_R signs subsets)) ! i) =
            signs ! (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets 
               (matrix_A_R signs subsets)) ! j)"
       have h1: "find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets 
               (matrix_A_R signs subsets)) ! i \<noteq> find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets 
               (matrix_A_R signs subsets)) ! j"
         unfolding find_nonzeros_from_input_vec_def using neq_hyp
         by (metis \<open>i < length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> \<open>j < length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> distinct_conv_nth distinct_filter distinct_upt find_nonzeros_from_input_vec_def) 
       then show "False" using distinct_signs
       proof -
         have f1: "\<forall>p ns n. ((n::nat) \<in> {n \<in> set ns. p n}) = (n \<in> set ns \<and> n \<in> Collect p)"
           by simp
         then have f2: "filter (\<lambda>n. solve_for_lhs_R p qs subsets (matrix_A_R signs subsets) $ n \<noteq> 0) [0..<dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))] ! i \<in> set [0..<length signs]"
           by (metis (full_types) \<open>i < length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> construct_lhs_matches_solve_for_lhs_R find_nonzeros_from_input_vec_def invertible_mat match nth_mem set_filter size_of_lhs_R)
         have "filter (\<lambda>n. solve_for_lhs_R p qs subsets (matrix_A_R signs subsets) $ n \<noteq> 0) [0..<dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))] ! j \<in> set [0..<length signs]"
           using f1 by (metis (full_types) \<open>j < length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> construct_lhs_matches_solve_for_lhs_R find_nonzeros_from_input_vec_def invertible_mat match nth_mem set_filter size_of_lhs_R)
         then show ?thesis
           using f2 by (metis \<open>signs ! (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) ! i) = signs ! (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) ! j)\<close> atLeastLessThan_iff distinct_conv_nth distinct_signs find_nonzeros_from_input_vec_def h1 set_upt)
       qed
     qed
     then have "distinct (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))"
       using distinct_conv_nth by blast 
     then show ?thesis
       using get_signs_R_def reduction_signs_R_def reduction_signs_is_get_signs_R by auto 
   qed
   have all_info_hyp: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(snd (snd (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs))))))"
     using reduce_system_sign_conditions_R assms unfolding get_signs_R_def by auto
   have welldefined_hyp: "all_list_constr_R (fst (snd (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))) (length qs)"
     using welldefined_subsets rows_to_keep_lem
     unfolding all_list_constr_R_def List.member_def list_constr_def list_all_def
     apply (auto simp add: Let_def take_indices_def take_cols_from_matrix_def)
     using nth_mem
     apply (smt (z3) mat_of_cols_carrier(2) rows_to_keep_lem)
     by (smt (z3) mat_of_cols_carrier(2) nth_mem rows_to_keep_lem)
   then show ?thesis using poly_type_hyp distinct_signs_hyp all_info_hyp  welldefined_hyp
     using matrix_equation_R unfolding get_subsets_R_def get_signs_R_def
     by blast 
 qed
 
 (* Show that we are tracking the correct matrix in the algorithm *)
 subsection "Showing matrix preserved"
 lemma reduce_system_matrix_signs_helper_aux_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length signs"
   assumes nonzero: "p \<noteq> 0"
   shows "alt_matrix_A_R (take_indices signs S) subsets = take_cols_from_matrix (alt_matrix_A_R signs subsets) S"
 proof - 
   have h0a: "dim_col (take_cols_from_matrix (alt_matrix_A_R signs subsets) S) = length (take_indices signs S)" 
     unfolding take_cols_from_matrix_def apply (auto) unfolding take_indices_def by auto
   have h0: "\<forall>i < length (take_indices signs S). (col (alt_matrix_A_R (take_indices signs S) subsets ) i = 
 col (take_cols_from_matrix (alt_matrix_A_R signs subsets) S) i)" 
   proof clarsimp
     fix i
     assume asm: "i < length (take_indices signs S)"
     have i_lt: "i < length (map ((!) (cols (alt_matrix_A_R signs subsets))) S)" using asm
       apply (auto) unfolding take_indices_def by auto
     have h0: " vec (length subsets) (\<lambda>j. z_R (subsets ! j) (map ((!) signs) S ! i)) = 
       vec (length subsets) (\<lambda>j. z_R (subsets ! j) (signs ! (S ! i)))" using nth_map
       by (metis \<open>i < length (take_indices signs S)\<close> length_map take_indices_def) 
     have dim: "(map ((!) (cols (alt_matrix_A_R signs subsets))) S) ! i \<in> carrier_vec (dim_row (alt_matrix_A_R signs subsets))"
     proof - 
       have "dim_col (alt_matrix_A_R signs subsets) = length (signs)"
         by (simp add: alt_matrix_A_R_def) 
       have well_d: "S ! i < length (signs)" using well_def_h
         using i_lt in_set_member by fastforce 
       have 
         map_eq: "(map ((!) (cols (alt_matrix_A_R signs subsets))) S) ! i  = nth (cols (alt_matrix_A_R signs subsets))  (S ! i)"
         using i_lt by auto
       have "nth (cols (alt_matrix_A_R signs subsets))  (S ! i) \<in> carrier_vec (dim_row (alt_matrix_A_R signs subsets))"
         using col_dim unfolding cols_def using nth_map well_d
         by (simp add: \<open>dim_col (alt_matrix_A_R signs subsets) = length signs\<close>) 
       then show ?thesis using map_eq  by auto
     qed
     have h1: "col (take_cols_from_matrix (alt_matrix_A_R signs subsets) S) i = 
       col (mat_of_cols (dim_row (alt_matrix_A_R signs subsets)) (map ((!) (cols (alt_matrix_A_R signs subsets))) S)) i "
       by (simp add: take_cols_from_matrix_def take_indices_def)
     have h2: "col (mat_of_cols (dim_row (alt_matrix_A_R signs subsets)) (map ((!) (cols (alt_matrix_A_R signs subsets))) S)) i 
       = nth (map ((!) (cols (alt_matrix_A_R signs subsets))) S) i " 
       using dim i_lt asm col_mat_of_cols[where j = "i", where n = "(dim_row (alt_matrix_A_R signs subsets))",
           where vs = "(map ((!) (cols (alt_matrix_A_R signs subsets))) S)"]
       by blast 
     have h3: "col (take_cols_from_matrix (alt_matrix_A_R signs subsets) S) i = (col (alt_matrix_A_R signs subsets) (S !i))"
       using h1 h2 apply (auto)
       by (metis alt_matrix_char_R asm cols_nth dim_col_mat(1) in_set_member length_map mat_of_rows_list_def matrix_A_R_def nth_map nth_mem take_indices_def well_def_h)
     have "vec (length subsets) (\<lambda>j. z_R (subsets ! j) (signs ! (S ! i))) = (col (alt_matrix_A_R signs subsets) (S !i))"
       by (metis asm in_set_member length_map nth_mem signs_are_cols_R take_indices_def well_def_h)
     then have "vec (length subsets) (\<lambda>j. z_R (subsets ! j) (take_indices signs S ! i)) =
       col (take_cols_from_matrix (alt_matrix_A_R signs subsets) S) i "
       using h0 h3
       by (simp add: take_indices_def) 
     then show "col (alt_matrix_A_R (take_indices signs S) subsets) i =
          col (take_cols_from_matrix (alt_matrix_A_R signs subsets) S) i "
       using asm signs_are_cols_R[where signs = "(take_indices signs S)", where subsets = "subsets"] 
       by auto
   qed
   then show ?thesis   unfolding alt_matrix_A_R_def take_cols_from_matrix_def apply (auto) 
     using h0a mat_col_eqI
     by (metis alt_matrix_A_R_def dim_col_mat(1) dim_row_mat(1) h0 mat_of_cols_def take_cols_from_matrix_def) 
 qed
 
 
 lemma reduce_system_matrix_signs_helper_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length signs"
   assumes nonzero: "p \<noteq> 0"
   shows "matrix_A_R (take_indices signs S) subsets = take_cols_from_matrix (matrix_A_R signs subsets) S"
   using reduce_system_matrix_signs_helper_aux_R alt_matrix_char_R assms by auto
 
 lemma reduce_system_matrix_subsets_helper_aux_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list* nat list) list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes inv: "length subsets \<ge> length signs"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length subsets"
   assumes nonzero: "p \<noteq> 0"
   shows "alt_matrix_A_R signs (take_indices subsets S) = take_rows_from_matrix (alt_matrix_A_R signs subsets) S"
 proof - 
   have h0a: "dim_row (take_rows_from_matrix (alt_matrix_A_R signs subsets) S) = length (take_indices subsets S)" 
     unfolding take_rows_from_matrix_def apply (auto) unfolding take_indices_def by auto
   have h0: "\<forall>i < length (take_indices subsets S). (row (alt_matrix_A_R signs (take_indices subsets S) ) i = 
 row (take_rows_from_matrix (alt_matrix_A_R signs subsets) S) i)" 
   proof clarsimp
     fix i
     assume asm: "i < length (take_indices subsets S)"
     have i_lt: "i < length (map ((!) (rows (alt_matrix_A_R signs subsets))) S)" using asm
       apply (auto) unfolding take_indices_def by auto
     have h0: "row (take_rows_from_matrix (alt_matrix_A_R signs subsets) S) i =
     row (mat_of_rows (dim_col (alt_matrix_A_R signs subsets)) (map ((!) (rows (alt_matrix_A_R signs subsets))) S)) i "
       unfolding take_rows_from_matrix_def take_indices_def by auto
     have dim: "(map ((!) (rows (alt_matrix_A_R signs subsets))) S) ! i \<in> carrier_vec (dim_col (alt_matrix_A_R signs subsets))"
     proof - 
       have "dim_col (alt_matrix_A_R signs subsets) = length (signs)"
         by (simp add: alt_matrix_A_R_def) 
       then have lenh: "dim_col (alt_matrix_A_R signs subsets) \<le> length (subsets)"
         using assms
         by auto 
       have well_d: "S ! i < length (subsets)" using well_def_h
         using i_lt in_set_member by fastforce 
       have 
         map_eq: "(map ((!) (rows (alt_matrix_A_R signs subsets))) S) ! i  = nth (rows (alt_matrix_A_R signs subsets))  (S ! i)"
         using i_lt by auto
       have "nth (rows (alt_matrix_A_R signs subsets))  (S ! i) \<in> carrier_vec (dim_col (alt_matrix_A_R signs subsets))"
         using col_dim unfolding rows_def using nth_map well_d
         using lenh
         by (simp add: alt_matrix_A_R_def) 
       then show ?thesis using map_eq unfolding alt_matrix_A_R_def by auto
     qed
     have h1: " row (mat_of_rows (dim_col (alt_matrix_A_R signs subsets)) (map ((!) (rows (alt_matrix_A_R signs subsets))) S)) i
       = (row  (alt_matrix_A_R signs subsets) (S ! i)) "
       using dim i_lt mat_of_rows_row[where i = "i", where n = "(dim_col (alt_matrix_A_R signs subsets))",
           where vs = "(map ((!) (rows (alt_matrix_A_R signs subsets))) S)"]
       using alt_matrix_char_R in_set_member nth_mem well_def_h
       by fastforce
     have "row (alt_matrix_A_R signs (take_indices subsets S) ) i = (row  (alt_matrix_A_R signs subsets) (S ! i))"
       using subsets_are_rows_R
     proof -
       have f1: "i < length S"
         by (metis (no_types) asm length_map take_indices_def)
       then have "List.member S (S ! i)"
         by (meson in_set_member nth_mem)
       then show ?thesis
         using f1 
         by (simp add: \<open>\<And>subsets signs. \<forall>i<length subsets. row (alt_matrix_A_R signs subsets) i = vec (length signs) (\<lambda>j. z_R (subsets ! i) (signs ! j))\<close> take_indices_def well_def_h)
     qed 
     then show "(row (alt_matrix_A_R signs (take_indices subsets S) ) i = 
       row (take_rows_from_matrix (alt_matrix_A_R signs subsets) S) i)" 
       using h0 h1 unfolding take_indices_def by auto
   qed
   then show ?thesis  unfolding alt_matrix_A_R_def take_rows_from_matrix_def apply (auto) 
     using eq_rowI
     by (metis alt_matrix_A_R_def dim_col_mat(1) dim_row_mat(1) h0 h0a mat_of_rows_def take_rows_from_matrix_def) 
 qed
 
 
 lemma reduce_system_matrix_subsets_helper_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes nonzero: "p \<noteq> 0"
   assumes inv: "length subsets \<ge> length signs"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length subsets"
   shows "matrix_A_R signs (take_indices subsets S) = take_rows_from_matrix (matrix_A_R signs subsets) S"
   using assms reduce_system_matrix_subsets_helper_aux_R alt_matrix_char_R
   by auto
 
 lemma reduce_system_matrix_match_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   assumes inv: "invertible_mat (matrix_A_R signs subsets)"
   shows "matrix_A_R (get_signs_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
   (get_subsets_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs))))) = 
   (get_matrix_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))"
 proof -
   let ?A = "(matrix_A_R signs subsets)"
   let ?lhs_vec = "(solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))"
   let ?red_mtx = "(take_rows_from_matrix (reduce_mat_cols (matrix_A_R signs subsets) ?lhs_vec) (rows_to_keep (reduce_mat_cols (matrix_A_R signs subsets) ?lhs_vec)))"
   have h1: "matrix_A_R (get_signs_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
   (get_subsets_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
    = matrix_A_R (reduction_signs_R p qs signs subsets (matrix_A_R signs subsets)) (reduction_subsets_R p qs signs subsets (matrix_A_R signs subsets))"
     using reduction_signs_is_get_signs_R reduction_subsets_is_get_subsets_R by auto
   have h1_var: "matrix_A_R (get_signs_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
   (get_subsets_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
    = matrix_A_R (take_indices signs (find_nonzeros_from_input_vec ?lhs_vec)) (take_indices subsets (rows_to_keep (reduce_mat_cols ?A ?lhs_vec)))"
     using h1 reduction_signs_R_def reduction_subsets_R_def  by auto 
   have h2: "?red_mtx = (take_rows_from_matrix (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec)) (rows_to_keep (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec))))"
     by simp
   have h30: "(construct_lhs_vector_R p qs signs) = ?lhs_vec"
     using assms construct_lhs_matches_solve_for_lhs_R
     by simp 
   have h3a: "\<forall>x. List.member (find_nonzeros_from_input_vec ?lhs_vec) x \<longrightarrow>x < length (signs)" 
     using h30 size_of_lhs_R[of p qs signs]  
     unfolding find_nonzeros_from_input_vec_def apply (auto)
     using in_set_member by force
   have h3b_a: "\<forall>x. List.member (find_nonzeros_from_input_vec ?lhs_vec) x \<longrightarrow>x < length (subsets)" 
     using assms h30 size_of_lhs_R same_size_R unfolding find_nonzeros_from_input_vec_def apply (auto)
     by (simp add: find_nonzeros_from_input_vec_def h3a)
   have h3ba: "length
      (filter (\<lambda>i. solve_for_lhs_R p qs subsets (matrix_A_R signs subsets) $ i \<noteq> 0)
        [0..<length subsets])
     \<le> length subsets" using length_filter_le[where P = "(\<lambda>i. solve_for_lhs_R p qs subsets (matrix_A_R signs subsets) $ i \<noteq> 0)",
     where xs = "[0..<length subsets]"] length_upto by auto
   have " length subsets = dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))"
     using h30 inv size_of_lhs_R same_size_R[of signs subsets] apply (auto)
     by metis 
   then have "length
      (filter (\<lambda>i. solve_for_lhs_R p qs subsets (matrix_A_R signs subsets) $ i \<noteq> 0)
        [0..<dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))])
     \<le> length subsets" using h3ba
     by auto
   then have h3b: "length subsets \<ge> length (take_indices signs (find_nonzeros_from_input_vec ?lhs_vec))" 
     unfolding take_indices_def find_nonzeros_from_input_vec_def by auto
   have h3c: "\<forall>x. List.member (rows_to_keep (reduce_mat_cols ?A ?lhs_vec)) x \<longrightarrow> x < length (subsets)"
   proof clarsimp
     fix x
     assume x_mem: "List.member (rows_to_keep
             (take_cols_from_matrix (matrix_A_R signs subsets)
               (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))) x"
     obtain nn :: "rat list list \<Rightarrow> nat list \<Rightarrow> nat" where
       "\<forall>x2 x3. (\<exists>v4. v4 \<in> set x3 \<and> \<not> v4 < length x2) = (nn x2 x3 \<in> set x3 \<and> \<not> nn x2 x3 < length x2)"
       by moura
     then have f4: "nn signs (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<in> set (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<and> \<not> nn signs (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) < length signs \<or> matrix_A_R (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) subsets = take_cols_from_matrix (matrix_A_R signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
       using nonzero
       using h3a reduce_system_matrix_signs_helper_R by auto 
     then have "matrix_A_R (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) subsets = take_cols_from_matrix (matrix_A_R signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<and> x \<in> set (map snd (pivot_positions (gauss_jordan_single (take_cols_from_matrix (matrix_A_R signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))\<^sup>T)))"
       using f4
       by (metis h3a in_set_member rows_to_keep_def x_mem)
     thus "x < length (subsets)" using x_mem unfolding rows_to_keep_def
       by (metis dim_row_matrix_A_R rows_to_keep_def rows_to_keep_lem)
   qed
   have h3: "matrix_A_R (take_indices signs (find_nonzeros_from_input_vec ?lhs_vec)) (take_indices subsets (rows_to_keep (reduce_mat_cols ?A ?lhs_vec))) = 
     (take_rows_from_matrix (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec)) (rows_to_keep (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec))))" 
     using inv h3a h3b h3c reduce_system_matrix_subsets_helper_R reduce_system_matrix_signs_helper_R
       assms 
     by auto
   show ?thesis using h1 h2 h3 
     by (metis fst_conv get_matrix_R_def h1_var reduce_system_R.simps reduction_step_R.simps)
 qed
 
 subsection "Showing invertibility preserved when reducing"
 
 (* gauss_jordan_single_rank is critically helpful in this subsection *)
 thm conjugatable_vec_space.gauss_jordan_single_rank
 
 thm vec_space.full_rank_lin_indpt
 
 (* Overall:
   Start with a matrix equation.
   Input a matrix, subsets, and signs.
   Drop columns of the matrix based on the 0's on the LHS---so extract a list of 0's. Reduce signs accordingly.
   Then find a list of rows to delete based on using rank (use the transpose result, pivot positions!),
    and delete those rows.  Reduce subsets accordingly.
   End with a reduced system! *)
 lemma well_def_find_zeros_from_lhs_vec_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A_R signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   shows "(\<And>j. j \<in> set (find_nonzeros_from_input_vec
                     (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<Longrightarrow>
           j < length (cols (matrix_A_R signs subsets)))"
 proof - 
   fix i
   fix j
   assume j_in: " j \<in> set (find_nonzeros_from_input_vec
                       (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) "
   let ?og_mat = "(matrix_A_R signs subsets)"
   let ?lhs = "(solve_for_lhs_R p qs subsets ?og_mat)"
   let ?new_mat = "(take_rows_from_matrix (reduce_mat_cols ?og_mat ?lhs) (rows_to_keep (reduce_mat_cols ?og_mat ?lhs)))"
   have "square_mat (matrix_A_R signs subsets)" using inv
     using invertible_mat_def by blast
   then have mat_size: "?og_mat \<in> carrier_mat (length signs) (length signs)" 
     using size_of_mat
     by auto 
   have "dim_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)) = (length signs)"
     using size_of_lhs_R construct_lhs_matches_solve_for_lhs_R assms
     by (metis (full_types))
   then have h: "j < (length signs)"
     using j_in unfolding find_nonzeros_from_input_vec_def
     by simp 
   then show "j <  length (cols (matrix_A_R signs subsets))" 
     using mat_size by auto
 qed
 
 
 lemma take_cols_subsets_og_cols_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A_R signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   shows "set (take_indices (cols (matrix_A_R signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))
     \<subseteq> set (cols (matrix_A_R signs subsets))"
 proof -
   have well_def: "(\<And>j. j \<in> set (find_nonzeros_from_input_vec
                     (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<Longrightarrow>
           j < length (cols (matrix_A_R signs subsets)))"
     using assms well_def_find_zeros_from_lhs_vec_R by auto
   have "\<forall>x. x \<in> set (take_indices (cols (matrix_A_R signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) 
     \<longrightarrow> x \<in>  set (cols (matrix_A_R signs subsets))" 
   proof clarsimp 
     fix x
     let ?og_list = "(cols (matrix_A_R signs subsets))"
     let ?ind_list = "(find_nonzeros_from_input_vec
                      (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
     assume x_in: "x \<in> set (take_indices ?og_list ?ind_list)"
     show "x \<in> set (cols (matrix_A_R signs subsets))" 
       using x_in unfolding take_indices_def using in_set_member apply (auto)
       using in_set_conv_nth well_def by fastforce
   qed
   then show ?thesis
     by blast 
 qed
 
 
 lemma reduction_doesnt_break_things_invertibility_step1_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A_R signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   shows "vec_space.rank (length signs) (reduce_mat_cols (matrix_A_R signs subsets) (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) =
     (length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))"
 proof - 
   let ?og_mat = "(matrix_A_R signs subsets)"
   let ?lhs = "(solve_for_lhs_R p qs subsets ?og_mat)"
   let ?new_mat = "(take_rows_from_matrix (reduce_mat_cols ?og_mat ?lhs) (rows_to_keep (reduce_mat_cols ?og_mat ?lhs)))"
   have "square_mat (matrix_A_R signs subsets)" using inv
     using invertible_mat_def by blast
   then have mat_size: "?og_mat \<in> carrier_mat (length signs) (length signs)" 
     using size_of_mat
     by auto 
   then have mat_size_alt: "?og_mat \<in> carrier_mat (length subsets) (length subsets)" 
     using size_of_mat same_size assms 
     by auto 
   have det_h: "det ?og_mat \<noteq> 0"
     using invertible_det[where A = "matrix_A_R signs subsets"] mat_size
     using inv by blast
   then have rank_h: "vec_space.rank (length signs) ?og_mat = (length signs)" 
     using vec_space.det_rank_iff  mat_size
     by auto
   then have dist_cols: "distinct (cols ?og_mat)" using mat_size vec_space.non_distinct_low_rank[where A = ?og_mat, where n = "length signs"]
     by auto
   have well_def: "(\<And>j. j \<in> set (find_nonzeros_from_input_vec
                     (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<Longrightarrow>
           j < length (cols (matrix_A_R signs subsets)))"
     using assms well_def_find_zeros_from_lhs_vec_R by auto
   have dist1: "distinct
      (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
     unfolding find_nonzeros_from_input_vec_def by auto
   have clear: "set (take_indices (cols (matrix_A_R signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))
     \<subseteq> set (cols (matrix_A_R signs subsets))"
     using assms take_cols_subsets_og_cols_R by auto
   then have "distinct (take_indices (cols (matrix_A_R signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))"
     unfolding take_indices_def
     using dist1 dist_cols well_def conjugatable_vec_space.distinct_map_nth[where ls = "cols (matrix_A_R signs subsets)", where inds = "(find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"]
     by auto
   then have unfold_thesis: "vec_space.rank (length signs) (mat_of_cols (dim_row ?og_mat) (take_indices (cols ?og_mat) (find_nonzeros_from_input_vec ?lhs)))
 = (length (find_nonzeros_from_input_vec ?lhs))" 
     using clear inv conjugatable_vec_space.rank_invertible_subset_cols[where A= "matrix_A_R signs subsets", where B = "(take_indices (cols (matrix_A_R signs subsets))
          (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))"]
     by (simp add: len_eq mat_size take_indices_def)
   then show ?thesis apply (simp) unfolding take_cols_from_matrix_def by auto
 qed
 
 
 lemma reduction_doesnt_break_things_invertibility_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A_R signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation_R p qs subsets signs"
   shows "invertible_mat (get_matrix_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))"
 proof - 
   let ?og_mat = "(matrix_A_R signs subsets)"
   let ?lhs = "(solve_for_lhs_R p qs subsets ?og_mat)"
   let ?step1_mat = "(reduce_mat_cols ?og_mat ?lhs)"
   let ?new_mat = "take_rows_from_matrix ?step1_mat (rows_to_keep ?step1_mat)"
   let ?ind_list = "(find_nonzeros_from_input_vec  ?lhs)"
   have "square_mat (matrix_A_R signs subsets)" using inv
     using invertible_mat_def by blast
   then have og_mat_size: "?og_mat \<in> carrier_mat (length signs) (length signs)" 
     using size_of_mat
     by auto 
   have "dim_col (mat_of_cols (dim_row ?og_mat) (take_indices (cols ?og_mat) ?ind_list))
       = (length (find_nonzeros_from_input_vec ?lhs))"
     by (simp add: take_indices_def) 
   then have "mat_of_cols (dim_row ?og_mat) (take_indices (cols ?og_mat) ?ind_list)
       \<in> carrier_mat (length signs) (length (find_nonzeros_from_input_vec ?lhs))"
     by (simp add: len_eq mat_of_cols_def)
   then have step1_mat_size: "?step1_mat \<in> carrier_mat (length signs) (length (find_nonzeros_from_input_vec ?lhs))"
     by (simp add: take_cols_from_matrix_def)
   then have "dim_row ?step1_mat \<ge> dim_col ?step1_mat"
     by (metis carrier_matD(1) carrier_matD(2) construct_lhs_matches_solve_for_lhs_R diff_zero find_nonzeros_from_input_vec_def inv length_filter_le length_upt match size_of_lhs_R)
   then have gt_eq_assm: "dim_col ?step1_mat\<^sup>T  \<ge> dim_row  ?step1_mat\<^sup>T"
     by simp 
   have det_h: "det ?og_mat \<noteq> 0"
     using invertible_det[where A = "matrix_A_R signs subsets"] og_mat_size
     using inv by blast
   then have rank_h: "vec_space.rank (length signs) ?og_mat = (length signs)" 
     using vec_space.det_rank_iff  og_mat_size
     by auto
   have rank_drop_cols: "vec_space.rank (length signs) ?step1_mat = (dim_col ?step1_mat)"
     using assms reduction_doesnt_break_things_invertibility_step1_R step1_mat_size 
     by auto
   let ?step1_T = "?step1_mat\<^sup>T"
   have rank_transpose: "vec_space.rank (length signs) ?step1_mat = vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) ?step1_T"
     using transpose_rank[of ?step1_mat]
     using step1_mat_size by auto  
   have obv: "?step1_T \<in> carrier_mat (dim_row ?step1_T) (dim_col ?step1_T)" by auto
   have should_have_this:"vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) (take_cols ?step1_T (map snd (pivot_positions (gauss_jordan_single (?step1_T))))) = vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) ?step1_T"
     using obv gt_eq_assm conjugatable_vec_space.gauss_jordan_single_rank[where A = "?step1_T", where n = "dim_row ?step1_T", where nc = "dim_col ?step1_T"]
     by (simp add: take_cols_from_matrix_def take_indices_def)
   then have "vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) (take_cols ?step1_T (map snd (pivot_positions (gauss_jordan_single (?step1_T))))) = dim_col ?step1_mat"
     using rank_drop_cols rank_transpose by auto
   then have with_take_cols_from_matrix: "vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) (take_cols_from_matrix ?step1_T (map snd (pivot_positions (gauss_jordan_single (?step1_T))))) = dim_col ?step1_mat"
     using rank_transpose rechar_take_cols conjugatable_vec_space.gjs_and_take_cols_var
     apply (auto)
     by (smt conjugatable_vec_space.gjs_and_take_cols_var gt_eq_assm obv rechar_take_cols reduce_mat_cols.simps)
   have "(take_rows_from_matrix ?step1_mat (rows_to_keep ?step1_mat)) = (take_cols_from_matrix ?step1_T  (rows_to_keep ?step1_mat))\<^sup>T"
     using take_rows_and_take_cols
     by blast 
   then have rank_new_mat: "vec_space.rank (dim_row ?new_mat) ?new_mat = dim_col ?step1_mat"
     using with_take_cols_from_matrix transpose_rank apply (auto)
     by (smt (verit, ccfv_threshold) carrier_matD(2) index_transpose_mat(2) mat_of_cols_carrier(2) reduce_mat_cols.simps rows_to_keep_def step1_mat_size take_cols_from_matrix_def transpose_rank)
   have "length (pivot_positions (gauss_jordan_single (?step1_mat\<^sup>T))) \<le> (length (find_nonzeros_from_input_vec ?lhs))"
     using obv length_pivot_positions_dim_row[where A = "(gauss_jordan_single (?step1_mat\<^sup>T))"]
     by (metis carrier_matD(1) carrier_matD(2) gauss_jordan_single(2) gauss_jordan_single(3) index_transpose_mat(2) step1_mat_size) 
   then have len_lt_eq: "length (pivot_positions (gauss_jordan_single (?step1_mat\<^sup>T))) \<le> dim_col ?step1_mat"
     using step1_mat_size
     by simp 
   have len_gt_false: "length (rows_to_keep ?step1_mat) < (dim_col ?step1_mat) \<Longrightarrow> False"
   proof - 
     assume length_lt: "length (rows_to_keep ?step1_mat) < (dim_col ?step1_mat)"
     have h: "dim_row ?new_mat < (dim_col ?step1_mat)"
       by (metis Matrix.transpose_transpose index_transpose_mat(3) length_lt length_map mat_of_cols_carrier(3) take_cols_from_matrix_def take_indices_def take_rows_and_take_cols)
     then show "False" using rank_new_mat
       by (metis Matrix.transpose_transpose carrier_matI index_transpose_mat(2) nat_less_le not_less_iff_gr_or_eq transpose_rank vec_space.rank_le_nc)    
   qed
   then have len_gt_eq: "length (rows_to_keep ?step1_mat) \<ge> (dim_col ?step1_mat)"
     using not_less by blast
   have len_match: "length (rows_to_keep ?step1_mat) = (dim_col ?step1_mat)"
     using len_lt_eq len_gt_eq
     by (simp add: rows_to_keep_def) 
   have mat_match: "matrix_A_R (get_signs_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))
   (get_subsets_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs))))) = 
   (get_matrix_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))"
     using reduce_system_matrix_match_R[of p qs signs subsets]  assms
     by blast 
   have f2: "length (get_subsets_R (take_rows_from_matrix (mat_of_cols (dim_row (matrix_A_R signs subsets)) (map ((!) (cols (matrix_A_R signs subsets))) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))) (rows_to_keep (mat_of_cols (dim_row (matrix_A_R signs subsets)) (map ((!) (cols (matrix_A_R signs subsets))) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))))), map ((!) subsets) (rows_to_keep (mat_of_cols (dim_row (matrix_A_R signs subsets)) (map ((!) (cols (matrix_A_R signs subsets))) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))))), map ((!) signs) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))) = length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
 
     by (metis (no_types) \<open>dim_col (mat_of_cols (dim_row (matrix_A_R signs subsets)) (take_indices (cols (matrix_A_R signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))) = length (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> \<open>length (rows_to_keep (reduce_mat_cols (matrix_A_R signs subsets) (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) = dim_col (reduce_mat_cols (matrix_A_R signs subsets) (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> length_map reduce_mat_cols.simps reduce_system_R.simps reduction_step_R.simps reduction_subsets_R_def reduction_subsets_is_get_subsets_R take_cols_from_matrix_def take_indices_def)
   have f3: "\<forall>p ps rss nss m. map ((!) rss) (find_nonzeros_from_input_vec (solve_for_lhs_R p ps nss m)) = get_signs_R (reduce_system_R p (ps, m, nss, rss))"
     by (metis (no_types) reduction_signs_R_def reduction_signs_is_get_signs_R take_indices_def)
   have square_final_mat: "square_mat (get_matrix_R (reduce_system_R p (qs, ((matrix_A_R signs subsets), (subsets, signs)))))"
     using mat_match assms size_of_mat_R same_size_R
     apply (auto) using f2 f3
     by (metis (no_types, lifting) Matrix.transpose_transpose fst_conv get_matrix_R_def index_transpose_mat(2) len_match length_map mat_of_cols_carrier(2) mat_of_cols_carrier(3) reduce_mat_cols.simps take_cols_from_matrix_def take_indices_def take_rows_and_take_cols) 
   have rank_match: "vec_space.rank (dim_row ?new_mat) ?new_mat = dim_row ?new_mat"
     using len_match rank_new_mat
     by (simp add: take_cols_from_matrix_def take_indices_def take_rows_and_take_cols) 
   have "invertible_mat ?new_mat"
     using invertible_det og_mat_size
     using vec_space.det_rank_iff square_final_mat
     by (metis dim_col_matrix_A_R dim_row_matrix_A_R fst_conv get_matrix_R_def mat_match rank_match reduce_system_R.simps reduction_step_R.simps size_of_mat_R square_mat.elims(2))
   then show ?thesis apply (simp)
     by (metis fst_conv get_matrix_R_def)
 qed
 
 subsection "Well def signs preserved when reducing"
 
 lemma reduction_doesnt_break_length_signs_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes length_init : "\<forall> x\<in> set(signs). length x = length qs"
   assumes sat_eq: "satisfy_equation_R p qs subsets signs"
   assumes inv_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "\<forall>x \<in> set(reduction_signs_R p qs signs subsets (matrix_A_R signs subsets)). 
     length x = length qs"
   unfolding reduction_signs_def using take_indices_lem
   by (smt (verit) atLeastLessThan_iff construct_lhs_matches_solve_for_lhs_R filter_is_subset find_nonzeros_from_input_vec_def in_set_conv_nth in_set_member inv_mat length_init reduction_signs_R_def sat_eq set_upt size_of_lhs_R subset_code(1))
 
 subsection "Distinct signs preserved when reducing"
 
 lemma reduction_signs_are_distinct_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes sat_eq: "satisfy_equation_R p qs subsets signs"
   assumes inv_mat: "invertible_mat (matrix_A_R signs subsets)"
   assumes distinct_init: "distinct signs"
   shows "distinct (reduction_signs_R p qs signs subsets (matrix_A_R signs subsets))"
 proof -
   have solve_construct: "construct_lhs_vector_R p qs signs =
   solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)"
     using construct_lhs_matches_solve_for_lhs_R assms
     by simp
   have h1: "distinct (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
     unfolding find_nonzeros_from_input_vec_def 
     using distinct_filter
     using distinct_upt by blast 
   have h2: "(\<And>j. j \<in> set (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))) \<Longrightarrow>
           j < length signs)"
   proof - 
     fix j
     assume "j \<in> set (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"
     show "j < length signs" using solve_construct size_of_lhs_R
       by (metis \<open>j \<in> set (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))\<close> atLeastLessThan_iff filter_is_subset find_nonzeros_from_input_vec_def set_upt subset_iff)
   qed
   then show ?thesis unfolding reduction_signs_R_def unfolding take_indices_def
     using distinct_init h1 h2 conjugatable_vec_space.distinct_map_nth[where ls = "signs", where inds = "(find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))"]
     by blast
 qed
 
 subsection "Well def subsets preserved when reducing"
 
 lemma reduction_doesnt_break_subsets_R:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list* nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes length_init : "all_list_constr_R subsets (length qs)"
   assumes sat_eq: "satisfy_equation_R p qs subsets signs"
   assumes inv_mat: "invertible_mat (matrix_A_R signs subsets)"
   shows "all_list_constr_R (reduction_subsets_R p qs signs subsets (matrix_A_R signs subsets)) (length qs)"
   unfolding all_list_constr_R_def 
 proof clarsimp
   fix a b
   assume in_red_subsets: "List.member (reduction_subsets_R p qs signs subsets (matrix_A_R signs subsets)) (a, b) "
   have solve_construct: "construct_lhs_vector_R p qs signs =
   solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)"
     using construct_lhs_matches_solve_for_lhs_R assms
     by simp
   have rows_to_keep_hyp: "\<forall>y. y \<in> set (rows_to_keep (reduce_mat_cols (matrix_A_R signs subsets) (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) \<longrightarrow> 
       y < length subsets" 
   proof clarsimp 
     fix y
     assume in_set: "y \<in> set (rows_to_keep
                    (take_cols_from_matrix (matrix_A_R signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))))"
     have in_set_2: "y \<in> set (rows_to_keep
                    (take_cols_from_matrix (matrix_A_R signs subsets) (find_nonzeros_from_input_vec (construct_lhs_vector_R p qs signs))))"
       using in_set solve_construct by simp
     let ?lhs_vec = "(solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))"
     have h30: "(construct_lhs_vector_R p qs signs) = ?lhs_vec"
       using assms construct_lhs_matches_solve_for_lhs_R
       by simp 
     have h3a: "\<forall>x. List.member (find_nonzeros_from_input_vec ?lhs_vec) x \<longrightarrow>x < length (signs)" 
       using h30 size_of_lhs_R unfolding find_nonzeros_from_input_vec_def 
       using atLeastLessThan_iff filter_is_subset member_def set_upt subset_eq apply (auto)
       by (smt (verit, best) atLeastLessThan_iff in_set_member mem_Collect_eq set_filter set_upt)
     have h3c: "\<forall>x. List.member (rows_to_keep (reduce_mat_cols (matrix_A_R signs subsets) (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets)))) x \<longrightarrow> x < length (subsets)"
     proof clarsimp
       fix x
       assume x_mem: "List.member (rows_to_keep
             (take_cols_from_matrix (matrix_A_R signs subsets)
               (find_nonzeros_from_input_vec (solve_for_lhs_R p qs subsets (matrix_A_R signs subsets))))) x"
       show "x < length (subsets)" using x_mem unfolding rows_to_keep_def using pivot_positions
         using  dim_row_matrix_A h3a in_set_member nonzero reduce_system_matrix_signs_helper_R rows_to_keep_def rows_to_keep_lem
         apply (auto)
         by (smt (verit, best) List.member_def dim_row_matrix_A_R rows_to_keep_def rows_to_keep_lem) 
     qed
     then show "y < length subsets" using in_set_member apply (auto)
       using in_set_2 solve_construct by fastforce  
   qed
   show "list_constr a (length qs) \<and> list_constr b (length qs)" using in_red_subsets  unfolding  reduction_subsets_def 
     using take_indices_lem_R[of _ subsets]  rows_to_keep_hyp 
     using all_list_constr_R_def in_set_conv_nth in_set_member length_init
     by (metis fst_conv reduction_subsets_R_def snd_conv)
 qed
 
 section "Overall Lemmas"
 lemma combining_to_smash_R:  "combine_systems_R p (qs1, m1, (sub1, sgn1)) (qs2, m2, (sub2, sgn2))
  =  smash_systems_R p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2"
   by simp
 
 lemma getter_functions_R: "calculate_data_R p qs = (get_matrix_R (calculate_data_R p qs), (get_subsets_R (calculate_data_R p qs), get_signs_R (calculate_data_R p qs))) "
   unfolding get_matrix_R_def get_subsets_R_def get_signs_R_def by auto
 
 subsection "Key properties preserved"
 
 subsubsection "Properties preserved when combining and reducing systems"
 lemma combining_sys_satisfies_properties_helper_R:
   fixes p:: "real poly"
   fixes qs1 :: "real poly list"
   fixes qs2 :: "real poly list"
   fixes subsets1 subsets2 :: "(nat list * nat list) list"
   fixes signs1 signs2 :: "rat list list" 
   fixes matrix1 matrix2:: "rat mat"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes nontriv2: "length qs2 > 0"
   assumes satisfies_properties_sys1: "satisfies_properties_R p qs1 subsets1 signs1 matrix1"
   assumes satisfies_properties_sys2: "satisfies_properties_R p qs2 subsets2 signs2 matrix2"
   shows  "satisfies_properties_R p (qs1@qs2) (get_subsets_R (snd ((combine_systems_R p (qs1,(matrix1, (subsets1, signs1))) (qs2,(matrix2, (subsets2, signs2))))))) 
   (get_signs_R (snd ((combine_systems_R p (qs1,(matrix1, (subsets1, signs1))) (qs2,(matrix2, (subsets2, signs2))))))) 
   (get_matrix_R (snd ((combine_systems_R p (qs1,(matrix1, (subsets1, signs1))) (qs2,(matrix2, (subsets2, signs2)))))))"
 proof -     
   let ?subsets = "(get_subsets_R (snd (combine_systems_R p (qs1, matrix1, subsets1, signs1)
               (qs2, matrix2, subsets2, signs2))))"
   let ?signs = "(get_signs_R (snd (combine_systems_R p (qs1, matrix1, subsets1, signs1) (qs2, matrix2, subsets2, signs2))))"
   let ?matrix = "(get_matrix_R (snd (combine_systems_R p (qs1, matrix1, subsets1, signs1) (qs2, matrix2, subsets2, signs2))))"
   have h1: "all_list_constr_R ?subsets (length (qs1 @ qs2))"
     using well_def_step_R[of subsets1 qs1 subsets2 qs2] assms
     by (simp add: nontriv2 get_subsets_R_def satisfies_properties_R_def smash_systems_R_def) 
   have h2: "well_def_signs (length (qs1 @ qs2)) ?signs"
     using well_def_signs_step[of qs1 qs2 signs1 signs2]
     using get_signs_R_def nontriv1 nontriv2 satisfies_properties_R_def satisfies_properties_sys1 satisfies_properties_sys2 smash_systems_R_def
     by (metis combining_to_smash_R snd_conv)
   have h3: "distinct ?signs" 
     using distinct_step[of _ signs1 _ signs2] assms
     using combine_systems.simps get_signs_R_def satisfies_properties_R_def smash_systems_R_def snd_conv
     by (metis combining_to_smash_R) 
   have h4: "satisfy_equation_R p (qs1 @ qs2) ?subsets ?signs" 
     using assms inductive_step_R[of p qs1 qs2 signs1 signs2 subsets1 subsets2]
     using get_signs_R_def get_subsets_R_def satisfies_properties_R_def smash_systems_R_def
     by (metis (no_types, opaque_lifting) combining_to_smash_R h1 h3 matrix_equation_R snd_conv subset_step_R) 
   have h5: " invertible_mat ?matrix"
     using assms inductive_step_R[of p qs1 qs2 signs1 signs2 subsets1 subsets2]
     by (metis combining_to_smash_R fst_conv get_matrix_R_def kronecker_invertible satisfies_properties_R_def smash_systems_R_def snd_conv)
   have h6: "?matrix = matrix_A_R ?signs ?subsets" 
     unfolding get_matrix_R_def combine_systems_R.simps smash_systems_R_def get_signs_R_def get_subsets_R_def
     apply simp
     apply (subst matrix_construction_is_kronecker_product_R[of subsets1 _ signs1 signs2 subsets2])
    
       apply (metis Ball_set all_list_constr_R_def in_set_member list_constr_def satisfies_properties_R_def satisfies_properties_sys1)
     using satisfies_properties_R_def satisfies_properties_sys1 well_def_signs_def apply blast
     using satisfies_properties_R_def satisfies_properties_sys1 satisfies_properties_sys2 by auto
   have h7: "set (characterize_consistent_signs_at_roots p (qs1 @ qs2))
     \<subseteq> set (?signs)"
     using subset_step_R[of p qs1 signs1 qs2  signs2] assms
     by (simp add: nonzero get_signs_R_def satisfies_properties_R_def smash_systems_R_def) 
   then show ?thesis unfolding satisfies_properties_R_def using h1 h2 h3 h4 h5 h6 h7 by blast
 qed
 
 lemma combining_sys_satisfies_properties_R:
   fixes p:: "real poly"
   fixes qs1 :: "real poly list"
   fixes qs2 :: "real poly list"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes nontriv2: "length qs2 > 0"
   assumes satisfies_properties_sys1: "satisfies_properties_R p qs1 (get_subsets_R (calculate_data_R p qs1)) (get_signs_R (calculate_data_R p qs1)) (get_matrix_R (calculate_data_R p qs1))"
   assumes satisfies_properties_sys2: "satisfies_properties_R p qs2 (get_subsets_R (calculate_data_R p qs2)) (get_signs_R (calculate_data_R p qs2)) (get_matrix_R (calculate_data_R p qs2))"
   shows  "satisfies_properties_R p (qs1@qs2) (get_subsets_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2))))) 
   (get_signs_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2))))) 
   (get_matrix_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2)))))"
   using combining_sys_satisfies_properties_helper_R[of p qs1 qs2]
   by (metis getter_functions_R nontriv1 nontriv2 nonzero satisfies_properties_sys1 satisfies_properties_sys2) 
 
 lemma reducing_sys_satisfies_properties_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   fixes matrix:: "rat mat"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv: "length qs > 0"
   assumes satisfies_properties_sys: "satisfies_properties_R p qs subsets signs matrix"
   shows  "satisfies_properties_R p qs (get_subsets_R (reduce_system_R p (qs,matrix,subsets,signs)))
   (get_signs_R (reduce_system_R p (qs,matrix,subsets,signs)))
   (get_matrix_R (reduce_system_R p (qs,matrix,subsets,signs)))"
 proof -
   have h1: " all_list_constr_R (get_subsets_R (reduce_system_R p (qs, matrix, subsets, signs))) (length qs)"
     using reduction_doesnt_break_subsets_R assms reduction_subsets_is_get_subsets_R satisfies_properties_R_def satisfies_properties_sys by auto
   have h2: "well_def_signs (length qs) (get_signs_R (reduce_system_R p (qs, matrix, subsets, signs)))"
     using reduction_doesnt_break_length_signs_R[of signs qs p subsets] assms reduction_signs_is_get_signs_R satisfies_properties_R_def well_def_signs_def by auto
   have h3: "distinct (get_signs_R (reduce_system_R p (qs, matrix, subsets, signs)))"
     using reduction_signs_are_distinct_R[of p qs subsets signs] assms reduction_signs_is_get_signs_R satisfies_properties_R_def by auto 
   have h4: "satisfy_equation_R p qs (get_subsets_R (reduce_system_R p (qs, matrix, subsets, signs)))
      (get_signs_R (reduce_system_R p (qs, matrix, subsets, signs)))"
     using reduce_system_matrix_equation_preserved_R[of p qs signs subsets] assms satisfies_properties_R_def by auto
   have h5: "invertible_mat (get_matrix_R (reduce_system_R p (qs, matrix, subsets, signs)))"
     using reduction_doesnt_break_things_invertibility_R assms same_size_R satisfies_properties_R_def by auto 
   have h6: "get_matrix_R (reduce_system_R p (qs, matrix, subsets, signs)) =
     matrix_A_R (get_signs_R (reduce_system_R p (qs, matrix, subsets, signs)))
      (get_subsets_R (reduce_system_R p (qs, matrix, subsets, signs)))"
     using reduce_system_matrix_match_R[of p qs signs subsets] assms satisfies_properties_R_def by auto
   have h7: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set (get_signs_R (reduce_system_R p (qs, matrix, subsets, signs)))"
     using reduction_doesnt_break_things_signs_R[of p qs signs subsets] assms reduction_signs_is_get_signs_R satisfies_properties_R_def by auto
   then show ?thesis unfolding satisfies_properties_R_def using h1 h2 h3 h4 h5 h6 h7
     by blast
 qed
 
 subsubsection "For length 1 qs"
 
 lemma  length_1_calculate_data_satisfies_properties_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes len1: "length qs = 1"
   shows "satisfies_properties_R p qs (get_subsets_R (calculate_data_R p qs)) (get_signs_R (calculate_data_R p qs)) (get_matrix_R (calculate_data_R p qs))"
 proof - 
   have h1: "all_list_constr_R  [([], []),([0], []),([], [0])] (length qs)"
     using len1 unfolding all_list_constr_R_def list_constr_def apply (auto)
     apply (smt (verit, best) Ball_set in_set_member member_rec(1) member_rec(2) prod.inject)
     by (smt (verit, ccfv_threshold) Ball_set in_set_member member_rec(1) member_rec(2) prod.inject)
   have h2: "well_def_signs (length qs) [[1],[-1]]"
     unfolding well_def_signs_def using len1 in_set_member 
     by auto
   have h3: "distinct ([[1],[0],[-1]]::rat list list)" 
     unfolding distinct_def using in_set_member by auto
   have h4: "satisfy_equation_R p qs [([], []),([0], []),([], [0])] [[1],[0],[-1]]"
     using assms base_case_satisfy_equation_alt_R[of qs p] by auto
   have h6: "(mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]::rat mat) = (matrix_A_R ([[1],[0],[-1]]) ([([], []),([0], []),([], [0])]) :: rat mat)" 
     using mat_base_case_R by auto
   then have h5: "invertible_mat (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]::rat mat)" 
     using base_case_invertible_mat_R
     by simp
   have h7:  "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set ([[1],[0],[-1]])"
     using assms base_case_sgas_alt_R[of qs p]
     by simp  
   have base_case_hyp: "satisfies_properties_R p qs [([], []),([0], []),([], [0])] [[1],[0],[-1]] (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]::rat mat)"
     using h1 h2 h3 h4 h5 h6 h7
     using satisfies_properties_R_def apply (auto)
     by (simp add: well_def_signs_def) 
   then have key_hyp: "satisfies_properties_R p qs (get_subsets_R (reduce_system_R p (qs,base_case_info_R))) (get_signs_R (reduce_system_R p (qs,base_case_info_R))) (get_matrix_R (reduce_system_R p (qs,base_case_info_R)))"
     using reducing_sys_satisfies_properties_R
     by (metis base_case_info_R_def len1 nonzero nonzero zero_less_one_class.zero_less_one) 
   show ?thesis
     by (simp add: key_hyp len1) 
 qed
 
 subsubsection "For arbitrary qs"
 
 lemma  calculate_data_satisfies_properties_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   shows "(p \<noteq> 0 \<and> (length qs > 0))
     \<longrightarrow> satisfies_properties_R p qs (get_subsets_R (calculate_data_R p qs)) (get_signs_R (calculate_data_R p qs)) (get_matrix_R (calculate_data_R p qs))"
 proof (induction "length qs" arbitrary: qs rule: less_induct)
   case less
   have len1_h: "length qs = 1 \<longrightarrow> ( p \<noteq> 0 \<and> (length qs > 0)) \<longrightarrow> satisfies_properties_R p qs (get_subsets_R (calculate_data_R p qs)) (get_signs_R (calculate_data_R p qs)) (get_matrix_R (calculate_data_R p qs))"
     using  length_1_calculate_data_satisfies_properties_R
     by blast
   let ?len = "length qs"
   let ?q1 = "take (?len div 2) qs"
   let ?left = "calculate_data_R p ?q1"
   let ?q2 = "drop (?len div 2) qs"
   let ?right = "calculate_data_R p ?q2"
   let ?comb = "combine_systems_R p (?q1,?left) (?q2,?right)"
   let ?red =  "reduce_system_R p ?comb"
   have h_q1_len: "length qs > 1 \<longrightarrow> (length ?q1 > 0)" by auto 
   have h_q2_len: "length qs > 1 \<longrightarrow> (length ?q2 > 0)" by auto
   have q1_sat_props: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0)) \<longrightarrow> satisfies_properties_R p ?q1 (get_subsets_R (calculate_data_R p ?q1)) (get_signs_R (calculate_data_R p ?q1)) (get_matrix_R (calculate_data_R p ?q1))"
     using less.hyps[of ?q1] h_q1_len
     by (metis div_le_dividend div_less_dividend length_take min.absorb2 one_less_numeral_iff semiring_norm(76)) 
   have q2_help: "length qs > 1 \<longrightarrow> length (drop (length qs div 2) qs) < length qs"
     using h_q1_len by auto  
   then have q2_sat_props: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0)) \<longrightarrow> satisfies_properties_R p ?q2 (get_subsets_R (calculate_data_R p ?q2)) (get_signs_R (calculate_data_R p ?q2)) (get_matrix_R (calculate_data_R p ?q2))"
     using less.hyps[of ?q2] h_q2_len
     by blast
   have put_tog: "?q1@?q2 = qs"
     using append_take_drop_id by blast 
   then have comb_sat_props: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0)) \<longrightarrow> (satisfies_properties_R p (qs) (get_subsets_R (snd ((combine_systems_R p (?q1,calculate_data_R p ?q1) (?q2,calculate_data_R p ?q2))))) 
   (get_signs_R (snd ((combine_systems_R p (?q1,calculate_data_R p ?q1) (?q2,calculate_data_R p ?q2))))) 
   (get_matrix_R (snd ((combine_systems_R p (?q1,calculate_data_R p ?q1) (?q2,calculate_data_R p ?q2))))))"
     using q1_sat_props q2_sat_props  combining_sys_satisfies_properties_R
     using h_q1_len h_q2_len  put_tog
     by metis
   then have comb_sat: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0)) \<longrightarrow> 
       (satisfies_properties_R p (qs) (get_subsets_R (snd ?comb)) (get_signs_R (snd ?comb)) (get_matrix_R (snd ?comb)))"
     by blast
   have red_char: "?red = (reduce_system_R p (qs,(get_matrix_R (snd ?comb)),(get_subsets_R (snd ?comb)),(get_signs_R (snd ?comb))))"
     using getter_functions
     by (smt (z3) combine_systems_R.simps find_consistent_signs_at_roots_R_def find_consistent_signs_at_roots_thm_R fst_conv get_matrix_R_def get_signs_R_def get_subsets_R_def prod.collapse put_tog smash_systems_R_def)
   then have "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0))  \<longrightarrow> (satisfies_properties_R p qs (get_subsets_R ?red) (get_signs_R ?red) (get_matrix_R ?red))"
     using reducing_sys_satisfies_properties_R comb_sat
     by presburger 
   then have len_gt1: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) ) \<longrightarrow> satisfies_properties_R p qs (get_subsets_R (calculate_data_R p qs)) (get_signs_R (calculate_data_R p qs)) (get_matrix_R (calculate_data_R p qs))"
     apply (auto)
     by (smt (z3) div_le_dividend min.absorb2)
   then show ?case using len1_h len_gt1
     by (metis One_nat_def Suc_lessI) 
 qed
 
 
 subsection "Some key results on consistent sign assignments"
 
 lemma find_consistent_signs_at_roots_len1_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes len1: "length qs = 1"
   shows "set (find_consistent_signs_at_roots_R p qs) = set (characterize_consistent_signs_at_roots p qs)"
 proof - 
   let ?signs = "[[1],[0],[-1]]::rat list list"
   let ?subsets = "[([], []),([0], []),([], [0])]::(nat list*nat list) list"
   let ?mat = "(mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]])"
   have mat_help: "matrix_A_R ?signs ?subsets = (mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]])"
     using mat_base_case_R by auto
   have well_def_signs: "well_def_signs (length qs) ?signs" unfolding well_def_signs_def 
     using len1 by auto
   have distinct_signs: "distinct ?signs"
     unfolding distinct_def by auto
   have ex_q: "\<exists>(q::real poly). qs = [q]" 
     using len1    
     using length_Suc_conv[of qs 0] by auto
   then have all_info: "set (characterize_consistent_signs_at_roots p qs) \<subseteq> set(?signs)"
     using assms base_case_sgas_R by auto
   have match: "satisfy_equation_R p qs ?subsets ?signs"
     using ex_q base_case_satisfy_equation_R nonzero
     by auto
   have invertible_mat: "invertible_mat (matrix_A_R ?signs ?subsets)"
     using inverse_mat_base_case_R inverse_mat_base_case_2_R unfolding invertible_mat_def using mat_base_case_R
     by auto
   have h: "set (get_signs_R (reduce_system_R p (qs, ((matrix_A_R ?signs ?subsets), (?subsets, ?signs))))) = 
     set (characterize_consistent_signs_at_roots p qs)" 
     using nonzero nonzero well_def_signs distinct_signs all_info match invertible_mat
       reduce_system_sign_conditions_R[where p = "p", where qs = "qs", where signs = ?signs, where subsets = ?subsets]
     by blast 
   then have  "set (snd (snd (reduce_system_R p (qs, (?mat, (?subsets, ?signs)))))) = 
     set (characterize_consistent_signs_at_roots p qs)"
     unfolding get_signs_R_def using mat_help by auto
   then have "set (snd (snd (reduce_system_R p (qs, base_case_info_R)))) = set (characterize_consistent_signs_at_roots p qs)"
     unfolding base_case_info_R_def
     by auto
   then show ?thesis using len1 
     by (simp add: find_consistent_signs_at_roots_thm_R)
 qed
 
 lemma smaller_sys_are_good_R:
   fixes p:: "real poly"
   fixes qs1 :: "real poly list"
   fixes qs2 :: "real poly list"
   fixes subsets :: "(nat list*nat list) list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes nontriv2: "length qs2 > 0"
   assumes "set(find_consistent_signs_at_roots_R p qs1) = set(characterize_consistent_signs_at_roots p qs1)"
   assumes "set(find_consistent_signs_at_roots_R p qs2) = set(characterize_consistent_signs_at_roots p qs2)"
   shows "set(snd(snd(reduce_system_R p (combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2)))))
     = set(characterize_consistent_signs_at_roots p (qs1@qs2))"
 proof - 
   let ?signs = "(get_signs_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2))))) "
   let ?subsets = "(get_subsets_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2))))) "
   have h0: "satisfies_properties_R p (qs1@qs2) ?subsets ?signs
     (get_matrix_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2)))))"
     using calculate_data_satisfies_properties_R combining_sys_satisfies_properties_R
     using nontriv1 nontriv2 nonzero nonzero
     by simp
   then have h1: "set(characterize_consistent_signs_at_roots p (qs1@qs2)) \<subseteq> set ?signs"
     unfolding satisfies_properties_R_def
     by linarith 
   have h2: "well_def_signs (length (qs1@qs2)) ?signs"
     using calculate_data_satisfies_properties_R
     using h0 satisfies_properties_R_def by blast 
   have h3: "distinct ?signs" 
     using calculate_data_satisfies_properties_R
     using h0 satisfies_properties_R_def by blast 
   have h4: "satisfy_equation_R p (qs1@qs2) ?subsets ?signs"
     using calculate_data_satisfies_properties_R
     using h0 satisfies_properties_R_def by blast 
   have h5: "invertible_mat (matrix_A_R ?signs ?subsets) "
     using calculate_data_satisfies_properties_R 
     using h0 satisfies_properties_R_def
     by auto
   have h: "set (take_indices ?signs 
             (find_nonzeros_from_input_vec (solve_for_lhs_R p (qs1@qs2) ?subsets  (matrix_A_R ?signs ?subsets))))
         =  set(characterize_consistent_signs_at_roots p (qs1@qs2))" 
     using h1 h2 h3 h4 h5 reduction_deletes_bad_sign_conds_R
     using nonzero reduction_signs_R_def by auto
   then have h: "set (characterize_consistent_signs_at_roots p (qs1@qs2)) =
     set (reduction_signs_R p (qs1@qs2) ?signs ?subsets  (matrix_A_R ?signs ?subsets ))" 
     unfolding reduction_signs_R_def get_signs_R_def
     by blast  
   have help_h: "reduction_signs_R p (qs1@qs2) ?signs ?subsets  (matrix_A_R ?signs ?subsets) 
       = (take_indices ?signs (find_nonzeros_from_input_vec (solve_for_lhs_R p (qs1@qs2) ?subsets  (matrix_A_R?signs ?subsets))))"
     unfolding reduction_signs_R_def by auto
   have clear_signs: "(signs_smash (get_signs_R (calculate_data_R p qs1)) (get_signs_R (calculate_data_R p qs2))) = (get_signs_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2)))))"
     using combining_to_smash get_signs_R_def getter_functions_R smash_systems_R_def snd_conv
   proof -
     have "combine_systems_R p (qs1, calculate_data_R p qs1) (qs2, calculate_data_R p qs2) = (qs1 @ qs2, kronecker_product (get_matrix_R (calculate_data_R p qs1)) (get_matrix_R (calculate_data_R p qs2)), subsets_smash_R (length qs1) (get_subsets_R (calculate_data_R p qs1)) (get_subsets_R (calculate_data_R p qs2)), signs_smash (snd (snd (calculate_data_R p qs1))) (snd (snd (calculate_data_R p qs2))))"
       by (metis (no_types) combine_systems_R.simps get_signs_R_def getter_functions_R smash_systems_R_def)
     then show ?thesis
       by (simp add: get_signs_R_def)
   qed
   have clear_subsets: "(subsets_smash_R (length qs1) (get_subsets_R(calculate_data_R p qs1)) (get_subsets_R (calculate_data_R p qs2))) = (get_subsets_R (snd ((combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2)))))"  
     using Pair_inject combining_to_smash get_subsets_R_def prod.collapse smash_systems_R_def
     by (smt (z3) combine_systems_R.simps)
   have "well_def_signs (length qs1) (get_signs_R (calculate_data_R p qs1))" 
     using calculate_data_satisfies_properties_R
     using nontriv1 nonzero nonzero satisfies_properties_R_def
     by auto 
   then have well_def_signs1: "(\<And>j. j \<in> set (get_signs_R (calculate_data_R p qs1)) \<Longrightarrow> length j = (length qs1))"
     using well_def_signs_def by blast 
   have "all_list_constr_R (get_subsets_R(calculate_data_R p qs1))  (length qs1) "
     using calculate_data_satisfies_properties_R
     using nontriv1 nonzero nonzero satisfies_properties_R_def
     by auto 
   then have well_def_subsets1: "(\<And>l i. l \<in> set (get_subsets_R(calculate_data_R p qs1)) \<Longrightarrow> (i \<in> set (fst l) \<longrightarrow> i < (length qs1)) \<and> (i \<in> set (snd l) \<longrightarrow> i < (length qs1)))"
     unfolding all_list_constr_R_def list_constr_def 
     using in_set_member
     by (metis in_set_conv_nth list_all_length) 
   have extra_matrix_same: "matrix_A_R (signs_smash (get_signs_R (calculate_data_R p qs1)) (get_signs_R (calculate_data_R p qs2)))
          (subsets_smash_R (length qs1) (get_subsets_R(calculate_data_R p qs1)) (get_subsets_R (calculate_data_R p qs2))) 
         = kronecker_product (get_matrix_R (calculate_data_R p qs1)) (get_matrix_R (calculate_data_R p qs2))"
     using  well_def_signs1 well_def_subsets1
     using matrix_construction_is_kronecker_product_R
     using calculate_data_satisfies_properties_R nontriv1 nontriv2 nonzero  nonzero satisfies_properties_R_def 
     by fastforce
   then have matrix_same: "matrix_A_R ?signs ?subsets = kronecker_product (get_matrix_R (calculate_data_R p qs1)) (get_matrix_R (calculate_data_R p qs2))"
     using clear_signs clear_subsets
     by simp
   have comb_sys_h: "snd(snd(reduce_system_R p (combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2)))) =
       snd(snd(reduce_system_R p (qs1@qs2, (matrix_A_R ?signs ?subsets, (?subsets, ?signs)))))"
     unfolding get_signs_R_def get_subsets_R_def using matrix_same
     by (metis (full_types) clear_signs clear_subsets combine_systems_R.simps get_signs_R_def get_subsets_R_def getter_functions_R smash_systems_R_def)
   then have extra_h: " snd(snd(reduce_system_R p (qs1@qs2, (matrix_A_R ?signs ?subsets, (?subsets, ?signs))))) = 
       snd(snd(reduction_step_R (matrix_A_R ?signs ?subsets) ?signs ?subsets (solve_for_lhs_R p (qs1@qs2) ?subsets (matrix_A_R ?signs ?subsets)))) "
     by simp
   then have same_h: "set(snd(snd(reduce_system_R p (combine_systems_R p (qs1,calculate_data_R p qs1) (qs2,calculate_data_R p qs2))))) 
       = set (reduction_signs_R p (qs1@qs2) ?signs ?subsets  (matrix_A_R ?signs ?subsets ))"
     using comb_sys_h unfolding reduction_signs_R_def
     by (metis get_signs_R_def help_h reduction_signs_is_get_signs_R) 
   then show ?thesis using h
     by blast 
 qed
 
 lemma find_consistent_signs_at_roots_1_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   shows "(p \<noteq> 0 \<and> length qs > 0) \<longrightarrow> 
     set(find_consistent_signs_at_roots_R p qs) = set(characterize_consistent_signs_at_roots p qs)"
 proof (induction "length qs" arbitrary: qs rule: less_induct)
   case less 
   then show ?case
   proof clarsimp
     assume ind_hyp: "(\<And>qsa.
         length qsa < length qs \<Longrightarrow> qsa \<noteq> [] \<longrightarrow>
         set (find_consistent_signs_at_roots_R p qsa) =
         set (characterize_consistent_signs_at_roots p qsa))"
     assume nonzero: "p \<noteq> 0"  
     assume nontriv: "qs \<noteq> []"
     let ?len = "length qs"
     let ?q1 = "take ((?len) div 2) qs"
     let ?left = "calculate_data_R p ?q1"
     let ?q2 = "drop ((?len) div 2) qs"
     let ?right = "calculate_data_R p ?q2"
     have nontriv_q1: "length qs>1 \<longrightarrow> length ?q1 > 0" 
       by auto
     have qs_more_q1: "length qs>1 \<longrightarrow> length qs > length ?q1" 
       by auto
     have nontriv_q2: "length qs>1 \<longrightarrow>length ?q2 > 0" 
       by auto
     have qs_more_q2: "length qs>1 \<longrightarrow> length qs > length ?q2" 
       by auto
     have key_h: "set (snd (snd (if ?len \<le> Suc 0 then reduce_system_R p (qs, base_case_info_R)
                         else   Let (combine_systems_R p (?q1, ?left) (?q2, ?right))
                                   (reduce_system_R p)))) =
        set (characterize_consistent_signs_at_roots p qs)" 
     proof - 
       have h_len1 : "?len = 1 \<longrightarrow> set (snd (snd (if ?len \<le> Suc 0 then reduce_system_R p (qs, base_case_info_R)
                         else   Let (combine_systems_R p (?q1, ?left) (?q2, ?right))
                                   (reduce_system_R p)))) =
        set (characterize_consistent_signs_at_roots p qs)" 
         using find_consistent_signs_at_roots_len1_R[of p qs] nonzero nontriv
         by (simp add: find_consistent_signs_at_roots_thm_R)
       have h_len_gt1 : "?len > 1 \<longrightarrow> set (snd (snd (if ?len \<le> Suc 0 then reduce_system_R p (qs, base_case_info_R)
                         else   Let (combine_systems_R p (?q1, ?left) (?q2, ?right))
                                   (reduce_system_R p)))) =
        set (characterize_consistent_signs_at_roots p qs)" 
       proof - 
         have h_imp_a: "?len > 1 \<longrightarrow> set (snd (snd (reduce_system_R p (combine_systems_R p (?q1, ?left) (?q2, ?right))))) =
               set (characterize_consistent_signs_at_roots p qs)"
         proof - 
           have h1: "?len > 1 \<longrightarrow> set(snd(snd(?left))) = set (characterize_consistent_signs_at_roots p ?q1)"
             using nontriv_q1 ind_hyp[of ?q1] qs_more_q1             
             by (metis find_consistent_signs_at_roots_thm_R less_numeral_extra(3) list.size(3))
           have h2: "?len > 1 \<longrightarrow> set(snd(snd(?right))) = set (characterize_consistent_signs_at_roots p ?q2)"
             using nontriv_q2 ind_hyp[of ?q2] qs_more_q2
             by (metis (full_types) find_consistent_signs_at_roots_thm_R list.size(3) not_less_zero)
           show ?thesis using nonzero nontriv_q1 nontriv_q2 h1 h2 smaller_sys_are_good_R             
             by (metis append_take_drop_id find_consistent_signs_at_roots_thm_R)
         qed
         then have h_imp: "?len > 1 \<longrightarrow> set (snd (snd (Let (combine_systems_R p (?q1, ?left) (?q2, ?right))
                                   (reduce_system_R p)))) =
        set (characterize_consistent_signs_at_roots p qs)"
           by auto
         then show ?thesis by auto 
       qed
       show ?thesis using h_len1 h_len_gt1
         by (meson \<open>qs \<noteq> []\<close> length_0_conv less_one nat_neq_iff) 
     qed
     then show "set (find_consistent_signs_at_roots_R p qs) = set (characterize_consistent_signs_at_roots p qs)"
       using One_nat_def calculate_data.simps find_consistent_signs_at_roots_thm length_0_conv nontriv
       by (smt (z3) calculate_data_R.simps find_consistent_signs_at_roots_thm_R)
   qed
 qed
 
 lemma find_consistent_signs_at_roots_0_R:
   fixes p:: "real poly"
   assumes "p \<noteq> 0"
   shows "set(find_consistent_signs_at_roots_R p []) =
          set(characterize_consistent_signs_at_roots p [])"
 proof -
   obtain a b c where abc: "reduce_system_R p ([1], base_case_info_R) = (a,b,c)"
     using prod_cases3 by blast 
   have "find_consistent_signs_at_roots_R p [1] = c" using abc
     by (simp add: find_consistent_signs_at_roots_thm_R) 
   have *: "set (find_consistent_signs_at_roots_R p [1]) = set (characterize_consistent_signs_at_roots p [1])"
     apply (subst find_consistent_signs_at_roots_1_R)
     using assms by auto
   have "set(characterize_consistent_signs_at_roots p []) = drop 1 ` set(characterize_consistent_signs_at_roots p [1])"
     unfolding characterize_consistent_signs_at_roots_def consistent_sign_vec_def signs_at_def squash_def apply simp
     using drop0 drop_Suc_Cons image_cong image_image 
   proof -
     have "(\<lambda>r. []) ` set (characterize_root_list_p p) = (\<lambda>r. drop (Suc 0) [1::rat]) ` set (characterize_root_list_p p)"
       by force
     then show "(\<lambda>r. []) ` set (characterize_root_list_p p) = drop (Suc 0) ` (\<lambda>r. [1::rat]) ` set (characterize_root_list_p p)"
       by blast
   qed 
   thus ?thesis using abc *
     apply (auto) apply (simp add: find_consistent_signs_at_roots_thm_R)
     by (simp add: find_consistent_signs_at_roots_thm_R) 
 qed
 
 lemma find_consistent_signs_at_roots_R:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   assumes "p \<noteq> 0"
   shows "set(find_consistent_signs_at_roots_R p qs) = set(characterize_consistent_signs_at_roots p qs)"
   by (metis assms find_consistent_signs_at_roots_0_R find_consistent_signs_at_roots_1_R length_greater_0_conv)
 
 end
\ No newline at end of file
diff --git a/thys/Differential_Dynamic_Logic/Lib.thy b/thys/Differential_Dynamic_Logic/Lib.thy
--- a/thys/Differential_Dynamic_Logic/Lib.thy
+++ b/thys/Differential_Dynamic_Logic/Lib.thy
@@ -1,469 +1,469 @@
 theory Lib
 imports
   Ordinary_Differential_Equations.ODE_Analysis
 begin
 section \<open>Generic Mathematical Lemmas\<close>
 text\<open>General lemmas that don't have anything to do with dL specifically and could be fit for 
   general-purpose libraries, mostly dealing with derivatives, ODEs and vectors.\<close>
 
 lemma vec_extensionality:"(\<And>i. v$i = w$i) \<Longrightarrow> (v = w)"
   by (simp add: vec_eq_iff)
 
 lemma norm_axis: "norm (axis i x) = norm x"
   unfolding axis_def norm_vec_def
   unfolding L2_set_def
   by(clarsimp simp add: if_distrib[where f=norm] if_distrib[where f="\<lambda>x. x\<^sup>2"] sum.If_cases)
 
 lemma bounded_linear_axis: "bounded_linear (axis i)"
 proof
   show "axis i (x + y) = axis i x + axis i y" "axis i (r *\<^sub>R x) = r *\<^sub>R axis i x" for x y :: "'a" and r
     by (auto simp: vec_eq_iff axis_def)
   show "\<exists>K. \<forall>x::'a. norm (axis i x) \<le> norm x * K"
     by (auto simp add: norm_axis intro!: exI[of _ 1])
 qed
 
 lemma bounded_linear_vec:
   fixes f::"('a::finite) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> 'c::real_normed_vector"
   assumes bounds:"\<And>i. bounded_linear (f i)"
   shows "bounded_linear (\<lambda>x. \<chi> i. f i x)"
 proof unfold_locales
   fix r x y
   interpret bounded_linear "f i" for i by fact
   show "(\<chi> i. f i (x + y)) = (\<chi> i. f i x) + (\<chi> i. f i y)"
     by (vector add)
   show "(\<chi> i. f i (r *\<^sub>R x)) = r *\<^sub>R (\<chi> i. f i x)"
     by (vector scaleR)
   obtain K where "norm (f i x) \<le> norm x * K i" for x i
     using bounded by metis
   then have "norm (\<chi> i. f i x) \<le> norm x * (\<Sum>i\<in>UNIV. K i)" (is "?lhs \<le> ?rhs") for x
     unfolding sum_distrib_left
     unfolding norm_vec_def
     by (auto intro!: L2_set_le_sum_abs[THEN order_trans] sum_mono simp: abs_mult)
   then show "\<exists>K. \<forall>x. norm (\<chi> i. f i x) \<le> norm x * K"
     by blast
 qed
 
 lift_definition blinfun_vec::"('a::finite \<Rightarrow> 'b::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b \<Rightarrow>\<^sub>L (real ^ 'a)" is "(\<lambda>(f::('a \<Rightarrow> 'b \<Rightarrow> real)) (x::'b). \<chi> (i::'a). f i x)"
   by(rule bounded_linear_vec, simp)  
 
 lemmas blinfun_vec_simps[simp] = blinfun_vec.rep_eq
 
 lemma continuous_blinfun_vec:"(\<And>i. continuous_on UNIV (blinfun_apply (g i))) \<Longrightarrow> continuous_on UNIV (blinfun_vec g)"
   by (simp add: continuous_on_vec_lambda)  
 
 lemma blinfun_elim:"\<And>g. (blinfun_apply (blinfun_vec g)) = (\<lambda>x. \<chi> i. g i x)"
   using blinfun_vec.rep_eq by auto
 
 lemma sup_plus:
   fixes f g::"('b::metric_space) \<Rightarrow> real"
   assumes nonempty:"R \<noteq> {}"
   assumes bddf:"bdd_above (f ` R)"
   assumes bddg:"bdd_above (g ` R)"
   shows "(SUP x\<in>R. f x  + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x)"
 proof -
   have bddfg:"bdd_above((\<lambda>x. f x + g x ) ` R)" 
     using bddf bddg apply (auto simp add: bdd_above_def)
     using add_mono_thms_linordered_semiring(1) by blast
   have eq:"(SUP x\<in>R. f x + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x)
     \<longleftrightarrow> (\<forall>x\<in>R. (f x + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x))"
     apply(rule cSUP_le_iff)
      subgoal by (rule nonempty)
     subgoal by (rule bddfg)
     done
   have fs:"\<And>x. x \<in> R \<Longrightarrow> f x \<le> (SUP x\<in>R. f x)"
     using bddf 
     by (simp add: cSUP_upper)
   have gs:"\<And>x. x \<in> R \<Longrightarrow> g x \<le> (SUP x\<in>R. g x)"
     using bddg
     by (simp add: cSUP_upper)
   have "(\<forall>x\<in>R. (f x + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x))"
     apply auto                    
     subgoal for x using fs[of x] gs[of x] by auto
     done
   then show ?thesis by (auto simp add: eq)
 qed
      
 lemma continuous_blinfun_vec':
   fixes f::"'a::{finite,linorder} \<Rightarrow> 'b::{metric_space, real_normed_vector,abs} \<Rightarrow> 'b \<Rightarrow>\<^sub>L real"
   fixes S::"'b set"
   assumes conts:"\<And>i. continuous_on UNIV (f i)"
   shows "continuous_on UNIV (\<lambda>x. blinfun_vec (\<lambda> i. f i x))"
 proof (auto simp add:  LIM_def continuous_on_def)
   fix x1 and \<epsilon>::real
   assume \<epsilon>:"0 < \<epsilon>"
   let ?n = "card (UNIV::'a set)"
   have conts':" \<And>i x1 \<epsilon>. 0 < \<epsilon> \<Longrightarrow> \<exists>\<delta>>0. \<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < \<delta> \<longrightarrow> dist (f i  x2) (f i x1) < \<epsilon>"  
     using conts by(auto simp add: LIM_def continuous_on_def)
   have conts'':"\<And>i. \<exists>\<delta>>0. \<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < \<delta> \<longrightarrow> dist (f i  x2) (f i x1) < (\<epsilon>/?n)"
     subgoal for i using conts'[of "\<epsilon> / ?n"  x1 i] \<epsilon> by auto done
   let ?f = "(\<lambda>x. blinfun_vec (\<lambda> i. f i x))"
   let ?P\<delta> = "(\<lambda> i \<delta>. (\<delta>>0 \<and> (\<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < \<delta> \<longrightarrow> dist (f i  x2) (f i x1) < (\<epsilon>/?n))))"
   let ?\<delta>i = "(\<lambda>i. SOME \<delta>. ?P\<delta> i \<delta>)"
   have Ps:"\<And>i. \<exists>\<delta>. ?P\<delta> i \<delta>" using conts'' by auto
   have P\<delta>i:"\<And>i. ?P\<delta> i (?\<delta>i i)"
     subgoal for i using someI[of "?P\<delta> i" ] Ps[of i] by auto done
   have finU:"finite (UNIV::'a set)" by auto
   let ?\<delta> = "linorder_class.Min  (?\<delta>i ` UNIV)"
   have \<delta>0s:"\<And>i. ?\<delta>i i > 0" using P\<delta>i by blast
   then have \<delta>0s':"\<And>i. 0 < ?\<delta>i i" by auto
   have bounds:"bdd_below (?\<delta>i ` UNIV)" 
     unfolding bdd_below_def 
     using \<delta>0s less_eq_real_def by blast
   have \<delta>s:"\<And>i. ?\<delta> \<le> ?\<delta>i i"
     using bounds cINF_lower[of ?\<delta>i] by auto
   have finite:"finite ((?\<delta>i ` UNIV))" by auto
   have nonempty:"((?\<delta>i ` UNIV)) \<noteq> {}" by auto
   have \<delta>:"?\<delta> > 0 " using Min_gr_iff[OF finite nonempty] \<delta>0s' 
     by blast
   have conts''':"\<And>i x2. x2 \<noteq> x1 \<Longrightarrow> dist x2 x1 < ?\<delta>i i \<Longrightarrow> dist (f i  x2) (f i x1) < (\<epsilon>/?n)"
     subgoal for i x2 
       using conts''[of i] apply auto
       subgoal for \<delta>
         apply(erule allE[where x=x2])
         using P\<delta>i  \<delta>s[of i] apply (auto simp add: \<delta>s[of i])
         done
       done
     done
   have "\<And>x2. x2 \<noteq> x1 \<and> dist x2 x1 < ?\<delta> \<Longrightarrow> dist (blinfun_vec (\<lambda>i. f i x2)) (blinfun_vec (\<lambda>i. f i x1)) < \<epsilon>"
   proof (auto)
     fix x2
     assume ne:"x2 \<noteq> x1"
     assume dist:"\<forall>i. dist x2 x1 < ?\<delta>i i"
     have dists:"\<And>i. dist x2 x1 < ?\<delta>i i"
       subgoal for i using dist \<delta>s[of i] by auto done
     have euclid:"\<And>y. norm(?f x1 y - ?f x2 y) = (L2_set (\<lambda>i. norm(f i x1 y - f i x2 y)) UNIV)"
       by (simp add: norm_vec_def)
     have finite:"finite (UNIV::'a set)" by auto
     have nonempty: "(UNIV::'a set) \<noteq> {}" by auto
     have nonemptyB: "(UNIV::'b set) \<noteq> {}" by auto
     have nonemptyR: "(UNIV::real set) \<noteq> {}" by auto
     have SUP_leq:"\<And>f::('b \<Rightarrow> real). \<And> g::('b \<Rightarrow> real). \<And> S::'b set. S \<noteq> {} \<Longrightarrow> bdd_above (g ` S) \<Longrightarrow> (\<And>x. x \<in> (S::'b set) \<Longrightarrow> ((f x)::real) \<le> ((g x)::real)) \<Longrightarrow> (SUP x\<in>S. f x) \<le> (SUP x\<in>S. g x)"
       by(rule cSup_mono, auto)
     have SUP_sum_comm':"\<And>R S f . finite (S::'a set) \<Longrightarrow> (R::'d::metric_space set) \<noteq> {} \<Longrightarrow>
       (\<And>i x. ((f i x)::real) \<ge> 0) \<Longrightarrow>
       (\<And>i. bdd_above (f i ` R)) \<Longrightarrow>
       (SUP x\<in>R . (\<Sum>i \<in> S. f i x)) \<le> (\<Sum>i \<in> S. (SUP x\<in>R. f i x))"
     proof -
       fix  R::"'d set" and S ::"('a)set"  and f  ::"'a \<Rightarrow> 'd \<Rightarrow> real"
       assume non:"R \<noteq> {} "
       assume fin:"finite S"
       assume every:"(\<And>i x. 0 \<le> f i x)"
       assume bddF:"\<And>i. bdd_above (f i ` R)"
       then have bddF':"\<And>i. \<exists>M. \<forall>x \<in>R. f i x \<le> M "
         unfolding bdd_above_def by auto
       let ?boundP = "(\<lambda>i M. \<forall>x \<in>R. f i x \<le> M)"
       let ?bound = "(\<lambda>i::'a. SOME M. \<forall>x \<in>R. f i x \<le> M)"
       have "\<And>i. \<exists>M. ?boundP i M" using bddF' by auto
       then have each_bound:"\<And>i. ?boundP i (?bound i)" 
         subgoal for i using someI[of "?boundP i"] by blast done
       let ?bigBound = "(\<lambda>F. \<Sum>i\<in>F. (?bound i))"
       have bddG:"\<And>i::'a. \<And>F. bdd_above ((\<lambda>x. \<Sum>i\<in>F. f i x) ` R)" 
         subgoal for i F
           using bddF[of i] unfolding bdd_above_def apply auto
           apply(rule exI[where x="?bigBound F"])
           subgoal for M
             apply auto
             subgoal for x
               using each_bound by (simp add: sum_mono)
             done
           done
         done
       show "?thesis R S f" using fin assms
       proof (induct)
         case empty
         have "((SUP x\<in>R. \<Sum>i\<in>{}. f i x)::real) \<le> (\<Sum>i\<in>{}. SUP a\<in>R. f i a)"   by (simp add: non)
         then show ?case by auto
       next
         case (insert x F)
         have "((SUP xa\<in>R. \<Sum>i\<in>insert x F. f i xa)::real) \<le> (SUP xa\<in>R. f x xa +  (\<Sum>i\<in>F. f i xa))"
           using insert.hyps(2) by auto
         moreover have "...  \<le> (SUP xa\<in> R. f x xa) + (SUP xa\<in>R. (\<Sum>i\<in>F. f i xa))"
           by(rule sup_plus, rule non, rule bddF, rule bddG)
         moreover have "... \<le> (SUP xa\<in> R. f x xa) + (\<Sum>i\<in>F. SUP a\<in>R. f i a)"
           using add_le_cancel_left conts insert.hyps(3) by blast
         moreover have "... \<le> (\<Sum>i\<in>(insert x F). SUP a\<in>R. f i a)"
           by (simp add: insert.hyps(2))
         ultimately have "((SUP xa\<in>R. \<Sum>i\<in>insert x F. f i xa)::real) \<le> (\<Sum>i\<in>(insert x F). SUP a\<in>R. f i a)"
           by linarith
         then show ?case by auto
       qed
     qed
     have SUP_sum_comm:"\<And>R S y1 y2 . finite (S::'a set) \<Longrightarrow> (R::'b set) \<noteq> {} \<Longrightarrow> (SUP x\<in>R . (\<Sum>i \<in> S. norm(f i y1 x - f i y2 x)/norm(x))) \<le> (\<Sum>i \<in> S. (SUP x\<in>R. norm(f i y1 x - f i y2 x)/norm(x)))"
       apply(rule SUP_sum_comm')
          apply(auto)[3]
       proof (unfold bdd_above_def)
         fix R S y1 y2 i
           { fix rr :: "real \<Rightarrow> real"
             obtain bb :: "real \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> 'b set \<Rightarrow> 'b" where
               ff1: "\<And>r f B. r \<notin> f ` B \<or> f (bb r f B) = r"
-              by moura
+              unfolding image_iff by moura
             { assume "\<exists>r. \<not> rr r \<le> norm (f i y1 - f i y2)"
               then have "\<exists>r. norm (blinfun_apply (f i y1) (bb (rr r) (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) R) - blinfun_apply (f i y2) (bb (rr r) (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) R)) / norm (bb (rr r) (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) R) \<noteq> rr r"
                 by (metis (no_types) le_norm_blinfun minus_blinfun.rep_eq)
               then have "\<exists>r. rr r \<le> r \<or> rr r \<notin> (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) ` R"
                 using ff1 by meson }
               then have "\<exists>r. rr r \<le> r \<or> rr r \<notin> (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) ` R"
                 by blast }
         then show "\<exists>r. \<forall>ra\<in>(\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) ` R. ra \<le> r"
           by meson
       qed
     have SUM_leq:"\<And>S::('a) set. \<And> f g ::('a \<Rightarrow> real). S \<noteq> {} \<Longrightarrow> finite S \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> f x < g x) \<Longrightarrow> (\<Sum>x\<in>S. f x) < (\<Sum>x\<in>S. g x)"
       by(rule sum_strict_mono, auto)
     have L2:"\<And>f S. L2_set (\<lambda>x. norm(f x)) S \<le> (\<Sum>x \<in> S. norm(f x))"
       using L2_set_le_sum norm_ge_zero by metis
     have L2':"\<And>y. (L2_set (\<lambda>i. norm(f i x1 y - f i x2 y)) UNIV)/norm(y) \<le> (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y))/norm(y)"
       subgoal for y
         using L2[of "(\<lambda> x. f x x1 y - f x x2 y)" UNIV]
         by (auto simp add: divide_right_mono)
       done
     have "\<And>i. (SUP y\<in>UNIV.  norm((f i x1 - f i x2) y)/norm(y)) = norm(f i x1 - f i x2)"
       by (simp add: onorm_def norm_blinfun.rep_eq)
     then have each_norm:"\<And>i. (SUP y\<in>UNIV.  norm(f i x1 y - f i x2 y)/norm(y)) = norm(f i x1 - f i x2)"
       by (metis (no_types, lifting) SUP_cong blinfun.diff_left)
     have bounded_linear:"\<And>i. bounded_linear (\<lambda>y. f i x1 y - f i x2 y)" 
       by (simp add: blinfun.bounded_linear_right bounded_linear_sub)
     have each_bound:"\<And>i. bdd_above ((\<lambda>y. norm(f i x1 y - f i x2 y)/norm(y)) ` UNIV)"
       using bounded_linear unfolding bdd_above_def
     proof -
       fix i :: 'a
       { fix rr :: "real \<Rightarrow> real"
         have "\<And>a r. norm (blinfun_apply (f a x1) r - blinfun_apply (f a x2) r) / norm r \<le> norm (f a x1 - f a x2)"
           by (metis le_norm_blinfun minus_blinfun.rep_eq)
         then have "\<And>r R. r \<notin> (\<lambda>r. norm (blinfun_apply (f i x1) r - blinfun_apply (f i x2) r) / norm r) ` R \<or> r \<le> norm (f i x1 - f i x2)"
           by blast
         then have "\<exists>r. rr r \<le> r \<or> rr r \<notin> range (\<lambda>r. norm (blinfun_apply (f i x1) r - blinfun_apply (f i x2) r) / norm r)"
           by blast }
       then show "\<exists>r. \<forall>ra\<in>range (\<lambda>r. norm (blinfun_apply (f i x1) r - blinfun_apply (f i x2) r) / norm r). ra \<le> r"
         by meson
     qed
     have bdd_above:"(bdd_above ((\<lambda>y. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y)/norm(y))) ` UNIV))"
       using each_bound unfolding bdd_above_def apply auto
     proof -
       assume each:"(\<And>i. \<exists>M. \<forall>x. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x \<le> M)"
       let ?boundP = "(\<lambda>i M. \<forall>x. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x \<le> M)"
       let ?bound = "(\<lambda>i. SOME x. ?boundP i x)"
       have bounds:"\<And>i. ?boundP i (?bound i)"
         subgoal for i using each someI[of "?boundP i"] by blast done
       let ?bigBound = "\<Sum>i\<in>(UNIV::'a set). ?bound i"
       show "\<exists>M. \<forall>x. (\<Sum>i\<in>UNIV. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x) \<le> M"
         apply(rule exI[where x= ?bigBound])
         by(auto simp add: bounds sum_mono) 
     qed
     have bdd_above:"(bdd_above ((\<lambda>y. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y))/norm(y)) ` UNIV))"
       using bdd_above unfolding bdd_above_def apply auto
     proof -
       fix M :: real
       assume a1: "\<forall>x. (\<Sum>i\<in>UNIV. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x) \<le> M"
       { fix bb :: "real \<Rightarrow> 'b"
         have "\<And>b. (\<Sum>a\<in>UNIV. \<bar>blinfun_apply (f a x1) b - blinfun_apply (f a x2) b\<bar>) / norm b \<le> M"
           using a1 by (simp add: sum_divide_distrib)
         then have "\<exists>r. (\<Sum>a\<in>UNIV. \<bar>blinfun_apply (f a x1) (bb r) - blinfun_apply (f a x2) (bb r)\<bar>) / norm (bb r) \<le> r"
           by blast }
       then show "\<exists>r. \<forall>b. (\<Sum>a\<in>UNIV. \<bar>blinfun_apply (f a x1) b - blinfun_apply (f a x2) b\<bar>) / norm b \<le> r"
         by meson
     qed 
     have "dist (?f x2) (?f x1) = norm((?f x2) - (?f x1))"
       by (simp add: dist_blinfun_def)
     moreover have "... = (SUP y\<in>UNIV. norm(?f x1 y - ?f x2 y)/norm(y))"
       by (metis (no_types, lifting) SUP_cong blinfun.diff_left norm_blinfun.rep_eq norm_minus_commute onorm_def)
     moreover have "... = (SUP y\<in>UNIV. (L2_set (\<lambda>i. norm(f i x1 y - f i x2 y)) UNIV)/norm(y))"
       using  euclid by auto
     moreover have "... \<le> (SUP y\<in>UNIV. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y))/norm(y))"
       using L2' SUP_cong SUP_leq bdd_above by auto
     moreover have "... = (SUP y\<in>UNIV. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y)/norm(y)))"
       by (simp add: sum_divide_distrib)
     moreover have "... \<le> (\<Sum>i\<in>UNIV. (SUP y\<in>UNIV.  norm(f i x1 y - f i x2 y)/norm(y)))"
       by(rule SUP_sum_comm[OF finite  nonemptyB, of x1 x2]) 
     moreover have "... = (\<Sum>i\<in>UNIV. norm(f i x1 - f i x2))"
       using each_norm by simp
     moreover have "... = (\<Sum>i\<in>UNIV. dist(f i x1) (f i x2))"
       by (simp add: dist_blinfun_def)
     moreover have "... < (\<Sum>i\<in>(UNIV::'a set). \<epsilon> / ?n)"
       using conts'''[OF ne dists] using SUM_leq[OF nonempty, of "(\<lambda>i.  dist (f i x1) (f i x2))" "(\<lambda>i.  \<epsilon> / ?n)"]
       by (simp add: dist_commute)
     moreover have "... = \<epsilon>"
       by(auto)
     ultimately show "dist (?f x2) (?f x1) < \<epsilon>"
       by linarith
   qed
   then show "\<exists>s>0. \<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < s \<longrightarrow> dist (blinfun_vec (\<lambda>i. f i x2)) (blinfun_vec (\<lambda>i. f i x1)) < \<epsilon>"
     using \<delta> by blast
 qed
 
 lemma has_derivative_vec[derivative_intros]:
   assumes "\<And>i. ((\<lambda>x. f i x) has_derivative (\<lambda>h. f' i h)) F"
   shows "((\<lambda>x. \<chi> i. f i x) has_derivative (\<lambda>h. \<chi> i. f' i h)) F"
 proof -
   have *: "(\<chi> i. f i x) = (\<Sum>i\<in>UNIV. axis i (f i x))" "(\<chi> i. f' i x) = (\<Sum>i\<in>UNIV. axis i (f' i x))" for x
     by (simp_all add: axis_def sum.If_cases vec_eq_iff)
   show ?thesis
     unfolding *
     by (intro has_derivative_sum bounded_linear.has_derivative[OF bounded_linear_axis] assms)
 qed
 
 lemma has_derivative_proj:
   fixes j::"('a::finite)" 
   fixes f::"'a \<Rightarrow> real \<Rightarrow> real"
   assumes assm:"((\<lambda>x. \<chi> i. f i x) has_derivative (\<lambda>h. \<chi> i. f' i h)) F"
   shows "((\<lambda>x. f j x) has_derivative (\<lambda>h. f' j h)) F"
 proof -
   have bounded_proj:"bounded_linear (\<lambda> x::(real^'a). x $ j)"
     by (simp add: bounded_linear_vec_nth)
   show "?thesis"
     using bounded_linear.has_derivative[OF bounded_proj, of "(\<lambda>x. \<chi> i. f i x)" "(\<lambda>h. \<chi> i. f' i h)", OF assm]
     by auto
 qed
 
 lemma has_derivative_proj':
   fixes i::"'a::finite"
   shows "\<forall>x. ((\<lambda> x. x $ i) has_derivative (\<lambda>x::(real^'a). x $ i)) (at x)"
 proof -
   have bounded_proj:"bounded_linear (\<lambda> x::(real^'a). x $ i)"
     by (simp add: bounded_linear_vec_nth)
   show "?thesis"
     using bounded_proj unfolding has_derivative_def by auto
 qed
 
 lemma constant_when_zero:
   fixes v::"real \<Rightarrow> (real, 'i::finite) vec"
   assumes x0: "(v t0) $ i = x0"
   assumes sol: "(v solves_ode f) T S"
   assumes f0: "\<And>s x. s \<in> T \<Longrightarrow> f s x $ i = 0"
   assumes t0:"t0 \<in> T"
   assumes t:"t \<in> T"
   assumes convex:"convex T"
   shows "v t $ i = x0"
 proof -
   from solves_odeD[OF sol]
   have deriv: "(v has_vderiv_on (\<lambda>t. f t (v t))) T" by simp
   then have "((\<lambda>t. v t $ i) has_vderiv_on (\<lambda>t. 0)) T"
     using f0
     by (auto simp: has_vderiv_on_def has_vector_derivative_def cart_eq_inner_axis
       intro!: derivative_eq_intros)
   from has_vderiv_on_zero_constant[OF convex this]
   obtain c where c:"\<And>x. x \<in> T \<Longrightarrow> v x $ i = c" by blast
   with x0 have "c = x0" "v t $ i = c"
     using t t0 c x0 by blast+
   then show ?thesis by simp
 qed
 
 lemma
   solves_ode_subset:
   assumes x: "(x solves_ode f) T X"
   assumes s: "S \<subseteq> T"
   shows "(x solves_ode f) S X"
   apply(rule solves_odeI)
    using has_vderiv_on_subset s solves_ode_vderivD x apply force
   using assms by (auto intro!: solves_odeI dest!: solves_ode_domainD)
 
 lemma
   solves_ode_supset_range:
   assumes x: "(x solves_ode f) T X"
   assumes y: "X \<subseteq> Y"
   shows "(x solves_ode f) T Y"
   apply(rule solves_odeI)
    using has_vderiv_on_subset y solves_ode_vderivD x apply force
   using assms by (auto intro!: solves_odeI dest!: solves_ode_domainD)
 
 lemma
   usolves_ode_subset:
   assumes x: "(x usolves_ode f from t0) T X"
   assumes s: "S \<subseteq> T"
   assumes t0: "t0 \<in> S"
   assumes S: "is_interval S"
   shows "(x usolves_ode f from t0) S X"
 proof (rule usolves_odeI)
   note usolves_odeD[OF x]
   show "(x solves_ode f) S X" by (rule solves_ode_subset; fact)
   show "t0 \<in> S" "is_interval S" by(fact+)
   fix z t
   assume s: "{t0 -- t} \<subseteq> S" and z: "(z solves_ode f) {t0 -- t} X" and z0: "z t0 = x t0"
   then have "t0 \<in> {t0 -- t}" "is_interval {t0 -- t}"
     by auto
   moreover note s
   moreover have "(z solves_ode f) {t0--t} X"
     using solves_odeD[OF z] \<open>S \<subseteq> T\<close>
     by (intro solves_ode_subset_range[OF z]) force
   moreover note z0
   moreover have "t \<in> {t0 -- t}" by simp
   ultimately show "z t = x t"
     by (meson \<open>\<And>z ta T'. \<lbrakk>t0 \<in> T'; is_interval T'; T' \<subseteq> T; (z solves_ode f) T' X; z t0 = x t0; ta \<in> T'\<rbrakk> \<Longrightarrow> z ta = x ta\<close> assms(2) dual_order.trans)
 qed
 
 \<comment> \<open>Example of using lemmas above to show a lemma that could be useful for dL: The constant ODE\<close>
 \<comment> \<open>0 does not change the state.\<close>
 lemma example:
   fixes x t::real and i::"('sz::finite)"
   assumes "t > 0"
   shows "x = (ll_on_open.flow UNIV (\<lambda>t. \<lambda>x. \<chi> (i::('sz::finite)). 0) UNIV 0 (\<chi> i. x) t) $ i"
 proof -
   let ?T = UNIV
   let ?f = "(\<lambda>t. \<lambda>x. \<chi> i::('sz::finite). 0)"
   let ?X = UNIV
   let ?t0.0 = 0
   let ?x0.0 = "\<chi> i::('sz::finite). x"
   interpret ll: ll_on_open "UNIV" "(\<lambda>t x. \<chi> i::('sz::finite). 0)" UNIV
     using gt_ex
     by unfold_locales
       (auto simp: interval_def continuous_on_def local_lipschitz_def intro!: lipschitz_intros)
   have foo1:"?t0.0 \<in> ?T" by auto
   have foo2:"?x0.0 \<in> ?X" by auto
   let ?v = "ll.flow  ?t0.0 ?x0.0"
   from ll.flow_solves_ode[OF foo1 foo2]
   have solves:"(ll.flow  ?t0.0 ?x0.0 solves_ode ?f) (ll.existence_ivl  ?t0.0 ?x0.0) ?X"  by (auto)
   then have solves:"(?v solves_ode ?f) (ll.existence_ivl  ?t0.0 ?x0.0) ?X" by auto
   have thex0: "(?v ?t0.0) $ (i::('sz::finite)) = x" by auto
   have sol_help: "(?v solves_ode ?f) (ll.existence_ivl  ?t0.0 ?x0.0) ?X" using solves by auto
   have ivl:"ll.existence_ivl ?t0.0 ?x0.0 = UNIV"
     by (rule ll.existence_ivl_eq_domain)
        (auto intro!: exI[where x=0] simp: vec_eq_iff)
   have sol: "(?v solves_ode ?f) UNIV ?X" using solves ivl by auto
   have thef0: "\<And>t x. ?f t x $ i = 0" by auto
   from constant_when_zero [OF thex0 sol thef0]
   have "?v t $ i = x"
     by auto
   thus ?thesis by auto
  qed
  
 lemma MVT_ivl:
   fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
   assumes fderiv: "\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D)"
   assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x u \<ge> J0"
   assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> a + x *\<^sub>R u \<in> D"
   shows "f (a + u) - f a \<ge> J0"
 proof -
   from MVT_corrected[OF fderiv line_in] obtain t where
     t: "t\<in>Basis \<rightarrow> {0<..<1}" and
     mvt: "f (a + u) - f a = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i)"
     by auto
   note mvt
   also have "\<dots> \<ge> J0"
   proof -
     have J: "\<And>i. i \<in> Basis \<Longrightarrow> J0 \<le> J (a + t i *\<^sub>R u) u"
       using J_ivl t line_in by (auto simp: Pi_iff)
     show ?thesis
       using J
       unfolding atLeastAtMost_iff eucl_le[where 'a='b]
       by auto
   qed
   finally show ?thesis .
 qed
 
 lemma MVT_ivl':
   fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
   assumes fderiv: "(\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D))"
   assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x (a - b) \<ge> J0"
   assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> b + x *\<^sub>R (a - b) \<in> D"
   shows "f a \<ge> f b + J0"
 proof -
   have "f (b + (a - b)) - f b \<ge> J0"
     apply (rule MVT_ivl[OF fderiv ])
       apply assumption
      apply (rule J_ivl) apply assumption
     using line_in
     apply (auto simp: diff_le_eq le_diff_eq ac_simps)
     done
   thus ?thesis
     by (auto simp: diff_le_eq le_diff_eq ac_simps)
 qed
 end
diff --git a/thys/Differential_Game_Logic/Coincidence.thy b/thys/Differential_Game_Logic/Coincidence.thy
--- a/thys/Differential_Game_Logic/Coincidence.thy
+++ b/thys/Differential_Game_Logic/Coincidence.thy
@@ -1,787 +1,786 @@
 theory "Coincidence" 
 imports
   "Lib"
   "Syntax"
   "Denotational_Semantics"
   "Static_Semantics"
   "HOL.Finite_Set"
 begin
 section \<open>Static Semantics Properties\<close>
 
 subsection Auxiliaries
 
 text \<open>The state interpolating \<open>stateinterpol \<nu> \<omega> S\<close> between \<open>\<nu>\<close> and \<open>\<omega>\<close> that is \<open>\<nu>\<close> on \<open>S\<close> and \<open>\<omega>\<close> elsewhere\<close>
 
 definition stateinterpol:: "state \<Rightarrow> state \<Rightarrow> variable set \<Rightarrow> state"
   where
   "stateinterpol \<nu> \<omega> S = (\<lambda>x. if (x\<in>S) then \<nu>(x) else \<omega>(x))"
 
 definition statediff:: "state \<Rightarrow> state \<Rightarrow> variable set"
   where "statediff \<nu> \<omega> = {x. \<nu>(x)\<noteq>\<omega>(x)}"
 
 lemma nostatediff: "x\<notin>statediff \<nu> \<omega> \<Longrightarrow> \<nu>(x)=\<omega>(x)"
   by (simp add: statediff_def)
 
 lemma stateinterpol_empty: "stateinterpol \<nu> \<omega> {} = \<omega>"
 proof
   fix x
   have empty: "\<And>x. \<not>(x\<in>{})" by auto
   show "\<And>x. stateinterpol \<nu> \<omega> {} x = \<omega> x" using empty by (simp add: stateinterpol_def)
 qed
 
 lemma stateinterpol_left [simp]: "x\<in>S \<Longrightarrow> (stateinterpol \<nu> \<omega> S)(x)=\<nu>(x)"
   by (simp add: stateinterpol_def)
 
 lemma stateinterpol_right [simp]: "x\<notin>S \<Longrightarrow> (stateinterpol \<nu> \<omega> S)(x)=\<omega>(x)"
   by (simp add: stateinterpol_def)
 
 lemma Vagree_stateinterpol [simp]: "Vagree (stateinterpol \<nu> \<omega> S) \<nu> S"
   and "Vagree (stateinterpol \<nu> \<omega> S) \<omega> (-S)"
   unfolding Vagree_def by auto
 
 lemma Vagree_ror: "Vagree \<nu> \<nu>' (V\<inter>W) \<Longrightarrow> (\<exists>\<omega>. (Vagree \<nu> \<omega> V \<and> Vagree \<omega> \<nu>' W))"
 proof -
   assume "Vagree \<nu> \<nu>' (V\<inter>W)"
   hence "\<forall>x. x\<in>V\<inter>W \<longrightarrow> \<nu>(x)=\<nu>'(x)" by (simp add: Vagree_def)
   let ?w="stateinterpol \<nu> \<nu>' V"
   have l: "Vagree \<nu> ?w V" by (simp add: Vagree_def)
   have r: "Vagree ?w \<nu>' W \<and> Vagree ?w \<nu>' W" by (simp add: Vagree_def stateinterpol_def \<open>\<forall>x. x\<in>V\<inter>W \<longrightarrow> \<nu> x = \<nu>' x\<close>)
   have "Vagree \<nu> ?w V \<and> Vagree ?w \<nu>' W" using l and r by blast
   thus ?thesis by auto
 qed
 
 
 text \<open>Remark 8 \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close> about simple properties of projections\<close>
 
 lemma restrictto_extends [simp]: "restrictto X V \<supseteq> X"
   by (auto simp add: restrictto_def)
 
 lemma restrictto_compose [simp]: "restrictto (restrictto X V) W = restrictto X (V\<inter>W)"
 proof
   show "restrictto (restrictto X V) W \<subseteq> restrictto X (V\<inter>W)"
     by (auto simp add: restrictto_def Vagree_def)
 next
   show "restrictto X (V\<inter>W) \<subseteq> restrictto (restrictto X V) W" 
   (*by (smt Vagree_ror mem_Collect_eq restrictto_def subsetI)*)
   proof - (* sledgehammer *)
   obtain rr :: "(variable \<Rightarrow> real) set \<Rightarrow> (variable \<Rightarrow> real) set \<Rightarrow> variable \<Rightarrow> real" where
   "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> x0) = (rr x0 x1 \<in> x1 \<and> rr x0 x1 \<notin> x0)"
-  by moura
+    by moura
   then have f1: "\<forall>F Fa. rr Fa F \<in> F \<and> rr Fa F \<notin> Fa \<or> F \<subseteq> Fa"
   by (meson subsetI)
   obtain rra :: "(variable \<Rightarrow> real) \<Rightarrow> variable set \<Rightarrow> (variable \<Rightarrow> real) set \<Rightarrow> variable \<Rightarrow> real" where
   "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x2 \<and> Vagree v3 x0 x1) = (rra x0 x1 x2 \<in> x2 \<and> Vagree (rra x0 x1 x2) x0 x1)"
   by moura
   then have f2: "\<forall>F V f. (f \<notin> {f. \<exists>fa. fa \<in> F \<and> Vagree fa f V} \<or> rra f V F \<in> F \<and> Vagree (rra f V F) f V) \<and> (f \<in> {f. \<exists>fa. fa \<in> F \<and> Vagree fa f V} \<or> (\<forall>fa. fa \<notin> F \<or> \<not> Vagree fa f V))"
   by blast
   moreover
   { assume "\<exists>f. f \<in> X \<and> Vagree f (v4_1 W V (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (rra (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (V \<inter> W) X)) V"
     moreover
     { assume "\<exists>f. f \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree f (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) W"
       then have "rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)} \<notin> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)} \<or> rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)} \<in> {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W}"
       by blast
       then have "{f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)} \<subseteq> {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W}"
       using f1 by meson }
     ultimately have "(\<not> Vagree (rra (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (V \<inter> W) X) (v4_1 W V (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (rra (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (V \<inter> W) X)) V \<or> \<not> Vagree (v4_1 W V (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (rra (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) (V \<inter> W) X)) (rr {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W} {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)}) W) \<or> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)} \<subseteq> {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W}"
     using f2 by meson }
   ultimately have "{f. \<exists>fa. fa \<in> X \<and> Vagree fa f (V \<inter> W)} \<subseteq> {f. \<exists>fa. fa \<in> {f. \<exists>fa. fa \<in> X \<and> Vagree fa f V} \<and> Vagree fa f W}"
   using f1 by (meson Vagree_ror)
   then show ?thesis
   using restrictto_def by presburger
   qed 
 qed
 
 lemma restrictto_antimon [simp]: "W\<supseteq>V \<Longrightarrow> restrictto X W \<subseteq> restrictto X V"
 proof -
   assume "W\<supseteq>V"
   then have "\<exists>U. V=W\<inter>U" by auto
   then obtain U where "V=W\<inter>U" by auto
   hence "restrictto X V = restrictto (restrictto X W) U" by simp
   hence "restrictto X V \<supseteq> restrictto X W" using restrictto_extends by blast
   thus ?thesis by auto
 qed
 
 lemma restrictto_empty [simp]: "X\<noteq>{} \<Longrightarrow> restrictto X {} = worlds"
   by (auto simp add: restrictto_def worlds_def)
 
 lemma selectlike_shrinks [simp]: "selectlike X \<nu> V \<subseteq> X"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_compose [simp]: "selectlike (selectlike X \<nu> V) \<nu> W = selectlike X \<nu> (V\<union>W)"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_antimon [simp]: "W\<supseteq>V \<Longrightarrow> selectlike X \<nu> W \<subseteq> selectlike X \<nu> V"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_empty [simp]: "selectlike X \<nu> {} = X"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_self [simp]: "(\<nu> \<in> selectlike X \<nu> V) = (\<nu>\<in>X)"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_complement [simp]: "selectlike (-X) \<nu> V \<subseteq> -selectlike X \<nu> V"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_union: "selectlike (X\<union>Y) \<nu> V = selectlike X \<nu> V \<union> selectlike Y \<nu> V"
   by (auto simp add: selectlike_def)
 
 lemma selectlike_Sup: "selectlike (Sup M) \<nu> V = Sup {selectlike X \<nu> V | X. X\<in>M}"
   using selectlike_def by auto
 
 lemma selectlike_equal_cond: "(selectlike X \<nu> V = selectlike Y \<nu> V) = (\<forall>\<mu>. Uvariation \<mu> \<nu> (-V) \<longrightarrow> (\<mu>\<in>X) = (\<mu>\<in>Y))"
   unfolding selectlike_def using Uvariation_Vagree by auto
 
 lemma selectlike_equal_cocond: "(selectlike X \<nu> (-V) = selectlike Y \<nu> (-V)) = (\<forall>\<mu>. Uvariation \<mu> \<nu> V \<longrightarrow> (\<mu>\<in>X) = (\<mu>\<in>Y))"
   using selectlike_equal_cond[where V=\<open>-V\<close>] by simp
 
 lemma selectlike_equal_cocond_rule: "(\<And>\<mu>. Uvariation \<mu> \<nu> (-V) \<Longrightarrow> (\<mu>\<in>X) = (\<mu>\<in>Y))
   \<Longrightarrow> (selectlike X \<nu> V = selectlike Y \<nu> V)"
   using selectlike_equal_cond[where V=\<open>V\<close>] by simp
 
 lemma selectlike_equal_cocond_corule: "(\<And>\<mu>. Uvariation \<mu> \<nu> V \<Longrightarrow> (\<mu>\<in>X) = (\<mu>\<in>Y))
   \<Longrightarrow> (selectlike X \<nu> (-V) = selectlike Y \<nu> (-V))"
   using selectlike_equal_cond[where V=\<open>-V\<close>] by simp
 
 lemma co_selectlike: "-(selectlike X \<nu> V) = (-X) \<union> {\<omega>. \<not>Vagree \<omega> \<nu> V}"
   unfolding selectlike_def by auto
 
 lemma selectlike_co_selectlike: "selectlike (-(selectlike X \<nu> V)) \<nu> V = selectlike (-X) \<nu> V"
   unfolding selectlike_def by auto
 
 lemma selectlike_Vagree: "Vagree \<nu> \<omega> V \<Longrightarrow> selectlike X \<nu> V = selectlike X \<omega> V"
   using Vagree_def selectlike_def by auto  
 
 lemma similar_selectlike_mem: "Vagree \<nu> \<omega> V \<Longrightarrow> (\<nu>\<in>selectlike X \<omega> V) = (\<nu>\<in>X)"
   unfolding selectlike_def using Vagree_sym_rel by blast  
 
 (* also see nonBVG_rule *)
 lemma BVG_nonelem [simp] :"(x\<notin>BVG \<alpha>) = (\<forall>I \<omega> X. (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> {x})))"
   using BVG_elem monotone selectlike_shrinks
   by (metis subset_iff)
 
 
 text \<open>\<open>statediff\<close> interoperability\<close>
 
 lemma Vagree_statediff [simp]: "Vagree \<omega> \<omega>' S \<Longrightarrow> statediff \<omega> \<omega>' \<subseteq> -S"
   by (auto simp add: Vagree_def statediff_def)
 
 lemma stateinterpol_diff [simp]: "stateinterpol \<nu> \<omega> (statediff \<nu> \<omega>) = \<nu>"
 proof
   fix x
   show sp: "(stateinterpol \<nu> \<omega> (statediff \<nu> \<omega>))(x) = \<nu>(x)"
   proof (cases "x\<in>statediff \<nu> \<omega>")
     case True
     then show ?thesis by simp
   next
     case False
     then show ?thesis by (simp add: stateinterpol_def nostatediff)
   qed
 qed
 
 lemma stateinterpol_insert: "Vagree (stateinterpol v w S) (stateinterpol v w (insert z S)) (-{z})"
    by (simp add: Vagree_def stateinterpol_def)
 
 
 lemma stateinterpol_FVT [simp]: "z\<notin>FVT(t) \<Longrightarrow> term_sem I t (stateinterpol \<omega> \<omega>' S) = term_sem I t (stateinterpol \<omega> \<omega>' (insert z S))"
 proof -
   assume a: "z\<notin>FVT(t)"
   have fvc: "\<And>v. \<And>w. Vagree v w (-{z}) \<Longrightarrow> (term_sem I t v = term_sem I t w)" using a by (simp add: FVT_def)
   then show "term_sem I t (stateinterpol \<omega> \<omega>' S) = term_sem I t (stateinterpol \<omega> \<omega>' (insert z S))"
     using fvc and stateinterpol_insert by blast
 qed
 
 subsection \<open>Coincidence Lemmas\<close>
 
 paragraph \<open>Coincidence for Terms\<close>
 
 text \<open>Lemma 10 \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close>\<close>
 
 theorem coincidence_term: "Vagree \<omega> \<omega>' (FVT \<theta>) \<Longrightarrow> term_sem I \<theta> \<omega> = term_sem I \<theta> \<omega>'"
 proof -
   assume a: "Vagree \<omega> \<omega>' (FVT \<theta>)"
   have isS: "statediff \<omega> \<omega>' \<subseteq> -FVT(\<theta>)" using a and Vagree_statediff by simp
   have gen: "S\<subseteq>-FVT(\<theta>) \<Longrightarrow> (term_sem I \<theta> \<omega>' = term_sem I \<theta> (stateinterpol \<omega> \<omega>' S))" if "finite S" for S
     using that
   proof (induction S)
     case empty
     show ?case by (simp add: stateinterpol_empty)
   next
     case (insert z S)
     thus ?case by auto
     qed
   from isS have finS: "finite (statediff \<omega> \<omega>')" using allvars_finite by (metis FVT_finite UNIV_def finite_compl rev_finite_subset)
   show ?thesis using gen[where S=\<open>statediff \<omega> \<omega>'\<close>, OF finS, OF isS] by simp
 qed
 
 corollary coincidence_term_cor: "Uvariation \<omega> \<omega>' U \<Longrightarrow> (FVT \<theta>)\<inter>U={} \<Longrightarrow> term_sem I \<theta> \<omega> = term_sem I \<theta> \<omega>'"
 using coincidence_term Uvariation_Vagree
   by (metis Vagree_antimon disjoint_eq_subset_Compl double_compl)
 
   
 lemma stateinterpol_FVF [simp]: "z\<notin>FVF(e) \<Longrightarrow> 
   ((stateinterpol \<omega> \<omega>' S) \<in> fml_sem I e \<longleftrightarrow> (stateinterpol \<omega> \<omega>' (insert z S)) \<in> fml_sem I e)"
 proof -
   assume a: "z\<notin>FVF(e)"
   have agr: "Vagree (stateinterpol \<omega> \<omega>' S) (stateinterpol \<omega> \<omega>' (insert z S)) (-{z})" by (simp add: Vagree_def stateinterpol_def)
   have fvc: "\<And>v. \<And>w. (Vagree v w (-{z}) \<Longrightarrow> (v\<in>fml_sem I e \<Longrightarrow> w\<in>fml_sem I e))" using a by (simp add: FVF_def)
   then have fvce: "\<And>v. \<And>w. (Vagree v w (-{z}) \<Longrightarrow> ((v\<in>fml_sem I e) = (w\<in>fml_sem I e)))"  using Vagree_sym_rel by blast
   then show "(stateinterpol \<omega> \<omega>' S) \<in> fml_sem I e \<longleftrightarrow> (stateinterpol \<omega> \<omega>' (insert z S)) \<in> fml_sem I e"
     using agr by simp
 qed
 
 
 paragraph \<open>Coincidence for Formulas\<close>
 
 text \<open>Lemma 11 \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close>\<close>
 
 theorem coincidence_formula: "Vagree \<omega> \<omega>' (FVF \<phi>) \<Longrightarrow> (\<omega> \<in> fml_sem I \<phi> \<longleftrightarrow> \<omega>' \<in> fml_sem I \<phi>)"
 proof -
   assume a: "Vagree \<omega> \<omega>' (FVF \<phi>)"
   have isS: "statediff \<omega> \<omega>' \<subseteq> -FVF(\<phi>)" using a and Vagree_statediff by simp
   have gen: "S\<subseteq>-FVF(\<phi>) \<Longrightarrow> (\<omega>' \<in> fml_sem I \<phi> \<longleftrightarrow> (stateinterpol \<omega> \<omega>' S) \<in> fml_sem I \<phi>)" if "finite S" for S
     using that
   proof (induction S)
     case empty
     show ?case by (simp add: stateinterpol_empty)
   next
     case (insert z S)
     thus ?case by auto
   qed
   from isS have finS: "finite (statediff \<omega> \<omega>')" using allvars_finite by (metis FVF_finite UNIV_def finite_compl rev_finite_subset)
   show ?thesis using gen[where S=\<open>statediff \<omega> \<omega>'\<close>, OF finS, OF isS] by simp
 qed
 
 corollary coincidence_formula_cor: "Uvariation \<omega> \<omega>' U \<Longrightarrow> (FVF \<phi>)\<inter>U={} \<Longrightarrow> (\<omega> \<in> fml_sem I \<phi> \<longleftrightarrow> \<omega>' \<in> fml_sem I \<phi>)"
   using coincidence_formula Uvariation_Vagree 
   by (metis Uvariation_def disjoint_eq_subset_Compl inf.commute subsetCE)
 
 
 paragraph \<open>Coincidence for Games\<close>
 
 text \<open>\<open>Cignorabimus \<alpha> V\<close> is the set of all sets of variables that can be ignored for the coincidence game lemma\<close>
 definition Cignorabimus:: "game \<Rightarrow> variable set \<Rightarrow> variable set set"
   where
 "Cignorabimus \<alpha> V = {M. \<forall>I.\<forall>\<omega>.\<forall>\<omega>'.\<forall>X. (Vagree \<omega> \<omega>' (-M) \<longrightarrow> (\<omega>\<in>game_sem I \<alpha> (restrictto X V)) \<longrightarrow> (\<omega>'\<in>game_sem I \<alpha> (restrictto X V)))}"
 
 lemma Cignorabimus_finite [simp]: "finite (Cignorabimus \<alpha> V)"
   unfolding Cignorabimus_def using finite_powerset[OF allvars_finite] finite_subset using Finite_Set.finite_subset by fastforce 
 
 lemma Cignorabimus_equiv [simp]: "Cignorabimus \<alpha> V = {M. \<forall>I.\<forall>\<omega>.\<forall>\<omega>'.\<forall>X. (Vagree \<omega> \<omega>' (-M) \<longrightarrow> (\<omega>\<in>game_sem I \<alpha> (restrictto X V)) = (\<omega>'\<in>game_sem I \<alpha> (restrictto X V)))}"
   unfolding Cignorabimus_def by (metis (no_types, lifting) Vagree_sym_rel)
 
 lemma Cignorabimus_antimon [simp]: "M \<in> Cignorabimus \<alpha> V \<and> N\<subseteq>M \<Longrightarrow> N \<in> Cignorabimus \<alpha> V"
   unfolding Cignorabimus_def
   using Vagree_antimon by blast 
 
 lemma coempty: "-{}=allvars"
   by simp
 
 lemma Cignorabimus_empty [simp]: "{} \<in> Cignorabimus \<alpha> V"
   unfolding Cignorabimus_def using coempty Vagree_univ
   by simp
 
 text \<open>Cignorabimus contains nonfree variables\<close>
 lemma Cignorabimus_init: "V\<supseteq>FVG(\<alpha>) \<Longrightarrow> x\<notin>V \<Longrightarrow> {x}\<in>Cignorabimus \<alpha> V"
 proof-
   assume "V\<supseteq>FVG(\<alpha>)"
   assume a0: "x\<notin>V"
   hence a1: "x\<notin>FVG(\<alpha>)" using \<open>FVG \<alpha> \<subseteq> V\<close> by blast
   hence "\<And>I v w. Vagree v w (-{x}) \<Longrightarrow> (v \<in> game_sem I \<alpha> (restrictto X (-{x})) \<longleftrightarrow> w \<in> game_sem I \<alpha> (restrictto X (-{x})))" 
   by (metis (mono_tags, lifting) CollectI FVG_def Vagree_sym_rel)
   show "{x}\<in>Cignorabimus \<alpha> V"
   proof-
     {
       fix I \<omega> \<omega>' X
       have "Vagree \<omega> \<omega>' (-{x}) \<longrightarrow> (\<omega>\<in>game_sem I \<alpha> (restrictto X V)) \<longrightarrow> (\<omega>'\<in>game_sem I \<alpha> (restrictto X V))"
       proof
         assume a2: "Vagree \<omega> \<omega>' (-{x})"
         show "(\<omega>\<in>game_sem I \<alpha> (restrictto X V)) \<longrightarrow> (\<omega>'\<in>game_sem I \<alpha> (restrictto X V))"
         proof
           assume "\<omega>\<in>game_sem I \<alpha> (restrictto X V)"
           hence "\<omega>\<in>game_sem I \<alpha> (restrictto (restrictto X V) (-{x}))" by (simp add: Int_absorb2 \<open>x\<notin>V\<close>)
           hence "\<omega>'\<in>game_sem I \<alpha> (restrictto (restrictto X V) (-{x}))" using FVG_def a1 a2 by blast
           hence "\<omega>'\<in>game_sem I \<alpha> (restrictto X (V\<inter>-{x}))" by simp
           show "\<omega>'\<in>game_sem I \<alpha> (restrictto X V)" using a0
             by (metis Int_absorb2 \<open>\<omega>' \<in> game_sem I \<alpha> (restrictto X (V \<inter> - {x}))\<close> subset_Compl_singleton)
         qed
       qed
     }
     thus ?thesis
       unfolding Cignorabimus_def
       by auto
   qed
 qed
 
 
 text \<open>Cignorabimus is closed under union\<close>
 lemma Cignorabimus_union: "M\<in>Cignorabimus \<alpha> V \<Longrightarrow> N\<in>Cignorabimus \<alpha> V \<Longrightarrow> (M\<union>N)\<in>Cignorabimus \<alpha> V"
 proof-
   assume a1: "M\<in>Cignorabimus \<alpha> V"
   assume a2: "N\<in>Cignorabimus \<alpha> V"
   show "(M\<union>N)\<in>Cignorabimus \<alpha> V" (*using a1 a2 unfolding Cignorabimus_def *)
   proof-
     {
       fix I \<omega> \<omega>' X
     assume a3: "Vagree \<omega> \<omega>' (-(M\<union>N))"
     have h1: "\<And>I \<omega> \<omega>'.\<And>X. (Vagree \<omega> \<omega>' (-M) \<Longrightarrow>  (\<omega>\<in>game_sem I \<alpha> (restrictto X V)) \<Longrightarrow> (\<omega>'\<in>game_sem I \<alpha> (restrictto X V)))" using a1 by simp
     have h2: "\<And>I \<omega> \<omega>'.\<And>X. (Vagree \<omega> \<omega>' (-N) \<Longrightarrow>  (\<omega>\<in>game_sem I \<alpha> (restrictto X V)) \<Longrightarrow> (\<omega>'\<in>game_sem I \<alpha> (restrictto X V)))" using a2 by simp
     let ?s = "stateinterpol \<omega>' \<omega> M"
     have v1: "Vagree \<omega> ?s (-(M\<union>N))" using a3 by (simp add: Vagree_def)
     have v2: "Vagree ?s \<omega>' (-(M\<union>N))" using a3 by (simp add: Vagree_def)
     have r1: "\<omega>\<in>game_sem I \<alpha> (restrictto X V) \<Longrightarrow> ?s\<in>game_sem I \<alpha> (restrictto X V)"
       by (metis ComplD Vagree_def h1 stateinterpol_right)
     have r2: "?s\<in>game_sem I \<alpha> (restrictto X V) \<Longrightarrow> \<omega>'\<in>game_sem I \<alpha> (restrictto X V)"
       by (metis Vagree_ror compl_sup h1 h2 v2)
     have res: "\<omega>\<in>game_sem I \<alpha> (restrictto X V) \<Longrightarrow> \<omega>'\<in>game_sem I \<alpha> (restrictto X V)" using r1 r2 by blast
     }
     thus ?thesis
       unfolding Cignorabimus_def
       by auto
   qed
 qed
 
 
 lemma powersetup_induct [case_names Base Cup]:
    "\<And>C. (\<And>M. M\<in>C \<Longrightarrow> P M) \<Longrightarrow>
     (\<And>S. (\<And>M. M\<in>S \<Longrightarrow> P M) \<Longrightarrow> P (\<Union>S)) \<Longrightarrow>
      P (\<Union>C)"
   by simp
 
 lemma Union_insert: "\<Union>(insert x S) = x\<union>\<Union>S"
   by simp
 
 lemma powerset2up_induct [case_names Finite Nonempty Base Cup]:
    "(finite C) \<Longrightarrow> (C\<noteq>{}) \<Longrightarrow> (\<And>M. M\<in>C \<Longrightarrow> P M) \<Longrightarrow>
     (\<And>M N. P M \<Longrightarrow> P N \<Longrightarrow> P (M\<union>N)) \<Longrightarrow>
      P (\<Union>C)"
 proof (induction rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by force
 qed
 
 lemma Cignorabimus_step: "(\<And>M. M\<in>S \<Longrightarrow> M\<in>Cignorabimus \<alpha> V) \<Longrightarrow> (\<Union>S)\<in>Cignorabimus \<alpha> V"
 proof (cases "S={}")
   case True
   then show ?thesis using Cignorabimus_empty by simp
 next
   case nonem: False
   then show "\<Union>S\<in>Cignorabimus \<alpha> V" if "\<And>M. M\<in>S \<Longrightarrow> M\<in>Cignorabimus \<alpha> V" and nonemp:"S\<noteq>{}" for S
   proof (induction rule: powerset2up_induct)
     case Finite                                                   
     then show ?case using Cignorabimus_finite by (meson infinite_super subset_eq that(1))  
   next
     case Nonempty
     then show ?case using nonemp by simp
   next
     case (Base M)
     then show ?case using that by simp
   next
     case (Cup S)
     then show ?case using that Cignorabimus_union by blast
   qed
 qed
 
 text \<open>Lemma 12 \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close>\<close>
 
 theorem coincidence_game: "Vagree \<omega> \<omega>' V \<Longrightarrow> V\<supseteq>FVG(\<alpha>) \<Longrightarrow> (\<omega> \<in> game_sem I \<alpha> (restrictto X V)) = (\<omega>' \<in> game_sem I \<alpha> (restrictto X V))"
 proof-
   assume a1: "Vagree \<omega> \<omega>' V"
   assume a2: "V \<supseteq> FVG \<alpha>"
   have base: "{x}\<in>Cignorabimus \<alpha> V" if a3: "x\<notin>V" and a4: "V \<supseteq> FVG \<alpha>" for x V
     using a3 and a4 and Cignorabimus_init by simp
   have h: "-V = \<Union>{xx. \<exists>x. xx={x} \<and> x\<notin>V}" by auto (* finite *)
   have "(-V)\<in>Cignorabimus \<alpha> V" using a2 base h using Cignorabimus_step
-  (*by (smt Cignorabimus_step mem_Collect_eq)*)
   proof - (*sledgehammer*)
     have f1: "\<forall>v V. v \<in> V \<or> \<not> FVG \<alpha> \<subseteq> V \<or> {v} \<in> Cignorabimus \<alpha> V"
       using base by satx
     obtain VV :: "variable set \<Rightarrow> game \<Rightarrow> variable set set \<Rightarrow> variable set" where
       f2: "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x2 \<and> v3 \<notin> Cignorabimus x1 x0) = (VV x0 x1 x2 \<in> x2 \<and> VV x0 x1 x2 \<notin> Cignorabimus x1 x0)"
       by moura
     obtain vv :: "variable set \<Rightarrow> variable" where
       f3: "((\<nexists>v. VV V \<alpha> {{v} |v. v \<notin> V} = {v} \<and> v \<notin> V) \<or> VV V \<alpha> {{v} |v. v \<notin> V} = {vv (VV V \<alpha> {{v} |v. v \<notin> V})} \<and> vv (VV V \<alpha> {{v} |v. v \<notin> V}) \<notin> V) \<and> ((\<exists>v. VV V \<alpha> {{v} |v. v \<notin> V} = {v} \<and> v \<notin> V) \<or> (\<forall>v. VV V \<alpha> {{v} |v. v \<notin> V} \<noteq> {v} \<or> v \<in> V))"
-      by moura
+      by fastforce
     moreover
     { assume "{vv (VV V \<alpha> {{v} |v. v \<notin> V})} \<in> Cignorabimus \<alpha> V"
       then have "(VV V \<alpha> {{v} |v. v \<notin> V} \<noteq> {vv (VV V \<alpha> {{v} |v. v \<notin> V})} \<or> vv (VV V \<alpha> {{v} |v. v \<notin> V}) \<in> V) \<or> VV V \<alpha> {{v} |v. v \<notin> V} \<notin> {{v} |v. v \<notin> V} \<or> VV V \<alpha> {{v} |v. v \<notin> V} \<in> Cignorabimus \<alpha> V"
         by metis
       then have "(\<exists>v. VV V \<alpha> {{v} |v. v \<notin> V} = {v} \<and> v \<notin> V) \<longrightarrow> VV V \<alpha> {{v} |v. v \<notin> V} \<notin> {{v} |v. v \<notin> V} \<or> VV V \<alpha> {{v} |v. v \<notin> V} \<in> Cignorabimus \<alpha> V"
         using f3 by blast }
     ultimately have "VV V \<alpha> {{v} |v. v \<notin> V} \<notin> {{v} |v. v \<notin> V} \<or> VV V \<alpha> {{v} |v. v \<notin> V} \<in> Cignorabimus \<alpha> V"
       using f1 a2 by blast
     then have "\<Union>{{v} |v. v \<notin> V} \<in> Cignorabimus \<alpha> V"
       using f2 by (meson Cignorabimus_step)
     then show ?thesis
       using h by presburger
   qed
   from this show ?thesis by (simp add: a1)
 qed
 
 corollary coincidence_game_cor: "Uvariation \<omega> \<omega>' U \<Longrightarrow> U\<inter>FVG(\<alpha>)={} \<Longrightarrow> (\<omega> \<in> game_sem I \<alpha> (restrictto X (-U))) = (\<omega>' \<in> game_sem I \<alpha> (restrictto X (-U)))"
   using coincidence_game Uvariation_Vagree 
   by (metis Uvariation_Vagree coincidence_game compl_le_swap1 disjoint_eq_subset_Compl double_compl)
 
   
 subsection \<open>Bound Effect Lemmas\<close>
 
 text \<open>\<open>Bignorabimus \<alpha> V\<close> is the set of all sets of variables that can be ignored for boundeffect\<close>
 definition Bignorabimus:: "game \<Rightarrow> variable set set"
   where
   "Bignorabimus \<alpha> = {M. \<forall>I.\<forall>\<omega>.\<forall>X. \<omega>\<in>game_sem I \<alpha> X \<longleftrightarrow> \<omega>\<in>game_sem I \<alpha> (selectlike X \<omega> M)}"
 
 lemma Bignorabimus_finite [simp]: "finite (Bignorabimus \<alpha>)"
   unfolding Bignorabimus_def using finite_powerset[OF allvars_finite] finite_subset using Finite_Set.finite_subset by fastforce 
 
 lemma Bignorabimus_single [simp]: "game_sem I \<alpha> (selectlike X \<omega> M) \<subseteq> game_sem I \<alpha> X"
   by (meson monotone selectlike_shrinks subsetCE)
 
 lemma Bignorabimus_equiv [simp]: "Bignorabimus \<alpha> = {M. \<forall>I.\<forall>\<omega>.\<forall>X. (\<omega>\<in>game_sem I \<alpha> X \<longrightarrow> \<omega>\<in>game_sem I \<alpha> (selectlike X \<omega> M))}"
   (*by (smt Bignorabimus_def Bignorabimus_single Collect_cong subsetCE)*)
 proof - (*sledgehammer transformed*)
   obtain VV :: "(variable set \<Rightarrow> bool) \<Rightarrow> (variable set \<Rightarrow> bool) \<Rightarrow> variable set" where
     f1: "\<forall>p pa. (\<not> p (VV pa p)) = pa (VV pa p) \<or> Collect p = Collect pa"
     by (metis (no_types) Collect_cong)
   obtain rr :: "variable set \<Rightarrow> game \<Rightarrow> variable \<Rightarrow> real" and ii :: "variable set \<Rightarrow> game \<Rightarrow> interp" and FF :: "variable set \<Rightarrow> game \<Rightarrow> (variable \<Rightarrow> real) set" where
     f2: "\<forall>x0 x1. (\<exists>v2 v3 v4. (v3 \<in> game_sem v2 x1 v4) \<noteq> (v3 \<in> game_sem v2 x1 (selectlike v4 v3 x0))) = ((rr x0 x1 \<in> game_sem (ii x0 x1) x1 (FF x0 x1)) \<noteq> (rr x0 x1 \<in> game_sem (ii x0 x1) x1 (selectlike (FF x0 x1) (rr x0 x1) x0)))"
     by moura
     have fact: "{V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))} = {V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)}"
         using f1 by (metis (no_types, opaque_lifting) Bignorabimus_single subsetCE)
   have f3: "rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha> \<notin> game_sem (ii (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<alpha> (selectlike (FF (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) (rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))) \<or> rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha> \<in> game_sem (ii (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<alpha> (FF (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>)"
     using Bignorabimus_single by blast
   have f4: "(\<not> (\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))) \<or> (\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))))) \<and> ((\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))) \<or> (rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha> \<notin> game_sem (ii (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<alpha> (FF (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>)) = (rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha> \<in> game_sem (ii (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<alpha> (selectlike (FF (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) (rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))))"
     using f2 by blast
   have "rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha> \<in> game_sem (ii (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<alpha> (FF (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<longrightarrow> (\<exists>i f F. f \<in> game_sem i \<alpha> F \<and> f \<notin> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))) \<or> rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha> \<in> game_sem (ii (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) \<alpha> (selectlike (FF (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) (rr (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))) \<alpha>) (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))"
     by blast
   moreover
   { assume "\<exists>i f F. f \<in> game_sem i \<alpha> F \<and> f \<notin> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))"
     then have "\<not> (\<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))"
       by blast
     moreover
     { assume "(\<not> (\<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))) \<noteq> (\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))))"
       then have "{V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))} = {V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)}"
         using fact by simp }
     ultimately have "(\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))) \<or> {V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))} = {V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)}"
       by satx }
   moreover
   { assume "\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))"
     then have "(\<not> (\<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)))))) \<noteq> (\<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f (VV (\<lambda>V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))) (\<lambda>V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V))))))"
       by blast
     then have "{V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))} = {V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)}"
       using fact by simp}
   ultimately have "{V. \<forall>i f F. (f \<in> game_sem i \<alpha> F) = (f \<in> game_sem i \<alpha> (selectlike F f V))} = {V. \<forall>i f F. f \<in> game_sem i \<alpha> F \<longrightarrow> f \<in> game_sem i \<alpha> (selectlike F f V)}"
     using f4 f3 by satx
   then show ?thesis
     using Bignorabimus_def by presburger
 qed 
 
 lemma Bignorabimus_empty [simp]: "{} \<in> Bignorabimus \<alpha>"
   unfolding Bignorabimus_def using coempty selectlike_empty
   by simp
 
 lemma Bignorabimus_init: "x\<notin>BVG(\<alpha>) \<Longrightarrow> {x}\<in>Bignorabimus \<alpha>"
   unfolding Bignorabimus_def BVG_def
 proof-
   assume "x \<notin> {x. \<exists>I \<omega> X. \<omega> \<in> game_sem I \<alpha> X \<and> \<omega> \<notin> game_sem I \<alpha> (selectlike X \<omega> {x})}"
   hence "\<not>(\<exists>I \<omega> X. \<omega> \<in> game_sem I \<alpha> X \<and> \<omega> \<notin> game_sem I \<alpha> (selectlike X \<omega> {x}))" by simp
   hence "\<forall>I \<omega> X. (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> {x}))" using Bignorabimus_single by blast
   thus "{x} \<in> {M. \<forall>I \<omega> X. (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> M))}" by simp
 qed
 
 text \<open>Bignorabimus is closed under union\<close>
 lemma Bignorabimus_union: "M\<in>Bignorabimus \<alpha> \<Longrightarrow> N\<in>Bignorabimus \<alpha> \<Longrightarrow> (M\<union>N)\<in>Bignorabimus \<alpha>"
 proof -
   assume a1: "M\<in>Bignorabimus \<alpha>"
   assume a2: "N\<in>Bignorabimus \<alpha>"
   have h1: "\<forall>I.\<forall>\<omega>.\<forall>X. (\<omega>\<in>game_sem I \<alpha> X) \<longleftrightarrow> (\<omega>\<in>game_sem I \<alpha> (selectlike X \<omega> M))" using a1
     using Bignorabimus_equiv Bignorabimus_single by blast
   have h2: "\<forall>I.\<forall>\<omega>.\<forall>X. (\<omega>\<in>game_sem I \<alpha> X) \<longleftrightarrow> (\<omega>\<in>game_sem I \<alpha> (selectlike X \<omega> N))" using a2
     using Bignorabimus_equiv Bignorabimus_single by blast
   have c: "\<forall>I.\<forall>\<omega>.\<forall>X. (\<omega>\<in>game_sem I \<alpha> X) \<longleftrightarrow> (\<omega>\<in>game_sem I \<alpha> (selectlike X \<omega> (M\<union>N)))" by (metis h1 h2 selectlike_compose)
   then show "(M\<union>N)\<in>Bignorabimus \<alpha>" unfolding Bignorabimus_def using c by fastforce 
 qed
 
 lemma Bignorabimus_step: "(\<And>M. M\<in>S \<Longrightarrow> M\<in>Bignorabimus \<alpha>) \<Longrightarrow> (\<Union>S)\<in>Bignorabimus \<alpha>"
 proof (cases "S={}")
   case True
   then show ?thesis using Bignorabimus_empty by simp
 next
   case nonem: False
   then show "\<Union>S\<in>Bignorabimus \<alpha>" if "\<And>M. M\<in>S \<Longrightarrow> M\<in>Bignorabimus \<alpha>" and nonemp:"S\<noteq>{}" for S
   proof (induction rule: powerset2up_induct)
     case Finite
     then show ?case using Bignorabimus_finite by (meson infinite_super subset_eq that(1))  
   next
     case Nonempty
     then show ?case using nonemp by simp
   next
     case (Base M)
     then show ?case using that by simp
   next
     case (Cup S)
     then show ?case using that Bignorabimus_union by blast
   qed
 qed
 
 
 text \<open>Lemma 13 \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close>\<close>
 
 theorem boundeffect: "(\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> (-BVG(\<alpha>))))"
 proof-
   have base: "{x}\<in>Bignorabimus \<alpha>" if a3: "x\<notin>BVG \<alpha>" for x using a3 and Bignorabimus_init by simp
   have h: "-BVG \<alpha> = \<Union>{xx. \<exists>x. xx={x} \<and> x\<notin>BVG \<alpha>}" by blast (* finite *)
   have "(-BVG \<alpha>)\<in>Bignorabimus \<alpha>" using base h
   (*by (smt Bignorabimus_step mem_Collect_eq)*)
   proof - (*sledgehammer*)
     obtain VV :: "game \<Rightarrow> variable set set \<Rightarrow> variable set" where
       f1: "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> Bignorabimus x0) = (VV x0 x1 \<in> x1 \<and> VV x0 x1 \<notin> Bignorabimus x0)"
       by moura
     have "VV \<alpha> {{v} |v. v \<notin> BVG \<alpha>} \<notin> {{v} |v. v \<notin> BVG \<alpha>} \<or> VV \<alpha> {{v} |v. v \<notin> BVG \<alpha>} \<in> Bignorabimus \<alpha>"
       by fastforce
     then have "\<Union>{{v} |v. v \<notin> BVG \<alpha>} \<in> Bignorabimus \<alpha>"
       using f1 by (meson Bignorabimus_step)
     then show ?thesis
       using h by presburger
   qed
   from this show ?thesis using Bignorabimus_def by blast
 qed
 
 corollary boundeffect_cor: "V\<inter>BVG(\<alpha>)={} \<Longrightarrow> (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> V))"
   using boundeffect
   by (metis disjoint_eq_subset_Compl selectlike_compose sup.absorb_iff2)
 
 
 subsection \<open>Static Analysis Observations\<close>
 
 lemma BVG_equiv: "game_equiv \<alpha> \<beta> \<Longrightarrow> BVG(\<alpha>) = BVG(\<beta>)"
 proof-
   assume a: "game_equiv \<alpha> \<beta>" 
   show "BVG(\<alpha>) = BVG(\<beta>)" unfolding BVG_def using game_equiv_subst_eq[OF a] by metis
 qed
 
 lemmas union_or = Set.Un_iff
 
 lemma not_union_or: "(x\<notin>A\<union>B) = (x\<notin>A \<and> x\<notin>B)"
   by simp
 
 lemma repv_selectlike_self: "(repv \<omega> x d \<in> selectlike X \<omega> {x}) = (d=\<omega>(x) \<and> \<omega> \<in> X)"
   unfolding selectlike_def using Vagree_repv_self Vagree_sym
   by (metis (no_types, lifting) mem_Collect_eq repv_self)
 
 lemma repv_selectlike_other: "x\<noteq>y \<Longrightarrow> (repv \<omega> x d \<in> selectlike X \<omega> {y}) = (repv \<omega> x d \<in> X)"
 proof
   assume a: "x\<noteq>y"
   then have h: "{y}\<subseteq>-{x}" by simp
   show "(repv \<omega> x d \<in> selectlike X \<omega> {y}) \<Longrightarrow> (repv \<omega> x d \<in> X)" using a selectlike_def Vagree_repv[of \<omega> x d] 
   by auto
   show "(repv \<omega> x d \<in> X) \<Longrightarrow> (repv \<omega> x d \<in> selectlike X \<omega> {y})" 
   using selectlike_def[where X=X and \<nu>=\<omega> and V=\<open>-{x}\<close>] Vagree_repv[where \<omega>=\<omega> and x=x and d=d]
   selectlike_antimon[where X=X and \<nu>=\<omega> and V=\<open>{y}\<close> and W=\<open>-{x}\<close>, OF h] Vagree_sym[where \<nu>=\<open>repv \<omega> x d\<close> and V=\<open>-{x}\<close>]
   by auto
 qed
 
 lemma repv_selectlike_other_converse: "x\<noteq>y \<Longrightarrow> (repv \<omega> x d \<in> X) = (repv \<omega> x d \<in> selectlike X \<omega> {y})"
   using repv_selectlike_other HOL.eq_commute by blast
 
 
 lemma BVG_assign_other: "x\<noteq>y \<Longrightarrow> y\<notin>BVG(Assign x \<theta>)"
   using repv_selectlike_other_converse[where x=x and y=y] by simp
 
 lemma BVG_assign_meta: "(\<And>I \<omega>. term_sem I \<theta> \<omega> = \<omega>(x)) \<Longrightarrow> BVG(Assign x \<theta>) = {}"
   and "term_sem I \<theta> \<omega> \<noteq> \<omega>(x) \<Longrightarrow> BVG(Assign x \<theta>) = {x}"
   (*using repv_selectlike_self BVG_assign_other BVG_def BVG_elem*)
 proof-
   have fact: "BVG(Assign x \<theta>) \<subseteq> {x}" using BVG_assign_other by (metis singleton_iff subsetI)
   from fact show "(\<And>I \<omega>. term_sem I \<theta> \<omega> = \<omega>(x)) \<Longrightarrow> BVG(Assign x \<theta>) = {}" using BVG_def by simp
   have h2: "\<exists>I \<omega>. term_sem I \<theta> \<omega> \<noteq> \<omega>(x) \<Longrightarrow> x \<in> BVG(Assign x \<theta>)" using repv_selectlike_self by auto
   from fact show "term_sem I \<theta> \<omega> \<noteq> \<omega>(x) \<Longrightarrow> BVG(Assign x \<theta>) = {x}" using BVG_elem h2 by blast 
 qed
 
 lemma BVG_assign: "BVG(Assign x \<theta>) = (if (\<forall>I \<omega>. term_sem I \<theta> \<omega> = \<omega>(x)) then {} else {x})"
 using repv_selectlike_self repv_selectlike_other BVG_assign_other 
 proof-
   have c0: "BVG(Assign x \<theta>) \<subseteq> {x}" using BVG_assign_other by (metis singletonI subsetI)
   have c1: "\<forall>I \<omega>. term_sem I \<theta> \<omega> = \<omega>(x) \<Longrightarrow> BVG(Assign x \<theta>) = {}" using BVG_assign_other by auto
   have h2: "\<exists>I \<omega>. term_sem I \<theta> \<omega> \<noteq> \<omega>(x) \<Longrightarrow> x \<in> BVG(Assign x \<theta>)" using repv_selectlike_self by auto
   have c2: "\<exists>I \<omega>. term_sem I \<theta> \<omega> \<noteq> \<omega>(x) \<Longrightarrow> BVG(Assign x \<theta>) = {x}" using c0 h2 by blast 
   from c1 and c2 show ?thesis by simp
 qed
 
 lemma BVG_ODE_other: "y\<noteq>RVar x \<Longrightarrow> y\<noteq>DVar x \<Longrightarrow> y\<notin>BVG(ODE x \<theta>)"
   (*using nonBVG_rule selectlike_equal_cocond_rule solves_ODE_def*)
 proof-
   assume yx: "y\<noteq>RVar x"
   assume yxp: "y\<noteq>DVar x"
   show "y\<notin>BVG(ODE x \<theta>)"
   proof (rule nonBVG_inc_rule)
     fix I \<omega> X
     assume "\<omega> \<in> game_sem I (ODE x \<theta>) X"
     then have "\<exists>F T. Vagree \<omega> (F(0)) (-{DVar x}) \<and> F(T) \<in> X \<and> solves_ODE I F x \<theta>" by simp
     then obtain F T where "Vagree \<omega> (F(0)) (-{DVar x}) \<and> F(T) \<in> X \<and> solves_ODE I F x \<theta>" by blast
     then have "Vagree \<omega> (F(0)) (-{DVar x}) \<and> F(T) \<in> (selectlike X \<omega> {y}) \<and> solves_ODE I F x \<theta>"
     using yx yxp solves_Vagree Vagree_def similar_selectlike_mem by auto 
     then have "\<exists>F T. Vagree \<omega> (F(0)) (-{DVar x}) \<and> F(T) \<in> (selectlike X \<omega> {y}) \<and> solves_ODE I F x \<theta>" by blast 
     then show "\<omega> \<in> game_sem I (ODE x \<theta>) (selectlike X \<omega> {y})" by simp
   qed
 qed
 
 text \<open>This result could be strengthened to a conditional equality based on the RHS values\<close>
 
 lemma BVG_ODE: "BVG(ODE x \<theta>) \<subseteq> {RVar x,DVar x}"
   using BVG_ODE_other by blast
 
 
 lemma BVG_test: "BVG(Test \<phi>) = {}"
   unfolding BVG_def game_sem.simps by auto
 
 
 lemma BVG_choice: "BVG(Choice \<alpha> \<beta>) \<subseteq> BVG(\<alpha>) \<union> BVG(\<beta>)"
   unfolding BVG_def game_sem.simps using not_union_or by auto
 (*proof-
   have f1: "\<And>\<omega> I X. (\<omega> \<in> game_sem I \<alpha> X \<union> game_sem I \<beta> X) = 
   (\<omega> \<in> game_sem I \<alpha> X \<or> \<omega> \<in> game_sem I \<beta> X)" by (rule union_or)
   have f2: "\<And>\<omega> I X. (\<omega> \<notin> game_sem I \<alpha> (selectlike X \<omega> {x}) \<union> game_sem I \<beta> (selectlike X \<omega> {x})) =
   (\<omega> \<notin> game_sem I \<alpha> (selectlike X \<omega> {x}) \<and> \<omega> \<notin> game_sem I \<beta> (selectlike X \<omega> {x}))" by (rule not_union_or)
   let ?lhs = "{x. \<exists>I \<omega> X.
            \<omega> \<in> game_sem I \<alpha> X \<union> game_sem I \<beta> X \<and>
            \<omega> \<notin> game_sem I \<alpha> (selectlike X \<omega> {x}) \<union> game_sem I \<beta> (selectlike X \<omega> {x})}"
   let ?rhs = "{x. \<exists>I \<omega> X. \<omega> \<in> game_sem I \<alpha> X \<and> \<omega> \<notin> game_sem I \<alpha> (selectlike X \<omega> {x})} \<union>
        {x. \<exists>I \<omega> X. \<omega> \<in> game_sem I \<beta> X \<and> \<omega> \<notin> game_sem I \<beta> (selectlike X \<omega> {x})}"
   show "?lhs\<subseteq>?rhs" using f1 f2 by auto
 qed*)
 
 lemma select_nonBV: "x\<notin>BVG(\<alpha>) \<Longrightarrow> selectlike (game_sem I \<alpha> (selectlike X \<omega> {x})) \<omega> {x} = selectlike (game_sem I \<alpha> X) \<omega> {x}"
 proof
   show "selectlike (game_sem I \<alpha> (selectlike X \<omega> {x})) \<omega> {x} \<subseteq> selectlike (game_sem I \<alpha> X) \<omega> {x}" 
   using game_sem_mono selectlike_shrinks selectlike_antimon Bignorabimus_single
   by (metis selectlike_union sup.absorb_iff1) 
   next
   assume nonbound: "x\<notin>BVG(\<alpha>)"
   then have fact: "{x}\<inter>BVG(\<alpha>)={}" by auto
   show "selectlike (game_sem I \<alpha> X) \<omega> {x} \<subseteq> selectlike (game_sem I \<alpha> (selectlike X \<omega> {x})) \<omega> {x}"
   proof
     fix \<mu>
     assume "\<mu> \<in> selectlike (game_sem I \<alpha> X) \<omega> {x}"
     (* "V\<inter>BVG(\<alpha>)={} \<Longrightarrow> (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> V))" *)
     then have "\<mu> \<in> selectlike (game_sem I \<alpha> (selectlike X \<mu> {x})) \<omega> {x}"
     using boundeffect_cor[where \<omega>=\<mu> and V=\<open>{x}\<close> and \<alpha>=\<alpha>, OF fact] nonbound
     by (metis ComplD ComplI co_selectlike not_union_or)
     then show "\<mu> \<in> selectlike (game_sem I \<alpha> (selectlike X \<omega> {x})) \<omega> {x}" using selectlike_Vagree selectlike_def by fastforce 
   qed
 qed
 
 lemma BVG_compose: "BVG(Compose \<alpha> \<beta>) \<subseteq> BVG(\<alpha>) \<union> BVG(\<beta>)"
   (*unfolding BVG_def game_sem.simps using game_union union_or not_union_or selectlike_shrinks monotone selectlike_compose*)
 proof
   fix x
   assume a: "x\<in>BVG(Compose \<alpha> \<beta>)"
   show "x \<in> BVG \<alpha> \<union> BVG \<beta>"
   proof (rule ccontr)
     assume "x\<notin>BVG \<alpha> \<union> BVG(\<beta>)"
     then have n\<beta>: "x\<notin>BVG(\<beta>)"
     and n\<alpha>: "x\<notin>BVG(\<alpha>)" by simp_all
     from a have "\<exists>I.\<exists>\<omega>.\<exists>X. \<omega> \<in> game_sem I (Compose \<alpha> \<beta>) X \<and> \<omega> \<notin> game_sem I (Compose \<alpha> \<beta>) (selectlike X \<omega> {x})" by simp
     then obtain I \<omega> X where adef: "\<omega> \<in> game_sem I (Compose \<alpha> \<beta>) X \<and> \<omega> \<notin> game_sem I (Compose \<alpha> \<beta>) (selectlike X \<omega> {x})" by blast
     from adef have a1: "\<omega> \<in> game_sem I \<alpha> (game_sem I \<beta> X)" by simp
     from adef have a2: "\<omega> \<notin> game_sem I \<alpha> (game_sem I \<beta> (selectlike X \<omega> {x}))" by simp
     let ?Y = "selectlike X \<omega> {x}"
     from n\<alpha> have n\<alpha>c: "\<And>I \<omega> X. (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> {x}))" using BVG_nonelem by simp
     from n\<beta> have n\<beta>c: "\<And>I \<omega> X. (\<omega> \<in> game_sem I \<beta> X) = (\<omega> \<in> game_sem I \<beta> (selectlike X \<omega> {x}))" using BVG_nonelem by simp
     have c1: "\<omega> \<in> game_sem I \<alpha> (selectlike (game_sem I \<beta> X) \<omega> {x})" using a1 n\<alpha>c[where I=I and \<omega>=\<omega> and X=\<open>game_sem I \<beta> X\<close>] by blast
     have c2: "\<omega> \<notin> game_sem I \<alpha> (selectlike (game_sem I \<beta> ?Y) \<omega> {x})" using a2 n\<alpha>c[where I=I and \<omega>=\<omega> and X=\<open>game_sem I \<beta> ?Y\<close>] by blast
     from c2 have c3: "\<omega> \<notin> game_sem I \<alpha> (selectlike (game_sem I \<beta> X) \<omega> {x})" using n\<beta> selectlike_Vagree
     proof-
       have "selectlike (game_sem I \<beta> ?Y) \<omega> {x} = selectlike (game_sem I \<beta> X) \<omega> {x}" using n\<beta> by (rule select_nonBV) 
       thus ?thesis using c2 by simp
     qed
     show "False" using c1 c3 n\<beta>c[where I=I] by auto
   qed
 qed
 
 
 text \<open>The converse inclusion does not hold generally, because
    \<open>BVG(x := x+1; x:= x-1) = {} \<noteq> BVG(x := x+1) \<union> BVG(x := x-1) = {x}\<close>\<close>
 
 lemma "BVG(Compose (Assign x (Plus (Var x) (Number 1))) (Assign x (Plus (Var x) (Number (-1))))) 
     \<noteq> BVG(Assign x (Plus (Var x) (Number 1))) \<union> BVG(Assign x (Plus (Var x) (Number (-1))))"
     unfolding BVG_def selectlike_def repv_def Vagree_def by auto
 
 
 lemma BVG_loop: "BVG(Loop \<alpha>) \<subseteq> BVG(\<alpha>)"
 proof
   fix x
   assume a: "x\<in>BVG(Loop \<alpha>)"
   show "x \<in> BVG(\<alpha>)"
   proof (rule ccontr)
     assume "\<not> (x \<in> BVG(\<alpha>))"
     then have n\<alpha>: "x\<notin>BVG \<alpha>" by simp
     from n\<alpha> have n\<alpha>c: "\<And>I \<omega> X. (\<omega> \<in> game_sem I \<alpha> X) = (\<omega> \<in> game_sem I \<alpha> (selectlike X \<omega> {x}))" using BVG_nonelem by simp
     have "x\<notin>BVG(Loop \<alpha>)" (*using BVG_nonelem*)
     proof (rule nonBVG_rule)
       fix I \<omega> X
       let ?f = "\<lambda>Z. X \<union> game_sem I \<alpha> Z"
       let ?g = "\<lambda>Y. (selectlike X \<omega> {x}) \<union> game_sem I \<alpha> Y"
       let ?R = "\<lambda>Z Y. selectlike Z \<omega> {x} = selectlike Y \<omega> {x}"
       have "?R (lfp ?f) (lfp ?g)"
       proof (induction rule: lfp_lockstep_induct[where f=\<open>?f\<close> and g=\<open>?g\<close> and R=\<open>?R\<close>])
         case monof
         then show ?case using game_sem_loop_fixpoint_mono by simp
       next
         case monog
         then show ?case using game_sem_loop_fixpoint_mono by simp
       next
         case (step A B)
         then have IH: "selectlike A \<omega> {x} = selectlike B \<omega> {x}" by simp
         then show ?case
         (* using selectlike_union n\<alpha> select_nonBV IH by (smt insert_absorb2 insert_def selectlike_compose singleton_conv smt_solver=cvc4)  *)
         proof-
           have "selectlike (X \<union> game_sem I \<alpha> A) \<omega> {x} = selectlike X \<omega> {x} \<union> selectlike (game_sem I \<alpha> A) \<omega> {x}" using selectlike_union by simp
           also have "... = selectlike X \<omega> {x} \<union> selectlike (game_sem I \<alpha> (selectlike A \<omega> {x})) \<omega> {x}" using n\<alpha> select_nonBV by blast 
           also have "... = selectlike X \<omega> {x} \<union> selectlike (game_sem I \<alpha> (selectlike B \<omega> {x})) \<omega> {x}" using IH by simp
           also have "... = selectlike (selectlike X \<omega> {x} \<union> game_sem I \<alpha> B) \<omega> {x}" using selectlike_union n\<alpha> select_nonBV by auto 
           finally show "selectlike (X \<union> game_sem I \<alpha> A) \<omega> {x} = selectlike (selectlike X \<omega> {x} \<union> game_sem I \<alpha> B) \<omega> {x}" .
         qed
         next
         case (union M)
         then have IH: "\<forall>(A,B)\<in>M. selectlike A \<omega> {x} = selectlike B \<omega> {x}" .
         then show ?case
         using fst_proj_mem[where M=M] snd_proj_mem[where M=M] 
         selectlike_Sup[where \<nu>=\<omega> and V=\<open>{x}\<close>] sup_corr_eq_chain by simp
         (*proof-
           have "selectlike (\<Union>fst_proj M) \<omega> {x} = \<Union>{selectlike A \<omega> {x} | A. A\<in>fst_proj M}" using selectlike_Sup by simp
           also have "... = \<Union>{selectlike B \<omega> {x} | B. B\<in>snd_proj M}" using sup_corr_eq_chain[OF IH] by simp
           also have "... = selectlike (\<Union>snd_proj M) \<omega> {x}" using selectlike_Sup by simp
           finally show "selectlike (\<Union>fst_proj M) \<omega> {x} = selectlike (\<Union>snd_proj M) \<omega> {x}" .
         qed*)
       qed
       from this show "(\<omega> \<in> game_sem I (Loop \<alpha>) X) = (\<omega> \<in> game_sem I (Loop \<alpha>) (selectlike X \<omega> {x}))"
       by (metis (mono_tags) game_sem.simps(6) lfp_def selectlike_self) 
       (*by (simp add: selectlike_self game_sem_loop_back)*)
     qed
   then show "False" using a by blast  
   qed
 qed
 
 
 lemma BVG_dual: "BVG(Dual \<alpha>) \<subseteq> BVG(\<alpha>)"
   (*unfolding game_sem.simps using BVG_elem selectlike_co_selectlike co_selectlike selectlike_complement selectlike_antimon*)
 proof
   fix x
   assume a: "x\<in>BVG(Dual \<alpha>)"
   show "x\<in>BVG \<alpha>"
   proof-
     from a have "\<exists>I.\<exists>\<omega>.\<exists>X. \<omega> \<in> game_sem I (Dual \<alpha>) X \<and> \<omega> \<notin> game_sem I (Dual \<alpha>) (selectlike X \<omega> {x})" by simp
     then obtain I \<omega> X where adef: "\<omega> \<in> game_sem I (Dual \<alpha>) X \<and> \<omega> \<notin> game_sem I (Dual \<alpha>) (selectlike X \<omega> {x})" by blast
     from adef have a1: "\<omega> \<notin> game_sem I \<alpha> (- X)" by simp
     from adef have a2: "\<omega> \<in> game_sem I \<alpha> (- selectlike X \<omega> {x})" by simp
     let ?Y = "- selectlike X \<omega> {x}"
     have f1: "\<omega> \<in> game_sem I \<alpha> ?Y" by (rule a2)
     have f2: "\<omega> \<notin> game_sem I \<alpha> (selectlike ?Y \<omega> {x})" using a1 selectlike_co_selectlike
     by (metis (no_types, lifting) selectlike_shrinks monotone dual_order.trans subset_Compl_singleton)
     show "x\<in>BVG(\<alpha>)" using f1 f2 by auto
   qed
 qed
   
 end
diff --git a/thys/Differential_Game_Logic/USubst.thy b/thys/Differential_Game_Logic/USubst.thy
--- a/thys/Differential_Game_Logic/USubst.thy
+++ b/thys/Differential_Game_Logic/USubst.thy
@@ -1,1751 +1,1751 @@
 theory "USubst"
 imports
   Complex_Main
   "Syntax"          
   "Static_Semantics"
   "Coincidence"
   "Denotational_Semantics"
 begin 
 section \<open>Uniform Substitution\<close>
 
 text \<open>uniform substitution representation as tuple of partial maps from identifiers to type-compatible replacements.\<close>
 type_synonym usubst =
  "(ident \<rightharpoonup> trm) \<times> (ident \<rightharpoonup> trm) \<times> (ident \<rightharpoonup> fml) \<times> (ident \<rightharpoonup> game)"
 
 abbreviation SConst:: "usubst \<Rightarrow> (ident \<rightharpoonup> trm)" 
 where "SConst \<equiv> (\<lambda>(F0, _, _, _). F0)"
 abbreviation SFuncs:: "usubst \<Rightarrow> (ident \<rightharpoonup> trm)" 
 where "SFuncs \<equiv> (\<lambda>(_, F, _, _). F)"
 abbreviation SPreds:: "usubst \<Rightarrow> (ident \<rightharpoonup> fml)" 
 where "SPreds \<equiv> (\<lambda>(_, _, P, _). P)"
 abbreviation SGames:: "usubst \<Rightarrow> (ident \<rightharpoonup> game)" 
 where "SGames \<equiv> (\<lambda>(_, _, _, G). G)"
 
 text \<open>crude approximation of size which is enough for termination arguments\<close>
 definition usubstsize:: "usubst \<Rightarrow> nat"
 where "usubstsize \<sigma> = (if (dom (SFuncs \<sigma>) = {} \<and> dom (SPreds \<sigma>) = {}) then 1 else 2)"
 
 
 text \<open>dot is some fixed constant function symbol that is reserved for the purposes of the substitution\<close>
 definition dot:: "trm"
   where "dot = Const (dotid)"
 
 
 subsection \<open>Strict Mechanism for Handling Substitution Partiality in Isabelle\<close>
 
 text \<open>Optional terms that result from a substitution, either actually a term or just none to indicate that the substitution clashed\<close>
 type_synonym trmo = "trm option"
 
 abbreviation undeft:: trmo where "undeft \<equiv> None"
 abbreviation Aterm:: "trm \<Rightarrow> trmo" where "Aterm \<equiv> Some"
 
 lemma undeft_None: "undeft=None" by simp
 lemma Aterm_Some: "Aterm \<theta>=Some \<theta>" by simp
 
 lemma undeft_equiv: "(\<theta>\<noteq>undeft) = (\<exists>t. \<theta>=Aterm t)"
   by simp
 
 text \<open>Plus on defined terms, strict undeft otherwise \<close>
 fun Pluso :: "trmo \<Rightarrow> trmo \<Rightarrow> trmo"
 where
   "Pluso (Aterm \<theta>) (Aterm \<eta>) = Aterm(Plus \<theta> \<eta>)"
 | "Pluso undeft \<eta> = undeft"
 | "Pluso \<theta> undeft = undeft"
 
 text \<open>Times on defined terms, strict undeft otherwise \<close>
 fun Timeso :: "trmo \<Rightarrow> trmo \<Rightarrow> trmo"
 where
   "Timeso (Aterm \<theta>) (Aterm \<eta>) = Aterm(Times \<theta> \<eta>)"
 | "Timeso undeft \<eta> = undeft"
 | "Timeso \<theta> undeft = undeft"
 
 fun Differentialo :: "trmo \<Rightarrow> trmo"
 where
   "Differentialo (Aterm \<theta>) = Aterm(Differential \<theta>)"
 | "Differentialo undeft = undeft"
 
 lemma Pluso_undef: "(Pluso \<theta> \<eta> = undeft) = (\<theta>=undeft \<or> \<eta>=undeft)"    by (metis Pluso.elims option.distinct(1))
 lemma Timeso_undef: "(Timeso \<theta> \<eta> = undeft) = (\<theta>=undeft \<or> \<eta>=undeft)"  by (metis Timeso.elims option.distinct(1)) 
 lemma Differentialo_undef: "(Differentialo \<theta> = undeft) = (\<theta>=undeft)" by (metis Differentialo.elims option.distinct(1)) 
 
 
 type_synonym fmlo = "fml option"
 
 abbreviation undeff:: fmlo where "undeff \<equiv> None"
 abbreviation Afml:: "fml \<Rightarrow> fmlo" where "Afml \<equiv> Some"
 
 type_synonym gameo = "game option"
 
 abbreviation undefg:: gameo where "undefg \<equiv> None"
 abbreviation Agame:: "game \<Rightarrow> gameo" where "Agame \<equiv> Some"
 
 lemma undeff_equiv: "(\<phi>\<noteq>undeff) = (\<exists>f. \<phi>=Afml f)"
   by simp
 
 lemma undefg_equiv: "(\<alpha>\<noteq>undefg) = (\<exists>g. \<alpha>=Agame g)"
   by simp
 
 
 text \<open>Geq on defined terms, strict undeft otherwise \<close>
 fun Geqo :: "trmo \<Rightarrow> trmo \<Rightarrow> fmlo"
 where
   "Geqo (Aterm \<theta>) (Aterm \<eta>) = Afml(Geq \<theta> \<eta>)"
 | "Geqo undeft \<eta> = undeff"
 | "Geqo \<theta> undeft = undeff"
 
 text \<open>Not on defined formulas, strict undeft otherwise \<close>
 fun Noto :: "fmlo \<Rightarrow> fmlo"
 where
   "Noto (Afml \<phi>) = Afml(Not \<phi>)"
 | "Noto undeff = undeff"
 
 text \<open>And on defined formulas, strict undeft otherwise \<close>
 fun Ando :: "fmlo \<Rightarrow> fmlo \<Rightarrow> fmlo"
 where
   "Ando (Afml \<phi>) (Afml \<psi>) = Afml(And \<phi> \<psi>)"
 | "Ando undeff \<psi> = undeff"
 | "Ando \<phi> undeff = undeff"
 
 text \<open>Exists on defined formulas, strict undeft otherwise \<close>
 fun Existso :: "variable \<Rightarrow> fmlo \<Rightarrow> fmlo"
 where
   "Existso x (Afml \<phi>) = Afml(Exists x \<phi>)"
 | "Existso x undeff = undeff"
 
 text \<open>Diamond on defined games/formulas, strict undeft otherwise \<close>
 fun Diamondo :: "gameo \<Rightarrow> fmlo \<Rightarrow> fmlo"
 where
   "Diamondo (Agame \<alpha>) (Afml \<phi>) = Afml(Diamond \<alpha> \<phi>)"
 | "Diamondo undefg \<phi> = undeff"
 | "Diamondo \<alpha> undeff = undeff"
 
 lemma Geqo_undef: "(Geqo \<theta> \<eta> = undeff) = (\<theta>=undeft \<or> \<eta>=undeft)"
   by (metis Geqo.elims option.distinct(1)) 
 lemma Noto_undef: "(Noto \<phi> = undeff) = (\<phi>=undeff)"
   by (metis Noto.elims option.distinct(1)) 
 lemma Ando_undef: "(Ando \<phi> \<psi> = undeff) = (\<phi>=undeff \<or> \<psi>=undeff)"
   by (metis Ando.elims option.distinct(1)) 
 lemma Existso_undef: "(Existso x \<phi> = undeff) = (\<phi>=undeff)"
   by (metis Existso.elims option.distinct(1)) 
 lemma Diamondo_undef: "(Diamondo \<alpha> \<phi> = undeff) = (\<alpha>=undefg \<or> \<phi>=undeff)"
   by (metis Diamondo.elims option.distinct(1)) 
 
 
 text \<open>Assign on defined terms, strict undefg otherwise \<close>
 fun Assigno :: "variable \<Rightarrow> trmo \<Rightarrow> gameo"
 where
   "Assigno x (Aterm \<theta>) = Agame(Assign x \<theta>)"
 | "Assigno x undeft = undefg"
 
 fun ODEo :: "ident \<Rightarrow> trmo \<Rightarrow> gameo"
 where
   "ODEo x (Aterm \<theta>) = Agame(ODE x \<theta>)"
 | "ODEo x undeft = undefg"
 
 text \<open>Test on defined formulas, strict undefg otherwise \<close>
 fun Testo :: "fmlo \<Rightarrow> gameo"
 where
   "Testo (Afml \<phi>) = Agame(Test \<phi>)"
 | "Testo undeff = undefg"
 
 text \<open>Choice on defined games, strict undefg otherwise \<close>
 fun Choiceo :: "gameo \<Rightarrow> gameo \<Rightarrow> gameo"
 where
   "Choiceo (Agame \<alpha>) (Agame \<beta>) = Agame(Choice \<alpha> \<beta>)"
 | "Choiceo \<alpha> undefg = undefg"
 | "Choiceo undefg \<beta> = undefg"
 
 text \<open>Compose on defined games, strict undefg otherwise \<close>
 fun Composeo :: "gameo \<Rightarrow> gameo \<Rightarrow> gameo"
 where
   "Composeo (Agame \<alpha>) (Agame \<beta>) = Agame(Compose \<alpha> \<beta>)"
 | "Composeo \<alpha> undefg = undefg"
 | "Composeo undefg \<beta> = undefg"
 
 text \<open>Loop on defined games, strict undefg otherwise \<close>
 fun Loopo :: "gameo \<Rightarrow> gameo"
 where
   "Loopo (Agame \<alpha>) = Agame(Loop \<alpha>)"
 | "Loopo undefg = undefg"
 
 text \<open>Dual on defined games, strict undefg otherwise \<close>
 fun Dualo :: "gameo \<Rightarrow> gameo"
 where
   "Dualo (Agame \<alpha>) = Agame(Dual \<alpha>)"
 | "Dualo undefg = undefg"
 
 
 lemma Assigno_undef: "(Assigno x \<theta> = undefg) = (\<theta>=undeft)"  by (metis Assigno.elims option.distinct(1)) 
 lemma ODEo_undef: "(ODEo x \<theta> = undefg) = (\<theta>=undeft)"        by (metis ODEo.elims option.distinct(1)) 
 lemma Testo_undef: "(Testo \<phi> = undefg) = (\<phi>=undeff)"        by (metis Testo.elims option.distinct(1)) 
 lemma Choiceo_undef: "(Choiceo \<alpha> \<beta> = undefg) = (\<alpha>=undefg \<or> \<beta>=undefg)"   by (metis Choiceo.elims option.distinct(1))
 lemma Composeo_undef: "(Composeo \<alpha> \<beta> = undefg) = (\<alpha>=undefg \<or> \<beta>=undefg)" by (metis Composeo.elims option.distinct(1))
 lemma Loopo_undef: "(Loopo \<alpha> = undefg) = (\<alpha>=undefg)"        by (metis Loopo.elims option.distinct(1))
 lemma Dualo_undef: "(Dualo \<alpha> = undefg) = (\<alpha>=undefg)"        by (metis Dualo.elims option.distinct(1))
   
 
 
 subsection \<open>Recursive Application of One-Pass Uniform Substitution\<close>
 
 text \<open>\<open>dotsubstt \<theta>\<close> is the dot substitution \<open>{. ~> \<theta>}\<close> substituting a term for the . function symbol\<close>
 definition dotsubstt:: "trm \<Rightarrow> usubst"
   where "dotsubstt \<theta> = (
          (\<lambda>f. (if f=dotid then (Some(\<theta>)) else None)),
          (\<lambda>_. None),
          (\<lambda>_. None),
          (\<lambda>_. None)
   )"
 
 definition usappconst:: "usubst \<Rightarrow> variable set \<Rightarrow> ident \<Rightarrow> (trmo)"
 where "usappconst \<sigma> U f \<equiv> (case SConst \<sigma> f of Some r \<Rightarrow> if FVT(r)\<inter>U={} then Aterm(r) else undeft | None \<Rightarrow> Aterm(Const f))"
 
 function usubstappt:: "usubst \<Rightarrow> variable set \<Rightarrow> (trm \<Rightarrow> trmo)"
 where
   "usubstappt \<sigma> U (Var x)     = Aterm (Var x)"
 | "usubstappt \<sigma> U (Number r)  = Aterm (Number r)"
 | "usubstappt \<sigma> U (Const f)   = usappconst \<sigma> U f"
 | "usubstappt \<sigma> U (Func f \<theta>)  =
   (case usubstappt \<sigma> U \<theta> of undeft   \<Rightarrow> undeft
                           | Aterm \<sigma>\<theta> \<Rightarrow> (case SFuncs \<sigma> f of Some r \<Rightarrow> if FVT(r)\<inter>U={} then usubstappt(dotsubstt \<sigma>\<theta>) {} r else undeft | None \<Rightarrow> Aterm(Func f \<sigma>\<theta>)))"
 | "usubstappt \<sigma> U (Plus \<theta> \<eta>)  = Pluso (usubstappt \<sigma> U \<theta>) (usubstappt \<sigma> U \<eta>)"
 | "usubstappt \<sigma> U (Times \<theta> \<eta>) = Timeso (usubstappt \<sigma> U \<theta>) (usubstappt \<sigma> U \<eta>)"
 | "usubstappt \<sigma> U (Differential \<theta>) = Differentialo (usubstappt \<sigma> allvars \<theta>)"
   by pat_completeness auto
 termination
   by (relation "measures [\<lambda>(\<sigma>,U,\<theta>). usubstsize \<sigma> , \<lambda>(\<sigma>,U,\<theta>). size \<theta>]")
   (auto simp add: usubstsize_def dotsubstt_def)
   
 (* Expand let constructs automatically *)
 declare Let_def [simp]
   
 function usubstappf:: "usubst \<Rightarrow> variable set \<Rightarrow> (fml \<Rightarrow> fmlo)"
      and usubstappp:: "usubst \<Rightarrow> variable set \<Rightarrow> (game \<Rightarrow> variable set \<times> gameo)"
 where
   "usubstappf \<sigma> U (Pred p \<theta>)   = 
   (case usubstappt \<sigma> U \<theta> of undeft   \<Rightarrow> undeff
                           | Aterm \<sigma>\<theta> \<Rightarrow> (case SPreds \<sigma> p of Some r \<Rightarrow> if FVF(r)\<inter>U={} then usubstappf(dotsubstt \<sigma>\<theta>) {} r else undeff | None \<Rightarrow> Afml(Pred p \<sigma>\<theta>)))"
 | "usubstappf \<sigma> U (Geq \<theta> \<eta>)    = Geqo (usubstappt \<sigma> U \<theta>) (usubstappt \<sigma> U \<eta>)"
 | "usubstappf \<sigma> U (Not \<phi>)      = Noto (usubstappf \<sigma> U \<phi>)"
 | "usubstappf \<sigma> U (And \<phi> \<psi>)    = Ando (usubstappf \<sigma> U \<phi>) (usubstappf \<sigma> U \<psi>)"
 | "usubstappf \<sigma> U (Exists x \<phi>) = Existso x (usubstappf \<sigma> (U\<union>{x}) \<phi>)"
 | "usubstappf \<sigma> U (Diamond \<alpha> \<phi>) = (let V\<alpha> = usubstappp \<sigma> U \<alpha> in Diamondo (snd V\<alpha>) (usubstappf \<sigma> (fst V\<alpha>) \<phi>))"
 
 | "usubstappp \<sigma> U (Game a)   =
   (case SGames \<sigma> a of Some r \<Rightarrow> (U\<union>BVG(r),Agame r)
                     | None   \<Rightarrow> (allvars,Agame(Game a)))"
 | "usubstappp \<sigma> U (Assign x \<theta>) = (U\<union>{x}, Assigno x (usubstappt \<sigma> U \<theta>))"
 | "usubstappp \<sigma> U (Test \<phi>) = (U, Testo (usubstappf \<sigma> U \<phi>))"
 | "usubstappp \<sigma> U (Choice \<alpha> \<beta>) =
     (let V\<alpha> = usubstappp \<sigma> U \<alpha> in
      let W\<beta> = usubstappp \<sigma> U \<beta> in
      (fst V\<alpha>\<union>fst W\<beta>, Choiceo (snd V\<alpha>) (snd W\<beta>)))"
 | "usubstappp \<sigma> U (Compose \<alpha> \<beta>) =
     (let V\<alpha> = usubstappp \<sigma> U \<alpha> in
      let W\<beta> = usubstappp \<sigma> (fst V\<alpha>) \<beta> in
      (fst W\<beta>, Composeo (snd V\<alpha>) (snd W\<beta>)))"
 | "usubstappp \<sigma> U (Loop \<alpha>) =
     (let V = fst(usubstappp \<sigma> U \<alpha>) in
      (V, Loopo (snd(usubstappp \<sigma> V \<alpha>))))"
 | "usubstappp \<sigma> U (Dual \<alpha>) =
     (let V\<alpha> = usubstappp \<sigma> U \<alpha> in (fst V\<alpha>, Dualo (snd V\<alpha>)))"
 | "usubstappp \<sigma> U (ODE x \<theta>) = (U\<union>{RVar x,DVar x}, ODEo x (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>))"
 by pat_completeness auto
 termination 
   by (relation "measures [(\<lambda>k. usubstsize (case k of Inl(\<sigma>,U,\<phi>) \<Rightarrow> \<sigma> | Inr(\<sigma>,U,\<alpha>) \<Rightarrow> \<sigma>)) , (\<lambda>k. case k of Inl (\<sigma>,U,\<phi>) \<Rightarrow> size \<phi> | Inr (\<sigma>,U,\<alpha>) \<Rightarrow> size \<alpha>)]") 
   (auto simp add: usubstsize_def dotsubstt_def)
 
 text \<open>Induction Principles for Uniform Substitutions\<close>
 lemmas usubstappt_induct = usubstappt.induct [case_names Var Number Const FuncMatch Plus Times Differential]
 lemmas usubstappfp_induct = usubstappf_usubstappp.induct [case_names Pred Geq Not And Exists Diamond  Game Assign Test Choice Compose Loop Dual ODE]
 
 
 paragraph \<open>Simple Observations for Automation\<close>
 
 text \<open>More automation for Case\<close>
 
 lemma usappconst_simp [simp]: "SConst \<sigma> f = Some r \<Longrightarrow> FVT(r)\<inter>U={} \<Longrightarrow> usappconst \<sigma> U f = Aterm(r)"
   and "SConst \<sigma> f = None \<Longrightarrow> usappconst \<sigma> U f = Aterm(Const f)"
   and "SConst \<sigma> f = Some r \<Longrightarrow> FVT(r)\<inter>U\<noteq>{} \<Longrightarrow> usappconst \<sigma> U f = undeft"
   unfolding usappconst_def by auto
 
 lemma usappconst_conv: "usappconst \<sigma> U f\<noteq>undeft \<Longrightarrow>
   SConst \<sigma> f = None \<or> (\<exists>r. SConst \<sigma> f = Some r \<and> FVT(r)\<inter>U={})"
   (*by (smt option.case_eq_if option.collapse usappconst_def)*)
 proof-
   assume as: "usappconst \<sigma> U f\<noteq>undeft"
   show "SConst \<sigma> f = None \<or> (\<exists>r. SConst \<sigma> f = Some r \<and> FVT(r)\<inter>U={})"
   proof (cases "SConst \<sigma> f")
     case None
     then show ?thesis
     by auto 
   next
     case (Some a)
     then show ?thesis using as usappconst_def[where \<sigma>=\<sigma> and U=U and f=f] option.distinct(1) by fastforce
   qed
 qed
 
 lemma usubstappt_const [simp]: "SConst \<sigma> f = Some r \<Longrightarrow> FVT(r)\<inter>U={} \<Longrightarrow> usubstappt \<sigma> U (Const f) = Aterm(r)"
   and "SConst \<sigma> f = None \<Longrightarrow> usubstappt \<sigma> U (Const f) = Aterm(Const f)"
   and "SConst \<sigma> f = Some r \<Longrightarrow> FVT(r)\<inter>U\<noteq>{} \<Longrightarrow> usubstappt \<sigma> U (Const f) = undeft"
   by (auto simp add: usappconst_def)
 
 lemma usubstappt_const_conv: "usubstappt \<sigma> U (Const f)\<noteq>undeft \<Longrightarrow>
   SConst \<sigma> f = None \<or> (\<exists>r. SConst \<sigma> f = Some r \<and> FVT(r)\<inter>U={})"
   using usappconst_conv by auto
 
 lemma usubstappt_func [simp]: "SFuncs \<sigma> f = Some r \<Longrightarrow> FVT(r)\<inter>U={} \<Longrightarrow> usubstappt \<sigma> U \<theta> = Aterm \<sigma>\<theta> \<Longrightarrow>
   usubstappt \<sigma> U (Func f \<theta>) = usubstappt (dotsubstt \<sigma>\<theta>) {} r"
   and "SFuncs \<sigma> f=None \<Longrightarrow>  usubstappt \<sigma> U \<theta> = Aterm \<sigma>\<theta> \<Longrightarrow> usubstappt \<sigma> U (Func f \<theta>) = Aterm(Func f \<sigma>\<theta>)"
   and "usubstappt \<sigma> U \<theta> = undeft \<Longrightarrow> usubstappt \<sigma> U (Func f \<theta>) = undeft"
   by auto
 
 lemma usubstappt_func2 [simp]: "SFuncs \<sigma> f = Some r \<Longrightarrow> FVT(r)\<inter>U\<noteq>{} \<Longrightarrow> usubstappt \<sigma> U (Func f \<theta>) = undeft"
   by (cases "usubstappt \<sigma> U \<theta>") (auto)
 
 lemma usubstappt_func_conv: "usubstappt \<sigma> U (Func f \<theta>) \<noteq> undeft \<Longrightarrow>
   usubstappt \<sigma> U \<theta> \<noteq> undeft \<and>
     (SFuncs \<sigma> f = None \<or> (\<exists>r. SFuncs \<sigma> f = Some r \<and> FVT(r)\<inter>U={}))"
   by (metis (lifting) option.simps(4) undeft_equiv usubstappt.simps(4) usubstappt_func2)
   (*by (cases "usubstappt \<sigma> U \<theta>") (auto) *)
 
 lemma usubstappt_plus_conv: "usubstappt \<sigma> U (Plus \<theta> \<eta>) \<noteq> undeft \<Longrightarrow>
   usubstappt \<sigma> U \<theta> \<noteq> undeft \<and> usubstappt \<sigma> U \<eta> \<noteq> undeft"
   by (simp add: Pluso_undef)
   
 lemma usubstappt_times_conv: "usubstappt \<sigma> U (Times \<theta> \<eta>) \<noteq> undeft \<Longrightarrow>
   usubstappt \<sigma> U \<theta> \<noteq> undeft \<and> usubstappt \<sigma> U \<eta> \<noteq> undeft"
   by (simp add: Timeso_undef)
 
 lemma usubstappt_differential_conv: "usubstappt \<sigma> U (Differential \<theta>) \<noteq> undeft \<Longrightarrow>
   usubstappt \<sigma> allvars \<theta> \<noteq> undeft"
   by (simp add: Differentialo_undef)
   
 
 lemma usubstappf_pred [simp]: "SPreds \<sigma> p = Some r \<Longrightarrow> FVF(r)\<inter>U={} \<Longrightarrow> usubstappt \<sigma> U \<theta> = Aterm \<sigma>\<theta> \<Longrightarrow>
   usubstappf \<sigma> U (Pred p \<theta>) = usubstappf (dotsubstt \<sigma>\<theta>) {} r"
   and "SPreds \<sigma> p = None \<Longrightarrow> usubstappt \<sigma> U \<theta> = Aterm \<sigma>\<theta> \<Longrightarrow> usubstappf \<sigma> U (Pred p \<theta>) = Afml(Pred p \<sigma>\<theta>)"
   and "usubstappt \<sigma> U \<theta> = undeft \<Longrightarrow> usubstappf \<sigma> U (Pred p \<theta>) = undeff"
   by auto
   
 lemma usubstappf_pred2 [simp]: "SPreds \<sigma> p = Some r \<Longrightarrow> FVF(r)\<inter>U\<noteq>{} \<Longrightarrow> usubstappf \<sigma> U (Pred p \<theta>) = undeff"
   by (cases "usubstappt \<sigma> U \<theta>") (auto)
 
 lemma usubstappf_pred_conv: "usubstappf \<sigma> U (Pred p \<theta>) \<noteq> undeff \<Longrightarrow>
   usubstappt \<sigma> U \<theta> \<noteq> undeft \<and>
     (SPreds \<sigma> p = None \<or> (\<exists>r. SPreds \<sigma> p = Some r \<and> FVF(r)\<inter>U={}))"
   by (metis (lifting) option.simps(4) undeff_equiv usubstappf.simps(1) usubstappf_pred2)
 
 lemma usubstappf_geq: "usubstappt \<sigma> U \<theta> \<noteq> undeft \<Longrightarrow> usubstappt \<sigma> U \<eta> \<noteq> undeft \<Longrightarrow>
   usubstappf \<sigma> U (Geq \<theta> \<eta>) = Afml(Geq (the (usubstappt \<sigma> U \<theta>)) (the (usubstappt \<sigma> U \<eta>)))"
   by fastforce
 
 lemma usubstappf_geq_conv: "usubstappf \<sigma> U (Geq \<theta> \<eta>) \<noteq> undeff \<Longrightarrow>
   usubstappt \<sigma> U \<theta> \<noteq> undeft \<and> usubstappt \<sigma> U \<eta> \<noteq> undeft"
   by (simp add: Geqo_undef) 
 
 lemma usubstappf_geqr: "usubstappf \<sigma> U (Geq \<theta> \<eta>) \<noteq> undeff \<Longrightarrow>
   usubstappf \<sigma> U (Geq \<theta> \<eta>) = Afml(Geq (the (usubstappt \<sigma> U \<theta>)) (the (usubstappt \<sigma> U \<eta>)))"
   using usubstappf_geq usubstappf_geq_conv by blast
 
 lemma usubstappf_exists: "usubstappf \<sigma> U (Exists x \<phi>) \<noteq> undeff \<Longrightarrow>
   usubstappf \<sigma> U (Exists x \<phi>) = Afml(Exists x (the (usubstappf \<sigma> (U\<union>{x}) \<phi>)))"
   using Existso_undef by auto
 
 lemma usubstappp_game [simp]: "SGames \<sigma> a = Some r \<Longrightarrow> usubstappp \<sigma> U (Game a) = (U\<union>BVG(r),Agame(r))"
   and "SGames \<sigma> a = None \<Longrightarrow> usubstappp \<sigma> U (Game a) = (allvars,Agame(Game a))"
    by auto  
 
 lemma usubstappp_choice [simp]: "usubstappp \<sigma> U (Choice \<alpha> \<beta>) =
   (fst(usubstappp \<sigma> U \<alpha>)\<union>fst(usubstappp \<sigma> U \<beta>), Choiceo (snd(usubstappp \<sigma> U \<alpha>)) (snd(usubstappp \<sigma> U \<beta>)))"
    by auto
 
 lemma usubstappp_choice_conv : "snd(usubstappp \<sigma> U (Choice \<alpha> \<beta>)) \<noteq> undefg \<Longrightarrow>
   snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<and> snd(usubstappp \<sigma> U \<beta>) \<noteq> undefg"
   by (simp add: Choiceo_undef)
 
 lemma usubstappp_compose [simp]: "usubstappp \<sigma> U (Compose \<alpha> \<beta>) =
   (fst(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<beta>), Composeo (snd(usubstappp \<sigma> U \<alpha>)) (snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<beta>)))"
   by simp
 
 lemma usubstappp_loop: "usubstappp \<sigma> U (Loop \<alpha>) =
   (fst(usubstappp \<sigma> U \<alpha>), Loopo (snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<alpha>)))"
   by auto
 
 lemma usubstappp_dual [simp]: "usubstappp \<sigma> U (Dual \<alpha>) =
   (fst(usubstappp \<sigma> U \<alpha>), Dualo (snd (usubstappp \<sigma> U \<alpha>)))"
   by simp
 
 
   
 section \<open>Soundness of Uniform Substitution\<close>
 
 
 subsection \<open>USubst Application is a Function of Deterministic Result\<close>
 
 lemma usubstappt_det: "usubstappt \<sigma> U \<theta> \<noteq> undeft \<Longrightarrow> usubstappt \<sigma> V \<theta> \<noteq> undeft \<Longrightarrow>
   usubstappt \<sigma> U \<theta> = usubstappt \<sigma> V \<theta>"
 proof (induction \<theta>)
   case (Var x)
   then show ?case by simp
 next
   case (Number x)
   then show ?case by simp
 next
   case (Const f)
   then show ?case
     (*by (smt option.case_eq_if usappconst_def usubstappt.simps(3))*)
   proof - (*sledgehammer*)
     have f1: "usubstappt \<sigma> U (Const f) = (case SConst \<sigma> f of None \<Rightarrow> Aterm (Const f) | Some t \<Rightarrow> if FVT t \<inter> U = {} then Aterm t else undeft)"
       by (simp add: usappconst_def)
     have f2: "\<forall>z f za. if za = undeft then (case za of None \<Rightarrow> z::trm option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
       by force
     then have "SConst \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SConst \<sigma> f)) \<inter> U = {} then Aterm (the (SConst \<sigma> f)) else undeft) = usappconst \<sigma> U f"
       by (simp add: usappconst_def)
     then have f3: "SConst \<sigma> f \<noteq> undeft \<longrightarrow> FVT (the (SConst \<sigma> f)) \<inter> U = {}"
       by (metis Const.prems(1) usubstappt.simps(3))
     have "SConst \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SConst \<sigma> f)) \<inter> V = {} then Aterm (the (SConst \<sigma> f)) else undeft) = usappconst \<sigma> V f"
       using f2 usappconst_def by presburger
     then have "SConst \<sigma> f \<noteq> undeft \<longrightarrow> FVT (the (SConst \<sigma> f)) \<inter> V = {}"
       by (metis (no_types) Const.prems(2) usubstappt.simps(3))
     then have f4: "SConst \<sigma> f \<noteq> undeft \<longrightarrow> usubstappt \<sigma> U (Const f) = usappconst \<sigma> V f"
       using f3 f2 f1 usappconst_def by presburger
     { assume "usubstappt \<sigma> U (Const f) \<noteq> usubstappt \<sigma> V (Const f)"
       then have "usubstappt \<sigma> U (Const f) \<noteq> (case SConst \<sigma> f of None \<Rightarrow> Aterm (Const f) | Some t \<Rightarrow> if FVT t \<inter> V = {} then Aterm t else undeft)"
         by (simp add: usappconst_def)
       then have "SConst \<sigma> f \<noteq> undeft"
         using f2 f1 by (metis (no_types))
       then have ?thesis
         using f4 by simp }
     then show ?thesis
       by blast
   qed
 next
   case (Func f \<theta>)
   then show ?case using usubstappt_func
       (*by (cases "SFuncs \<sigma> f") (auto simp add: usubstappt_func)*)
       (*by (smt option.case_eq_if usubstappt.simps(4))*)
   proof - (*sledgehammer*)
     have f1: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeft | Some t \<Rightarrow> (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f t) | Some ta \<Rightarrow> if FVT ta \<inter> U = {} then usubstappt (dotsubstt t) {} ta else undeft)) \<noteq> undeft"
       using Func(2) by auto
     have f2: "\<forall>z f za. if za = undeft then (case za of None \<Rightarrow> z::trm option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
       by force
     then have f3: "usubstappt \<sigma> U \<theta> \<noteq> undeft"
       using f1 by meson
     have "(case usubstappt \<sigma> V \<theta> of None \<Rightarrow> undeft | Some t \<Rightarrow> (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f t) | Some ta \<Rightarrow> if FVT ta \<inter> V = {} then usubstappt (dotsubstt t) {} ta else undeft)) \<noteq> undeft"
       using Func(3) by auto
     then have f4: "usubstappt \<sigma> V \<theta> \<noteq> undeft"
       using f2 by meson
     then have f5: "usubstappt \<sigma> U (trm.Func f \<theta>) = (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft)"
       using f3 f2 Func(1) usubstappt.simps(4) by presburger
     have "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SFuncs \<sigma> f)) \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SFuncs \<sigma> f)) else undeft) = usubstappt \<sigma> U (trm.Func f \<theta>)"
       using f4 f3 f2 Func(1) usubstappt.simps(4) by presburger
     then have f6: "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> FVT (the (SFuncs \<sigma> f)) \<inter> U = {}"
       by (metis Func(2))
     have f7: "(case usubstappt \<sigma> V \<theta> of None \<Rightarrow> undeft | Some t \<Rightarrow> (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f t) | Some ta \<Rightarrow> if FVT ta \<inter> V = {} then usubstappt (dotsubstt t) {} ta else undeft)) = (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> V = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft)"
       using f4 f2 by presburger
     then have "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SFuncs \<sigma> f)) \<inter> V = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SFuncs \<sigma> f)) else undeft) = usubstappt \<sigma> V (trm.Func f \<theta>)"
       using f2 by simp
     then have f8: "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> FVT (the (SFuncs \<sigma> f)) \<inter> V = {}"
       by (metis (full_types) Func(3))
     { assume "usubstappt \<sigma> U (trm.Func f \<theta>) \<noteq> usubstappt \<sigma> V (trm.Func f \<theta>)"
       moreover
       { assume "(case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> V = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft) \<noteq> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>)))"
         then have "SFuncs \<sigma> f \<noteq> undeft"
           using f2 by meson }
       ultimately have "SFuncs \<sigma> f \<noteq> undeft"
         using f7 f5 by fastforce
       then have ?thesis
         using f8 f7 f6 f5 f2 by simp }
     then show ?thesis
       by blast
   qed 
 next
   case (Plus \<theta>1 \<theta>2)
   then show ?case using Pluso_undef by auto 
 next
   case (Times \<theta>1 \<theta>2)
   then show ?case using Timeso_undef by auto
 next
   case (Differential \<theta>)
   then show ?case using Differentialo_undef by auto
 qed
 
 
 lemma usubstappf_and_usubstappp_det: 
 shows "usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> V \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> U \<phi> = usubstappf \<sigma> V \<phi>"
 and "snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> V \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) = snd(usubstappp \<sigma> V \<alpha>)"
 proof (induction \<phi> and \<alpha> arbitrary: U V and U V)
   case (Pred p \<theta>)
   then show ?case using usubstappt_det usubstappf_pred
   (*by (metis usubstappf.simps(1)) *)
   (*by (smt option.case_eq_if usubstappf.simps(1)) *)
     proof - (*sledgehammer*)
     have f1: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeff | Some t \<Rightarrow> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p t) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt t) {} f else undeff)) \<noteq> undeff"
     using Pred.prems(1) by auto
     have f2: "\<forall>z f za. if za = undeft then (case za of None \<Rightarrow> z::fml option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
     by (simp add: option.case_eq_if)
     then have f3: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeff | Some t \<Rightarrow> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p t) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt t) {} f else undeff)) = (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> U \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} f else undeff)"
     using f1 by meson
     have f4: "(case usubstappt \<sigma> V \<theta> of None \<Rightarrow> undeff | Some t \<Rightarrow> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p t) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt t) {} f else undeff)) \<noteq> undeff"
     using Pred.prems(2) by auto
     then have f5: "usubstappt \<sigma> U \<theta> = usubstappt \<sigma> V \<theta>"
     using f2 f1 by (meson usubstappt_det)
     then have f6: "usubstappf \<sigma> U (Pred p \<theta>) = (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff)"
     using f3 usubstappf.simps(1) by presburger
     have f7: "\<forall>z f za. if za = undeff then (case za of None \<Rightarrow> z::fml option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
     by (simp add: option.case_eq_if)
     have f8: "(case usubstappt \<sigma> V \<theta> of None \<Rightarrow> undeff | Some t \<Rightarrow> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p t) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt t) {} f else undeff)) = (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff)"
     using f4 f2 by meson
     then have f9: "SPreds \<sigma> p = undeff \<longrightarrow> usubstappf \<sigma> U (Pred p \<theta>) = usubstappf \<sigma> V (Pred p \<theta>)"
     using f6 by fastforce
     { assume "usubstappf \<sigma> U (Pred p \<theta>) \<noteq> usubstappf \<sigma> V (Pred p \<theta>)"
       then have "usubstappf \<sigma> U (Pred p \<theta>) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff)"
       using f8 by simp
       moreover
       { assume "usubstappf \<sigma> U (Pred p \<theta>) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
         moreover
         { assume "usubstappf \<sigma> U (Pred p \<theta>) \<noteq> usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p))"
           moreover
           { assume "usubstappf \<sigma> U (Pred p \<theta>) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
             then have "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
             using f6 by force
             then have "SPreds \<sigma> p = undeff"
             using f7 by (metis (no_types, lifting) Pred.prems(1) calculation f5 option.collapse usubstappf_pred usubstappf_pred2 usubstappf_pred_conv) }
           moreover
           { assume "(if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p))"
             then have "(if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> U \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} f else undeff)"
             using f3 Pred.prems(1) by auto
             then have "(if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff)"
             using f5 using Pred.prems(1) \<open>(if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p))\<close> f6 by auto
             then have "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
             by simp
             then have "SPreds \<sigma> p = undeff"
             using f7 proof -
               show ?thesis
                 using \<open>(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)\<close> calculation(2) f6 by presburger
             qed}
           ultimately have "SPreds \<sigma> p = undeff"
           by fastforce }
         moreover
         { assume "(if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p))"
           then have "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
           using f8 Pred.prems(2) by auto
           then have "SPreds \<sigma> p = undeff"
           using f7 by (metis (no_types, lifting) Pred.prems(2) \<open>(if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p))\<close> option.collapse usubstappf_pred2)}
         ultimately have "SPreds \<sigma> p = undeff"
         by fastforce }
       moreover
       { assume "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
         then have "SPreds \<sigma> p = undeff"
         using f7 by (metis (no_types, lifting) Pred.prems(1) Pred.prems(2) \<open>usubstappf \<sigma> U (Pred p \<theta>) \<noteq> usubstappf \<sigma> V (Pred p \<theta>)\<close> calculation(2) option.collapse usubstappf_pred usubstappf_pred_conv)}
       ultimately have ?thesis
       using f9 by fastforce }
     then show ?thesis
     by blast
     qed
   next
   case (Geq \<theta> \<eta>)
   then show ?case using usubstappt_det by (metis Geqo_undef usubstappf.simps(2))
   next
   case (Not x)
   then show ?case by (metis Noto.simps(2) usubstappf.simps(3))
   next
   case (And x1 x2)
   then show ?case by (metis Ando_undef usubstappf.simps(4))
   next
   case (Exists x1 x2)
   then show ?case by (metis Existso_undef usubstappf.simps(5))
   next
   case (Diamond x1 x2)
   then show ?case by (metis Diamondo_undef usubstappf.simps(6))
   next
   case (Game a)
   then show ?case by (cases "SGames \<sigma> a") (auto)
   next
   case (Assign x \<theta>)
   then show ?case using usubstappt_det by (metis Assigno_undef snd_conv usubstappp.simps(2))
   next
   case (ODE x \<theta>)
   then show ?case using usubstappt_det by (metis ODEo_undef snd_conv usubstappp.simps(8))
   next
   case (Test \<phi>)
   then show ?case by (metis Testo_undef snd_conv usubstappp.simps(3))
   next
   case (Choice \<alpha> \<beta>)
   then show ?case by (metis Choiceo_undef snd_conv usubstappp.simps(4))
   next
   case (Compose \<alpha> \<beta>)
   then show ?case by (metis Composeo_undef snd_conv usubstappp.simps(5))
   next
   case (Loop \<alpha>)
   then show ?case by (metis Loopo_undef snd_conv usubstappp.simps(6))
   next
   case (Dual \<alpha>)
   then show ?case by (metis Dualo_undef snd_conv usubstappp.simps(7))
 qed
 
 lemma usubstappf_det: "usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> V \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> U \<phi> = usubstappf \<sigma> V \<phi>"
   using usubstappf_and_usubstappp_det by simp
 
 lemma usubstappp_det: "snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> V \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) = snd(usubstappp \<sigma> V \<alpha>)"
   using usubstappf_and_usubstappp_det by simp
 
 
 subsection \<open>Uniform Substitutions are Antimonotone in Taboos\<close>
 
 
 lemma usubst_taboos_mon: "fst(usubstappp \<sigma> U \<alpha>) \<supseteq> U"
 proof (induction \<alpha> arbitrary: U rule: game_induct)
   case (Game a)
   then show ?case by (cases "SGames \<sigma> a") (auto)
 next
   case (Assign x \<theta>)
   then show ?case by fastforce
 next
   case (ODE x \<theta>)
   then show ?case by fastforce
 next
   case (Test \<phi>)
   then show ?case by fastforce
 next
   case (Choice \<alpha> \<beta>)
   then show ?case by fastforce
 next
   case (Compose \<alpha> \<beta>)
   then show ?case by fastforce
 next
   case (Loop \<alpha>)
   then show ?case by fastforce
 next
   case (Dual \<alpha>)
   then show ?case by fastforce
 qed
 
 lemma fst_pair [simp]: "fst (a,b) = a" 
   by simp
 
 lemma snd_pair [simp]: "snd (a,b) = b" 
   by simp
 
   
 lemma usubstappt_antimon: "V\<subseteq>U \<Longrightarrow> usubstappt \<sigma> U \<theta> \<noteq> undeft \<Longrightarrow>
   usubstappt \<sigma> U \<theta> = usubstappt \<sigma> V \<theta>"
 proof (induction \<theta>)
   case (Var x)
   then show ?case by simp
 next
   case (Number x)
   then show ?case by simp
 next
   case (Const f)
   then show ?case
     (*by (smt disjoint_iff_not_equal option.case_eq_if set_rev_mp usappconst_def usubstappt.simps(3))*)
   proof - (*sledgehammer*)
     have f1: "usubstappt \<sigma> U (Const f) = (case SConst \<sigma> f of None \<Rightarrow> Aterm (Const f) | Some t \<Rightarrow> if FVT t \<inter> U = {} then Aterm t else undeft)"
       by (simp add: usappconst_def)
     have f2: "\<forall>z f za. if za = undeft then (case za of None \<Rightarrow> z::trm option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
       by force
     then have "SConst \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SConst \<sigma> f)) \<inter> U = {} then Aterm (the (SConst \<sigma> f)) else undeft) = usappconst \<sigma> U f"
       using usappconst_def by presburger
     then have f3: "SConst \<sigma> f \<noteq> undeft \<longrightarrow> FVT (the (SConst \<sigma> f)) \<inter> U = {}"
       by (metis (no_types) Const.prems(2) usubstappt.simps(3))
     have f4: "\<forall>V Va. (V \<inter> Va = {}) = (\<forall>v. (v::variable) \<in> V \<longrightarrow> (\<forall>va. va \<in> Va \<longrightarrow> v \<noteq> va))"
       by blast
     { assume "usubstappt \<sigma> U (Const f) \<noteq> usubstappt \<sigma> V (Const f)"
       then have "usubstappt \<sigma> U (Const f) \<noteq> (case SConst \<sigma> f of None \<Rightarrow> Aterm (Const f) | Some t \<Rightarrow> if FVT t \<inter> V = {} then Aterm t else undeft)"
         by (simp add: usappconst_def)
       then have "SConst \<sigma> f \<noteq> undeft"
         using f2 f1 by metis
       then have "SConst \<sigma> f \<noteq> undeft \<and> FVT (the (SConst \<sigma> f)) \<inter> V = {}"
         using f4 f3 by (meson Const.prems(1) subsetD)
       then have ?thesis
         using f3 f2 usappconst_def usubstappt.simps(3) by presburger }
     then show ?thesis
       by blast
   qed 
 next
   case (Func f \<theta>)
   then show ?case using usubstappt_func
       (*by (smt disjoint_iff_not_equal option.case_eq_if subset_iff usubstappt.simps(4))*)
   proof - (*sledgehammer*)
     have f1: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeft | Some t \<Rightarrow> (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f t) | Some ta \<Rightarrow> if FVT ta \<inter> U = {} then usubstappt (dotsubstt t) {} ta else undeft)) \<noteq> undeft"
       using Func.prems(2) by fastforce
     have f2: "\<forall>z f za. if za = undeft then (case za of None \<Rightarrow> z::trm option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
       by fastforce
     then have f3: "usubstappt \<sigma> U \<theta> \<noteq> undeft"
       using f1 by meson
     then have f4: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeft | Some t \<Rightarrow> (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f t) | Some ta \<Rightarrow> if FVT ta \<inter> U = {} then usubstappt (dotsubstt t) {} ta else undeft)) = (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> U \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} t else undeft)"
       using f2 by presburger
     have f5: "usubstappt \<sigma> U \<theta> = undeft \<or> usubstappt \<sigma> U \<theta> = usubstappt \<sigma> V \<theta>"
       using Func.IH Func.prems(1) by fastforce
     have "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SFuncs \<sigma> f)) \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SFuncs \<sigma> f)) else undeft) = (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft)"
       using f2 by presburger
     then have "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> (if FVT (the (SFuncs \<sigma> f)) \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SFuncs \<sigma> f)) else undeft) = usubstappt \<sigma> U (trm.Func f \<theta>)"
       using f5 f4 f3 usubstappt.simps(4) by presburger
     then have f6: "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> FVT (the (SFuncs \<sigma> f)) \<inter> U = {}"
       by (metis (no_types) Func.prems(2))
     then have f7: "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> V \<subseteq> - FVT (the (SFuncs \<sigma> f))"
       using Func.prems(1) by blast
     have f8: "(case usubstappt \<sigma> V \<theta> of None \<Rightarrow> undeft | Some t \<Rightarrow> (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f t) | Some ta \<Rightarrow> if FVT ta \<inter> V = {} then usubstappt (dotsubstt t) {} ta else undeft)) = (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> V = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft)"
       using f5 f3 f2 by presburger
     have "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SFuncs \<sigma> f)) = (case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> U = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft)"
       using f6 f2 by presburger
     then have f9: "SFuncs \<sigma> f \<noteq> undeft \<longrightarrow> usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SFuncs \<sigma> f)) = usubstappt \<sigma> U (trm.Func f \<theta>)"
       using f5 f4 f3 usubstappt.simps(4) by presburger
     { assume "usubstappt \<sigma> U (trm.Func f \<theta>) \<noteq> usubstappt \<sigma> V (trm.Func f \<theta>)"
       moreover
       { assume "(case SFuncs \<sigma> f of None \<Rightarrow> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>))) | Some t \<Rightarrow> if FVT t \<inter> V = {} then usubstappt (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} t else undeft) \<noteq> Aterm (trm.Func f (the (usubstappt \<sigma> V \<theta>)))"
         then have "SFuncs \<sigma> f \<noteq> undeft"
           using f2 by meson }
       ultimately have "SFuncs \<sigma> f \<noteq> undeft"
         using f5 f3 by fastforce
       then have ?thesis
         using f9 f8 f7 f2 by (simp add: disjoint_eq_subset_Compl inf.commute) }
     then show ?thesis
       by blast
   qed
 next
   case (Plus \<theta>1 \<theta>2)
   then show ?case using Pluso_undef by auto 
 next
   case (Times \<theta>1 \<theta>2)
   then show ?case using Timeso_undef by auto
 next
   case (Differential \<theta>)
   then show ?case using Differentialo_undef by auto
 qed
 
 text \<open>Uniform Substitutions of Games have monotone taboo output\<close>
 
 lemma usubstappp_fst_mon: "U\<subseteq>V \<Longrightarrow> fst(usubstappp \<sigma> U \<alpha>) \<subseteq> fst(usubstappp \<sigma> V \<alpha>)"
 proof (induction \<alpha> arbitrary: U V rule: game_induct)
   case (Game a)
   then show ?case by (cases "SGames \<sigma> a") (auto)
 next
   case (Assign x \<theta>)
   then show ?case by auto
 next
   case (ODE x \<theta>)
   then show ?case by auto
 next
   case (Test \<phi>)
   then show ?case by auto
 next
   case (Choice \<alpha> \<beta>)
   then show ?case by (metis Un_mono fst_pair usubstappp_choice) 
 next
   case (Compose \<alpha> \<beta>)
   then show ?case by (metis fst_pair usubstappp_compose) 
 next
   case (Loop \<alpha>)
   then show ?case by (metis fst_pair usubstappp_loop) 
 next
   case (Dual \<alpha>)
   then show ?case by (metis fst_pair usubstappp_dual) 
 qed
 
 
 lemma usubstappf_and_usubstappp_antimon: 
 shows "V\<subseteq>U \<Longrightarrow> usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> U \<phi> = usubstappf \<sigma> V \<phi>"
 and "V\<subseteq>U \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) = snd(usubstappp \<sigma> V \<alpha>)"
 proof-
   have "V\<subseteq>U \<Longrightarrow> usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> V \<phi> \<noteq> undeff"
   and "V\<subseteq>U \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> V \<alpha>) \<noteq> undefg"
   proof (induction \<phi> and \<alpha> arbitrary: U V and U V)
     case (Pred p \<theta>)
     then show ?case using usubstappt_antimon usubstappf_pred
     (*by (smt Un_mono disjoint_eq_subset_Compl empty_subsetI inf.commute option.case_eq_if sup.absorb_iff1 sup.absorb_iff2 usubstappf.simps(1)) *)
       proof - (*sledgehammer*)
       have f1: "\<forall>v. v \<notin> V \<or> v \<in> U"
       using Pred.prems(1) by auto
       have f2: "\<forall>z f za. if za = undeff then (case za of None \<Rightarrow> z::fml option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
       by (simp add: option.case_eq_if)
       have f3: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeff | Some t \<Rightarrow> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p t) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt t) {} f else undeff)) \<noteq> undeff"
       using Pred.prems(2) by auto
       have f4: "\<forall>z f za. if za = undeft then (case za of None \<Rightarrow> z::fml option | Some x \<Rightarrow> f x) = z else (case za of None \<Rightarrow> z | Some x \<Rightarrow> f x) = f (the za)"
       by (simp add: option.case_eq_if)
       then have f5: "usubstappt \<sigma> U \<theta> \<noteq> undeft"
       using f3 by meson
       then have f6: "(case usubstappt \<sigma> U \<theta> of None \<Rightarrow> undeff | Some t \<Rightarrow> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p t) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt t) {} f else undeff)) = (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> U \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} f else undeff)"
       using f4 by presburger
       have f7: "usubstappt \<sigma> U \<theta> = usubstappt \<sigma> V \<theta>"
       using f5 by (meson Pred.prems(1) usubstappt_antimon)
       then have f8: "SPreds \<sigma> p = undeff \<longrightarrow> usubstappf \<sigma> U (Pred p \<theta>) = usubstappf \<sigma> V (Pred p \<theta>)"
       using f2 usubstappf.simps(1) by presburger
       obtain vv :: "variable set \<Rightarrow> variable set \<Rightarrow> variable" where
       "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> (\<exists>v3. v3 \<in> x0 \<and> v2 = v3)) = (vv x0 x1 \<in> x1 \<and> (\<exists>v3. v3 \<in> x0 \<and> vv x0 x1 = v3))"
       by moura
       then obtain vva :: "variable set \<Rightarrow> variable set \<Rightarrow> variable" where
       f9: "\<forall>V Va. (V \<inter> Va \<noteq> {} \<or> (\<forall>v. v \<notin> V \<or> (\<forall>va. va \<notin> Va \<or> v \<noteq> va))) \<and> (V \<inter> Va = {} \<or> vv Va V \<in> V \<and> vva Va V \<in> Va \<and> vv Va V = vva Va V)"
-      by moura
+      by auto
       then have f10: "(FVF (the (SPreds \<sigma> p)) \<inter> V \<noteq> {} \<or> (\<forall>v. v \<notin> FVF (the (SPreds \<sigma> p)) \<or> (\<forall>va. va \<notin> V \<or> v \<noteq> va))) \<and> (FVF (the (SPreds \<sigma> p)) \<inter> V = {} \<or> vv V (FVF (the (SPreds \<sigma> p))) \<in> FVF (the (SPreds \<sigma> p)) \<and> vva V (FVF (the (SPreds \<sigma> p))) \<in> V \<and> vv V (FVF (the (SPreds \<sigma> p))) = vva V (FVF (the (SPreds \<sigma> p))))"
       by presburger
       { assume "vv V (FVF (the (SPreds \<sigma> p))) \<notin> FVF (the (SPreds \<sigma> p)) \<or> vva V (FVF (the (SPreds \<sigma> p))) \<notin> V \<or> vv V (FVF (the (SPreds \<sigma> p))) \<noteq> vva V (FVF (the (SPreds \<sigma> p)))"
         moreover
         { assume "(if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> undeff"
           moreover
           { assume "(if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> usubstappf \<sigma> V (Pred p \<theta>)"
             then have "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
             using f7 f5 f4 by simp
             then have "SPreds \<sigma> p = undeff"
             using f2 by (metis (no_types, lifting) \<open>(if FVF (the (SPreds \<sigma> p)) \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> usubstappf \<sigma> V (Pred p \<theta>)\<close> calculation f5 f7 option.collapse usubstappf_pred)}
           ultimately have "usubstappf \<sigma> V (Pred p \<theta>) = undeff \<longrightarrow> SPreds \<sigma> p = undeff"
           by fastforce }
         moreover
         { assume "usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) \<noteq> usubstappf \<sigma> U (Pred p \<theta>)"
           then have "usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> U \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} f else undeff)"
           using f6 by simp
           then have "usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff)"
           using f7 by (metis f7)
           moreover
           { assume "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
             then have "SPreds \<sigma> p = undeff"
             using f2  by (metis (no_types, lifting) Pred.prems(2) \<open>usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) \<noteq> usubstappf \<sigma> U (Pred p \<theta>)\<close> f5 f7 option.collapse usubstappf_pred usubstappf_pred2)}
           ultimately have "FVF (the (SPreds \<sigma> p)) \<inter> U = {} \<longrightarrow> SPreds \<sigma> p = undeff"
           by force }
         ultimately have "FVF (the (SPreds \<sigma> p)) \<inter> U = {} \<and> usubstappf \<sigma> V (Pred p \<theta>) = undeff \<longrightarrow> SPreds \<sigma> p = undeff"
         using f10 by (metis Pred.prems(2)) }
       moreover
       { assume "FVF (the (SPreds \<sigma> p)) \<inter> U \<noteq> {}"
         then have "(if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> U \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} f else undeff)"
         using f6 Pred.prems(2) by auto
         then have "(if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff) \<noteq> (case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff)"
         using f7 by (metis  \<open>FVF (the (SPreds \<sigma> p)) \<inter> U \<noteq> {}\<close>)
         then have "(case SPreds \<sigma> p of None \<Rightarrow> Afml (Pred p (the (usubstappt \<sigma> V \<theta>))) | Some f \<Rightarrow> if FVF f \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} f else undeff) \<noteq> (if FVF (the (SPreds \<sigma> p)) \<inter> U = {} then usubstappf (dotsubstt (the (usubstappt \<sigma> V \<theta>))) {} (the (SPreds \<sigma> p)) else undeff)"
         by simp
         then have "SPreds \<sigma> p = undeff"
         using f2
           proof -
           show ?thesis
           by (metis (no_types) Pred.prems(2) \<open>FVF (the (SPreds \<sigma> p)) \<inter> U \<noteq> {}\<close> option.discI option.expand option.sel usubstappf_pred2)
           qed }
       ultimately have "usubstappf \<sigma> V (Pred p \<theta>) = undeff \<longrightarrow> SPreds \<sigma> p = undeff"
       using f9 f1 by meson
       then show ?thesis
       using f8 by (metis (full_types) Pred.prems(2))
       qed
 
     next
       case (Geq \<theta> \<eta>)
       then show ?case using usubstappt_antimon using Geqo_undef by auto
     next
       case (Not x)
       then show ?case using Noto_undef by auto
     next
       case (And x1 x2)
       then show ?case using Ando_undef by auto
     next
       case (Exists x1 x2)
       then show ?case using Existso_undef
         by (metis (no_types, lifting) Un_mono subsetI usubstappf.simps(5))
     next
       case (Diamond x1 x2)
       then show ?case using Diamondo_undef usubstappf.simps(6) usubstappp_fst_mon by metis
     next
       case (Game a)
       then show ?case by (cases "SGames \<sigma> a") (auto)
     next
       case (Assign x \<theta>)
       then show ?case using usubstappt_antimon by (metis Assigno_undef snd_conv usubstappp.simps(2))
     next
       case (ODE x \<theta>)
       then show ?case using usubstappt_antimon ODEo_undef
         by (metis (no_types, opaque_lifting) Un_mono order_refl snd_conv usubstappp.simps(8))
     next
       case (Test \<phi>)
       then show ?case by (metis Testo_undef snd_conv usubstappp.simps(3))
     next
       case (Choice \<alpha> \<beta>)
       then show ?case using Choiceo_undef by auto 
     next
       case (Compose \<alpha> \<beta>)
       then show ?case 
         using usubstappp_compose[where \<sigma>=\<sigma> and U=U and \<alpha>=\<alpha> and \<beta>=\<beta>] usubstappp_compose[where \<sigma>=\<sigma> and U=V and \<alpha>=\<alpha> and \<beta>=\<beta>]
           Composeo_undef[where \<alpha>=\<open>snd (usubstappp \<sigma> U \<alpha>)\<close> and \<beta>=\<open>snd (usubstappp \<sigma> (fst (usubstappp \<sigma> U \<alpha>)) \<beta>)\<close>]
           Composeo_undef[where \<alpha>=\<open>snd (usubstappp \<sigma> V \<alpha>)\<close> and \<beta>=\<open>snd (usubstappp \<sigma> (fst (usubstappp \<sigma> V \<alpha>)) \<beta>)\<close>]
           snd_conv usubstappp_fst_mon by metis
           (*proof-
             from Compose have ca: "snd (usubstappp \<sigma> U (\<alpha> ;; \<beta>)) \<noteq> undefg" by simp
             have decU: "snd (usubstappp \<sigma> U (\<alpha> ;; \<beta>)) = Composeo (snd(usubstappp \<sigma> U \<alpha>)) (snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<beta>))" using usubstappp_compose by simp
             have decV: "snd (usubstappp \<sigma> V (\<alpha> ;; \<beta>)) = Composeo (snd(usubstappp \<sigma> V \<alpha>)) (snd(usubstappp \<sigma> (fst(usubstappp \<sigma> V \<alpha>)) \<beta>))" using usubstappp_compose by simp
             from Compose have fact1: "snd(usubstappp \<sigma> V \<alpha>) \<noteq> undefg" using Composeo_undef by auto 
             from Compose have fact2: "snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<beta>) \<noteq> undefg" using Composeo_undef by auto 
             have rel: "fst(usubstappp \<sigma> V \<alpha>) \<subseteq> fst(usubstappp \<sigma> U \<alpha>)" using \<open>V\<subseteq>U\<close> usubstappp_fst_mon by auto
             from Compose have fact3: "snd(usubstappp \<sigma> (fst(usubstappp \<sigma> V \<alpha>)) \<beta>) \<noteq> undefg" using fact2 rel by auto 
             then show ?thesis by (simp add: Composeo_undef fact1)
           qed*)
     next
       case (Loop \<alpha>)
       then show ?case using Loopo_undef snd_conv usubstappp.simps(6) usubstappp_fst_mon by metis
     next
       case (Dual \<alpha>)
       then show ?case by (metis Dualo_undef snd_conv usubstappp.simps(7))
     qed
     from this show "V\<subseteq>U \<Longrightarrow> usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> U \<phi> = usubstappf \<sigma> V \<phi>"
       and "V\<subseteq>U \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) = snd(usubstappp \<sigma> V \<alpha>)" using usubstappf_and_usubstappp_det by auto
   qed
 
 lemma usubstappf_antimon: "V\<subseteq>U \<Longrightarrow> usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow> usubstappf \<sigma> U \<phi> = usubstappf \<sigma> V \<phi>"
   using usubstappf_and_usubstappp_antimon by simp
 
 lemma usubstappp_antimon: "V\<subseteq>U \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow> snd(usubstappp \<sigma> U \<alpha>) = snd(usubstappp \<sigma> V \<alpha>)"
   using usubstappf_and_usubstappp_antimon by simp
 
   
 subsection \<open>Taboo Lemmas\<close>
 
 lemma usubstappp_loop_conv: "snd (usubstappp \<sigma> U (Loop \<alpha>)) \<noteq> undefg \<Longrightarrow>
   snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<and>
   snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<alpha>) \<noteq> undefg"
   (*using usubstappp_loop Loopo_undef*)
 proof
   assume a: "snd (usubstappp \<sigma> U (Loop \<alpha>)) \<noteq> undefg"
   have fact: "fst(usubstappp \<sigma> U \<alpha>) \<supseteq> U" using usubst_taboos_mon by simp
   show "snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<alpha>) \<noteq> undefg" using a usubstappp_loop Loopo_undef by simp
   then show "snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg" using a usubstappp_loop Loopo_undef fact usubstappp_antimon by auto
 qed
 
 
 text \<open>Lemma 13 of \<^url>\<open>http://arxiv.org/abs/1902.07230\<close>\<close>
 
 lemma usubst_taboos: "snd(usubstappp \<sigma> U \<alpha>)\<noteq>undefg \<Longrightarrow> fst(usubstappp \<sigma> U \<alpha>) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>)))"
 proof (induction \<alpha> arbitrary: U rule: game_induct)
   case (Game a)
   then show ?case by (cases "SGames \<sigma> a") (auto)
 next
   case (Assign x \<theta>)
   then show ?case 
     using BVG_assign Assigno_undef
     by (metis (no_types, lifting) Assigno.elims BVG_assign_other fst_pair option.sel singletonI snd_pair subsetI union_or usubstappp.simps(2))
 next
   case (ODE x \<theta>)
   then show ?case
     using BVG_ODE ODEo_undef
     by (metis (no_types, lifting) ODEo.elims Un_least fst_pair option.sel snd_conv sup.coboundedI2 usubst_taboos_mon usubstappp.simps(8))
 next
   case (Test p)
   then show ?case
     using BVG_test Testo_undef usubst_taboos_mon by auto 
 next
   case (Choice \<alpha> \<beta>)
   then show ?case (*using usubstappp.simps Product_Type.fst_conv Product_Type.snd_conv BVG_choice*)
   proof-
     from Choice have IHa: "fst(usubstappp \<sigma> U \<alpha>) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>)))" by (simp add: Choiceo_undef)
     from Choice have IHb: "fst(usubstappp \<sigma> U \<beta>) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<beta>)))" by (simp add: Choiceo_undef)
     have fact: "BVG(the (snd(usubstappp \<sigma> U \<alpha>))) \<union> BVG(the (snd(usubstappp \<sigma> U \<beta>))) \<supseteq> BVG(the (snd(usubstappp \<sigma> U (Choice \<alpha> \<beta>))))" using BVG_choice
         (*by (smt Choice.prems Choiceo.simps(1) Choiceo_undef option.collapse option.sel snd_pair usubstappp_choice)*)
     proof -
       have "Agame (the (snd (usubstappp \<sigma> U \<alpha>)) \<union>\<union> the (snd (usubstappp \<sigma> U \<beta>))) = Choiceo (snd (usubstappp \<sigma> U \<alpha>)) (snd (usubstappp \<sigma> U \<beta>))"
         by (metis (no_types) Choice.prems Choiceo.simps(1) option.collapse usubstappp_choice_conv)
       then show ?thesis
         by (metis (no_types) BVG_choice Choice.prems Pair_inject option.collapse option.inject surjective_pairing usubstappp.simps(4))
     qed
     from IHa and IHb have "fst(usubstappp \<sigma> U \<alpha>) \<union> fst(usubstappp \<sigma> U \<beta>) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>))) \<union> BVG(the (snd(usubstappp \<sigma> U \<beta>)))" by auto
     then have "fst(usubstappp \<sigma> U (Choice \<alpha> \<beta>)) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>))) \<union> BVG(the (snd(usubstappp \<sigma> U \<beta>)))" using usubstappp.simps Let_def by auto
     then show "fst(usubstappp \<sigma> U (Choice \<alpha> \<beta>)) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Choice \<alpha> \<beta>))))" using usubstappp.simps fact by auto
   qed
 next
   case (Compose \<alpha> \<beta>)
   then show ?case
   proof-
     let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
     let ?W = "fst(usubstappp \<sigma> ?V \<beta>)"
     from Compose have IHa: "?V \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>)))" by (simp add: Composeo_undef)
     from Compose have IHb: "?W \<supseteq> ?V \<union> BVG(the (snd(usubstappp \<sigma> ?V \<beta>)))" by (simp add: Composeo_undef)
     have fact: "BVG(the (snd(usubstappp \<sigma> U \<alpha>))) \<union> BVG(the (snd(usubstappp \<sigma> ?V \<beta>))) \<supseteq> BVG(the (snd(usubstappp \<sigma> U (Compose \<alpha> \<beta>))))" using usubstappp.simps BVG_compose
         (*by (smt Compose.prems Composeo.simps(1) Composeo_undef option.collapse option.sel snd_pair)*)
     proof -
       have f1: "\<forall>z. z = undefg \<or> Agame (the z) = z"
         using option.collapse by blast
       then have "Agame (the (snd (usubstappp \<sigma> U \<alpha>)) ;; the (snd (usubstappp \<sigma> (fst (usubstappp \<sigma> U \<alpha>)) \<beta>))) = snd (usubstappp \<sigma> U (\<alpha> ;; \<beta>))"
         using Compose.prems Composeo_undef by auto
       then show ?thesis
         using f1 by (metis (no_types) BVG_compose Compose.prems option.inject)
     qed
     have "?W \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>))) \<union> BVG(the (snd(usubstappp \<sigma> ?V \<beta>)))" using usubstappp.simps Let_def IHa IHb by auto
     then have "?W \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Compose \<alpha> \<beta>))))" using fact by auto
     then show "fst(usubstappp \<sigma> U (Compose \<alpha> \<beta>)) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Compose \<alpha> \<beta>))))" using usubstappp.simps Let_def by simp
   qed
 next
   case (Loop \<alpha>)
   then show ?case
   proof-
     let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
     let ?W = "fst(usubstappp \<sigma> ?V \<alpha>)"
     from Loop have def\<alpha>: "snd(usubstappp \<sigma> U \<alpha>) \<noteq> undefg" using usubstappp_loop_conv by simp
     from Loop have IHdef: "?V \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>)))" 
       using def\<alpha> usubstappp_loop[where \<sigma>=\<sigma> and U=U and \<alpha>=\<alpha>] Loopo_undef[where \<alpha>=\<open>snd (usubstappp \<sigma> (fst (usubstappp \<sigma> U \<alpha>)) \<alpha>)\<close>]   by auto
     from Loop have IH: "?W \<supseteq> ?V \<union> BVG(the (snd(usubstappp \<sigma> ?V \<alpha>)))" by (simp add: Loopo_undef)
     then have Vfix: "?V \<supseteq> BVG(the (snd(usubstappp \<sigma> ?V \<alpha>)))"
       using usubstappp_det by (metis IHdef Loop.prems le_sup_iff usubstappp_loop_conv)
     then have "?V \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Loop \<alpha>))))"
       using usubstappp.simps Vfix IHdef BVG_loop usubst_taboos_mon usubstappp_loop_conv
         (*by (smt Loop.prems Loopo.simps(1) Un_mono option.collapse option.sel snd_pair sup.absorb_iff1)*)
     proof - (*sledgehammer*)
       have f1: "\<forall>z. z = undefg \<or> Agame (the z) = z"
         using option.collapse by blast
       have "snd (usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<and> snd (usubstappp \<sigma> (fst (usubstappp \<sigma> U \<alpha>)) \<alpha>) \<noteq> undefg"
         using Loop.prems usubstappp_loop_conv by blast
       then have "Agame (Loop (the (snd (usubstappp \<sigma> (fst (usubstappp \<sigma> U \<alpha>)) \<alpha>)))) = snd (usubstappp \<sigma> U (Loop \<alpha>))"
         by force
       then show ?thesis
         using f1 by (metis (no_types) BVG_loop Loop.prems Vfix option.inject sup.absorb_iff1 sup.mono usubst_taboos_mon)
     qed
     then show "fst(usubstappp \<sigma> U (Loop \<alpha>)) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Loop \<alpha>))))" using usubstappp.simps Let_def by simp
   qed
 next
   case (Dual \<alpha>)
   then show ?case
     (*using BVG_dual usubstappp.simps Let_def by auto*)
   proof-
     let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
     from Dual have IH: "?V \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>)))" by (simp add: Dualo_undef)
     have fact: "BVG(the (snd(usubstappp \<sigma> U \<alpha>))) \<supseteq> BVG(the (snd(usubstappp \<sigma> U (Dual \<alpha>))))" using usubstappp.simps BVG_dual
       by (metis (no_types, lifting) Dual.prems Dualo.simps(1) Dualo.simps(2) option.collapse option.sel snd_pair)
     then have "?V \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Dual \<alpha>))))" using IH fact by auto
     then show "fst(usubstappp \<sigma> U (Dual \<alpha>)) \<supseteq> U \<union> BVG(the (snd(usubstappp \<sigma> U (Dual \<alpha>))))" using usubstappp.simps Let_def by simp
   qed
 qed
 
 
 
 subsection \<open>Substitution Adjoints\<close>
 
 text \<open>Modified interpretation \<open>repI I f d\<close> replaces the interpretation of constant function \<open>f\<close> in the interpretation \<open>I\<close> with \<open>d\<close>\<close>
 definition repc :: " interp \<Rightarrow> ident \<Rightarrow> real \<Rightarrow> interp"
   where "repc I f d \<equiv>  mkinterp((\<lambda>c. if c = f then d else Consts I c), Funcs I, Preds I, Games I)"
 
 lemma repc_consts [simp]: "Consts (repc I f d) c = (if (c=f) then d else Consts I c)"
   unfolding repc_def by auto
 lemma repc_funcs [simp]: "Funcs (repc I f d) = Funcs I"
   unfolding repc_def by simp
 lemma repc_preds [simp]: "Preds (repc I f d) = Preds I"
   unfolding repc_def by simp
 lemma repc_games [simp]: "Games (repc I f d) = Games I"
   unfolding repc_def by (simp add: mon_mono)
   
 lemma adjoint_stays_mon: "mono (case SGames \<sigma> a of None \<Rightarrow> Games I a | Some r \<Rightarrow> \<lambda>X. game_sem I r X)"
   using game_sem_mono game_sem.simps(1)
   by (metis disjE_realizer2 option.case_distrib) 
   (*proof -
   have "\<forall>z p b i f. (mono (case z of None \<Rightarrow> f | Some x \<Rightarrow> game_sem i x) \<or> \<not> (case z of None \<Rightarrow> b | Some x \<Rightarrow> p x)) \<or> \<not> mono f"
   by (metis (no_types) disjE_realizer2 game_sem_mono)
   then show ?thesis
   by (metis (no_types) game_sem.simps(1) game_sem_mono option.case_distrib)
   qed*)
 
 text \<open>adjoint interpretation \<open>adjoint \<sigma> I \<omega>\<close> to \<open>\<sigma>\<close> of interpretation \<open>I\<close> in state \<open>\<omega>\<close>\<close> 
 
 definition adjoint:: "usubst \<Rightarrow> (interp \<Rightarrow> state \<Rightarrow> interp)"
 where "adjoint \<sigma> I \<omega> = mkinterp(
          (\<lambda>f. (case SConst \<sigma> f of None \<Rightarrow> Consts I f| Some r \<Rightarrow> term_sem I r \<omega>)),
          (\<lambda>f. (case SFuncs \<sigma> f of None \<Rightarrow> Funcs I f | Some r \<Rightarrow> \<lambda>d. term_sem (repc I dotid d) r \<omega>)),
          (\<lambda>p. (case SPreds \<sigma> p of None \<Rightarrow> Preds I p | Some r \<Rightarrow> \<lambda>d. \<omega>\<in>fml_sem (repc I dotid d) r)),
          (\<lambda>a. (case SGames \<sigma> a of None \<Rightarrow> Games I a | Some r \<Rightarrow> \<lambda>X. game_sem I r X))
   )"
 
 
 paragraph \<open>Simple Observations about Adjoints\<close>
   
 lemma adjoint_consts: "Consts (adjoint \<sigma> I \<omega>) f = term_sem I (case SConst \<sigma> f of Some r \<Rightarrow> r | None \<Rightarrow> Const f) \<omega>"
   unfolding adjoint_def by (cases "SConst \<sigma> f=None") (auto)
 
 lemma adjoint_funcs: "Funcs (adjoint \<sigma> I \<omega>) f = (case SFuncs \<sigma> f of None \<Rightarrow> Funcs I f | Some r \<Rightarrow> \<lambda>d. term_sem (repc I dotid d) r \<omega>)"
   unfolding adjoint_def by auto
 
 lemma adjoint_funcs_match: "SFuncs \<sigma> f=Some r \<Longrightarrow> Funcs (adjoint \<sigma> I \<omega>) f = (\<lambda>d. term_sem (repc I dotid d) r \<omega>)"
   using adjoint_funcs by auto
 
 lemma adjoint_funcs_skip: "SFuncs \<sigma> f=None \<Longrightarrow> Funcs (adjoint \<sigma> I \<omega>) f = Funcs I f"
   using adjoint_funcs by auto
 
 lemma adjoint_preds: "Preds (adjoint \<sigma> I \<omega>) p = (case SPreds \<sigma> p of None \<Rightarrow> Preds I p | Some r \<Rightarrow> \<lambda>d. \<omega>\<in>fml_sem (repc I dotid d) r)"
   unfolding adjoint_def by auto
 
 lemma adjoint_preds_skip: "SPreds \<sigma> p=None \<Longrightarrow> Preds (adjoint \<sigma> I \<omega>) p = Preds I p"
   using adjoint_preds by simp
 
 lemma adjoint_preds_match: "SPreds \<sigma> p=Some r \<Longrightarrow> Preds (adjoint \<sigma> I \<omega>) p = (\<lambda>d. \<omega>\<in>fml_sem (repc I dotid d) r)"
   using adjoint_preds by simp
 
 lemma adjoint_games [simp]: "Games (adjoint \<sigma> I \<omega>) a = (case SGames \<sigma> a of None \<Rightarrow> Games I a | Some r \<Rightarrow> \<lambda>X. game_sem I r X)"
   unfolding adjoint_def using adjoint_stays_mon Games_mkinterp by simp 
 
 lemma adjoint_dotsubstt: "adjoint (dotsubstt \<theta>) I \<omega> = repc I dotid (term_sem I \<theta> \<omega>)"
   (*unfolding adjoint_def dotsubstt_def adjoint_consts adjoint_funcs_skip adjoint_preds adjoint_games*)
 proof-
   let ?lhs = "adjoint (dotsubstt \<theta>) I \<omega>"
   let ?rhs = "repc I dotid (term_sem I \<theta> \<omega>)"
   have feq: "Funcs ?lhs = Funcs ?rhs" using repc_funcs adjoint_funcs dotsubstt_def by auto
   moreover have peq: "Preds ?lhs = Preds ?rhs" using repc_preds adjoint_preds dotsubstt_def by auto
   moreover have geq: "Games ?lhs = Games ?rhs" using repc_games adjoint_games dotsubstt_def by auto
   moreover have ceq: "Consts ?lhs = Consts ?rhs" using repc_consts  adjoint_consts dotsubstt_def by auto
   show ?thesis using mkinterp_eq[where I=\<open>?lhs\<close> and J=\<open>?rhs\<close>] feq peq geq ceq by simp
 qed
 
   
 subsection \<open>Uniform Substitution for Terms\<close>
 
 text \<open>Lemma 15 of \<^url>\<open>http://arxiv.org/abs/1902.07230\<close>\<close>
 theorem usubst_term: "Uvariation \<nu> \<omega> U \<Longrightarrow> usubstappt \<sigma> U \<theta>\<noteq>undeft \<Longrightarrow>
     term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu> = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>"
 proof- 
   assume vaouter: "Uvariation \<nu> \<omega> U"
   assume defouter: "usubstappt \<sigma> U \<theta>\<noteq>undeft"
   show "usubstappt \<sigma> U \<theta>\<noteq>undeft \<Longrightarrow> term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu> = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" for \<sigma> \<theta>
     using vaouter proof (induction arbitrary: \<nu> \<omega> rule: usubstappt_induct)
     case (Var \<sigma> U x)
     then show ?case by simp
   next
     case (Number \<sigma> U r)
     then show ?case by simp
   next
     case (Const \<sigma> U f)
     then show ?case 
     proof (cases "SConst \<sigma> f")
       case None
       then show ?thesis using adjoint_consts by (simp add: usappconst_def)
     next
       case (Some r)
       then have varcond: "FVT(r)\<inter>U={}" using Const usubstappt_const usubstappt_const_conv by (metis option.inject option.simps(3))
       from Some have "term_sem I (the (usubstappt \<sigma> U (Const f))) \<nu> = term_sem I r \<nu>" by (simp add: varcond)
       also have "... = term_sem I r \<omega>" using Const coincidence_term_cor[of \<nu> \<omega> U r] varcond by simp
       also have "... = Consts (adjoint \<sigma> I \<omega>) f" using Some adjoint_consts by simp
       also have "... = term_sem (adjoint \<sigma> I \<omega>) (Const f) \<nu>" by auto
       finally show "term_sem I (the (usubstappt \<sigma> U (Const f))) \<nu> = term_sem (adjoint \<sigma> I \<omega>) (Const f) \<nu>" .
     qed
   next
     case (FuncMatch \<sigma> U f \<theta>)
     then have va: "Uvariation \<nu> \<omega> U" by simp
     then show ?case
     proof (cases "SFuncs \<sigma> f")
       case None 
       from FuncMatch and None have IHsubterm: "term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu> = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" using va
         by (simp add: FuncMatch.IH(1) usubstappt_func_conv)
       from None show ?thesis using usubstappt_func IHsubterm adjoint_funcs
         by (metis (no_types, lifting) FuncMatch.prems(1) option.case_eq_if option.sel term_sem.simps(4) usubstappt.simps(4))
     next
       case (Some r)
       then have varcond: "FVT(r)\<inter>U={}" using FuncMatch usubstappt_func usubstappt_func2 usubstappt_func_conv by meson
       from FuncMatch have subdef: "usubstappt \<sigma> U \<theta> \<noteq> undeft" using usubstappt_func_conv by auto
       from FuncMatch and Some
       have IHsubterm: "term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu> = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" using va subdef by blast
       from FuncMatch and Some
       have IHsubsubst: "\<And>\<nu> \<omega>. Uvariation \<nu> \<omega> {} \<Longrightarrow> term_sem I (the (usubstappt (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} r)) \<nu> = term_sem (adjoint (dotsubstt (the (usubstappt \<sigma> U \<theta>))) I \<omega>) r \<nu>"
         using subdef varcond by fastforce 
 
       let ?d = "term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu>"
       have deq: "?d = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" by (rule IHsubterm)
       let ?dotIa = "adjoint (dotsubstt (the (usubstappt \<sigma> U \<theta>))) I \<nu>"
 
       from Some 
       have "term_sem I (the (usubstappt \<sigma> U (Func f \<theta>))) \<nu> = term_sem I (the (usubstappt (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} r)) \<nu>" using subdef varcond by force
       also have "... = term_sem ?dotIa r \<nu>" using IHsubsubst[where \<nu>=\<nu> and \<omega>=\<nu>] Uvariation_empty by auto
       also have "... = term_sem (repc I dotid ?d) r \<nu>" using adjoint_dotsubstt[where \<theta>=\<open>the (usubstappt \<sigma> U \<theta>)\<close> and I=I and \<omega>=\<nu>] by simp
       also have "... = term_sem (repc I dotid ?d) r \<omega>" using coincidence_term_cor[where \<omega>=\<nu> and \<omega>'=\<omega> and U=U and \<theta>=r and I=\<open>repc I dotid ?d\<close>] va varcond by simp
           (*I.^d\<omega>\<lbrakk>\<sigma>f(\<cdot>)\<rbrakk>  also have "... = term_sem ?dotIa r \<omega>" using coincidence_term_cor[of \<nu> \<omega> U r ?dotIa] uv varcond by simp*)
       also have "... = (Funcs (adjoint \<sigma> I \<omega>) f)(?d)" using adjoint_funcs_match Some by simp
       also have "... = (Funcs (adjoint \<sigma> I \<omega>) f)(term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>)" using deq by simp
       also have "... = term_sem (adjoint \<sigma> I \<omega>) (Func f \<theta>) \<nu>" by simp
       finally show "term_sem I (the (usubstappt \<sigma> U (Func f \<theta>))) \<nu> = term_sem (adjoint \<sigma> I \<omega>) (Func f \<theta>) \<nu>" .
     qed
   next
     case (Plus \<sigma> U \<theta> \<eta>)
     then show ?case using Pluso_undef by auto
   next
     case (Times \<sigma> U \<theta> \<eta>)
     then show ?case using Timeso_undef by auto
   next
     case (Differential \<sigma> U \<theta>)
     from Differential have subdef: "usubstappt \<sigma> allvars \<theta> \<noteq> undeft" using usubstappt_differential_conv by simp
     from Differential have IH: "\<And>\<nu>. term_sem I (the (usubstappt \<sigma> allvars \<theta>)) \<nu> = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" using subdef Uvariation_univ by blast (*by auto*)
 
     have "term_sem I (the (usubstappt \<sigma> U (Differential \<theta>))) \<nu> = term_sem I (Differential (the (usubstappt \<sigma> allvars \<theta>))) \<nu>" using subdef by force
     also have "... = sum(\<lambda>x. \<nu>(DVar x)*deriv(\<lambda>X. term_sem I (the (usubstappt \<sigma> allvars \<theta>)) (repv \<nu> (RVar x) X))(\<nu>(RVar x)))(allidents)" by simp
     also have "... = sum(\<lambda>x. \<nu>(DVar x)*deriv(\<lambda>X. term_sem (adjoint \<sigma> I \<omega>) \<theta> (repv \<nu> (RVar x) X))(\<nu>(RVar x)))(allidents)" using IH by auto
     also have "... = term_sem (adjoint \<sigma> I \<omega>) (Differential \<theta>) \<nu>" by simp
     finally show "term_sem I (the (usubstappt \<sigma> U (Differential \<theta>))) \<nu> = term_sem (adjoint \<sigma> I \<omega>) (Differential \<theta>) \<nu>" .
   qed
 qed
 
 subsection \<open>Uniform Substitution for Formulas and Games\<close>
 
 paragraph \<open>Separately Prove Crucial Ingredient for the ODE Case of \<open>usubst_fml_game\<close>\<close>
 
 lemma same_ODE_same_sol:
   "(\<And>\<nu>. Uvariation \<nu> (F(0)) {RVar x,DVar x} \<Longrightarrow> term_sem I \<theta> \<nu> = term_sem J \<eta> \<nu>)
   \<Longrightarrow> solves_ODE I F x \<theta> = solves_ODE J F x \<eta>"
   using Uvariation_Vagree Vagree_def solves_ODE_def
     (*by (smt double_complement)*)
 proof-
   assume va: "\<And>\<nu>. Uvariation \<nu> (F(0)) {RVar x,DVar x} \<Longrightarrow> term_sem I \<theta> \<nu> = term_sem J \<eta> \<nu>"
   then have va2: "\<And>\<nu>. Uvariation \<nu> (F(0)) {RVar x,DVar x} \<Longrightarrow> term_sem J \<eta> \<nu> = term_sem I \<theta> \<nu>" by simp
   have one: "\<And>I J \<theta> \<eta>. (\<And>\<nu>. Uvariation \<nu> (F(0)) {RVar x,DVar x} \<Longrightarrow> term_sem I \<theta> \<nu> = term_sem J \<eta> \<nu>)
    \<Longrightarrow> solves_ODE I F x \<theta> \<Longrightarrow> solves_ODE J F x \<eta>"
    proof-
      fix I J \<theta> \<eta>
      assume vaflow: "\<And>\<nu>. Uvariation \<nu> (F(0)) {RVar x,DVar x} \<Longrightarrow> term_sem I \<theta> \<nu> = term_sem J \<eta> \<nu>"
      assume sol: "solves_ODE I F x \<theta>"
      from vaflow and sol show "solves_ODE J F x \<eta>" unfolding solves_ODE_def using Uvariation_Vagree coincidence_term
      by (metis double_complement solves_Vagree sol)
   qed
   show "solves_ODE I F x \<theta> = solves_ODE J F x \<eta>" using one[where \<theta>=\<theta> and \<eta>=\<eta>, OF va] one[where \<theta>=\<eta> and \<eta>=\<theta>, OF va2] 
   by force
 qed
 
 
 lemma usubst_ode:
   assumes subdef: "usubstappt \<sigma> {RVar x,DVar x} \<theta> \<noteq> undeft"
   shows "solves_ODE I F x (the (usubstappt \<sigma> {RVar x,DVar x} \<theta>)) = solves_ODE (adjoint \<sigma> I (F(0))) F x \<theta>"
 proof-
   have vaflow: "\<And>F \<theta> \<zeta>. solves_ODE I F x \<theta> \<Longrightarrow> Uvariation (F(\<zeta>)) (F(0)) {RVar x,DVar x}" using solves_Vagree_trans by simp
   from subdef have IH: "\<And>\<nu>. Uvariation \<nu> (F(0)) {RVar x,DVar x} \<Longrightarrow> term_sem I (the (usubstappt \<sigma> {RVar x,DVar x} \<theta>)) \<nu> = term_sem (adjoint \<sigma> I (F(0))) \<theta> \<nu>" by (simp add: usubst_term)
   then show ?thesis using IH vaflow solves_ODE_def Uvariation_Vagree same_ODE_same_sol by blast  
 qed
 
 lemma usubst_ode_ext:
   assumes     uv: "Uvariation (F(0)) \<omega> (U\<union>{RVar x,DVar x})"
   assumes subdef: "usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta> \<noteq> undeft"
   shows "solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)) = solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta>"
   (*using usubst_ode usubstappt_det usubstappt_antimon Uvariation_Vagree Uvariation_mon *)
 proof-
   have vaflow1: "\<And>F \<theta> \<zeta>. solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)) \<Longrightarrow> Uvariation (F(\<zeta>)) (F(0)) {RVar x,DVar x}" using solves_Vagree_trans by simp
   have vaflow2: "\<And>F \<theta> \<zeta>. solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta> \<Longrightarrow> Uvariation (F(\<zeta>)) (F(0)) {RVar x,DVar x}" using solves_Vagree_trans by simp
   from subdef have IH: "\<And>\<nu>. Uvariation \<nu> (F(0)) (U\<union>{RVar x,DVar x}) \<Longrightarrow> term_sem I (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)) \<nu> = term_sem (adjoint \<sigma> I (F(0))) \<theta> \<nu>" using Uvariation_refl Uvariation_trans usubst_term by blast
   have l2r: "solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)) \<Longrightarrow> solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta>"
     using vaflow1 subdef same_ODE_same_sol Uvariation_trans usubst_term uv
       (*by (smt sup_commute sup_left_idem)*)
   proof - (*sledgehammer*)
     assume a1: "solves_ODE I F x (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>))"
     obtain rr :: "trm \<Rightarrow> interp \<Rightarrow> trm \<Rightarrow> interp \<Rightarrow> char \<Rightarrow> (real \<Rightarrow> variable \<Rightarrow> real) \<Rightarrow> variable \<Rightarrow> real" where
       f2: "\<forall>x0 x1 x2 x3 x4 x5. (\<exists>v6. Uvariation v6 (x5 0) {RVar x4, DVar x4} \<and> term_sem x3 x2 v6 \<noteq> term_sem x1 x0 v6) = (Uvariation (rr x0 x1 x2 x3 x4 x5) (x5 0) {RVar x4, DVar x4} \<and> term_sem x3 x2 (rr x0 x1 x2 x3 x4 x5) \<noteq> term_sem x1 x0 (rr x0 x1 x2 x3 x4 x5))"
       by moura
     have f3: "Uvariation (F 0) \<omega> (insert (RVar x) (U \<union> {DVar x}))"
       using uv by auto
     have f4: "{DVar x} \<union> {} \<union> {DVar x} = insert (DVar x) ({DVar x} \<union> {} \<union> {}) \<longrightarrow> {RVar x} \<union> {DVar x} \<union> insert (RVar x) (U \<union> {DVar x}) = insert (RVar x) (U \<union> {DVar x})"
       by fastforce
     { assume "{DVar x} \<union> {} \<union> {DVar x} = insert (DVar x) ({DVar x} \<union> {} \<union> {}) \<and> Uvariation (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F) \<omega> ({RVar x} \<union> {DVar x} \<union> insert (RVar x) (U \<union> {DVar x}))"
       then have "\<not> Uvariation (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F) (F 0) {RVar x, DVar x} \<or> term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F) = term_sem I (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F)"
         using f4 subdef usubst_term by auto }
     then have "\<not> Uvariation (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F) (F 0) {RVar x, DVar x} \<or> term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F) = term_sem I (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) (rr (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I \<theta> (USubst.adjoint \<sigma> I \<omega>) x F)"
       using f3 by (metis (no_types) Uvariation_trans insert_is_Un)
     then show ?thesis
       using f2 a1 by (meson same_ODE_same_sol)
   qed 
   have r2l: "solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta> \<Longrightarrow> solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>))"
     using vaflow2 subdef same_ODE_same_sol Uvariation_trans usubst_term uv
       (*by (smt sup_commute sup_left_idem)*)
   proof - (*sledgehammer*)
     assume a1: "solves_ODE (USubst.adjoint \<sigma> I \<omega>) F x \<theta>"
     obtain rr :: "trm \<Rightarrow> interp \<Rightarrow> trm \<Rightarrow> interp \<Rightarrow> char \<Rightarrow> (real \<Rightarrow> variable \<Rightarrow> real) \<Rightarrow> variable \<Rightarrow> real" where
       "\<forall>x0 x1 x2 x3 x4 x5. (\<exists>v6. Uvariation v6 (x5 0) {RVar x4, DVar x4} \<and> term_sem x3 x2 v6 \<noteq> term_sem x1 x0 v6) = (Uvariation (rr x0 x1 x2 x3 x4 x5) (x5 0) {RVar x4, DVar x4} \<and> term_sem x3 x2 (rr x0 x1 x2 x3 x4 x5) \<noteq> term_sem x1 x0 (rr x0 x1 x2 x3 x4 x5))"
       by moura
     then have f2: "\<forall>f c i t ia ta. Uvariation (rr ta ia t i c f) (f 0) {RVar c, DVar c} \<and> term_sem i t (rr ta ia t i c f) \<noteq> term_sem ia ta (rr ta ia t i c f) \<or> solves_ODE i f c t = solves_ODE ia f c ta"
       by (meson same_ODE_same_sol)
     have f3: "Uvariation (F 0) \<omega> ({RVar x, DVar x} \<union> U)"
       using uv by force
     have f4: "usubstappt \<sigma> ({RVar x, DVar x} \<union> U) \<theta> \<noteq> undeft"
       using subdef by auto
     { assume "Uvariation (rr \<theta> (USubst.adjoint \<sigma> I \<omega>) (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I x F) \<omega> ({RVar x, DVar x} \<union> ({RVar x, DVar x} \<union> U))"
       then have "\<not> Uvariation (rr \<theta> (USubst.adjoint \<sigma> I \<omega>) (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I x F) (F 0) {RVar x, DVar x} \<or> term_sem I (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) (rr \<theta> (USubst.adjoint \<sigma> I \<omega>) (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I x F) = term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> (rr \<theta> (USubst.adjoint \<sigma> I \<omega>) (the (usubstappt \<sigma> (U \<union> {RVar x, DVar x}) \<theta>)) I x F)"
         using f4 by (simp add: Un_commute usubst_term) }
     then show ?thesis
       using f3 f2 a1 by (meson Uvariation_trans)
   qed
   from l2r and r2l show ?thesis by auto
 qed
 
 lemma usubst_ode_ext2:
   assumes subdef: "usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta> \<noteq> undeft"
   assumes     uv: "Uvariation (F(0)) \<omega> (U\<union>{RVar x,DVar x})"
   shows "solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)) = solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta>"
   using usubst_ode_ext subdef uv by blast 
 
 paragraph \<open>Separately Prove the Loop Case of \<open>usubst_fml_game\<close>\<close>
 
 lemma union_comm: "A\<union>B=B\<union>A"
   by auto
 
 
 definition loopfp\<tau>:: "game \<Rightarrow> interp \<Rightarrow> (state set \<Rightarrow> state set)"
   where "loopfp\<tau> \<alpha> I X = lfp(\<lambda>Z. X \<union> game_sem I \<alpha> Z)"
 
 lemma usubst_game_loop:
   assumes  uv: "Uvariation \<nu> \<omega> U"
     and  IH\<alpha>rec: "\<And>\<nu> \<omega> X. Uvariation \<nu> \<omega> (fst(usubstappp \<sigma> U \<alpha>)) \<Longrightarrow> snd (usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<alpha>)\<noteq>undefg \<Longrightarrow> 
          (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)"
   shows "snd (usubstappp \<sigma> U (Loop \<alpha>))\<noteq>undefg \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (Loop \<alpha>)))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (Loop \<alpha>) X)"
 proof-
   assume def: "snd (usubstappp \<sigma> U (Loop \<alpha>))\<noteq>undefg"
   have loopfix: "\<And>\<alpha> I X. loopfp\<tau> \<alpha> I X = game_sem I (Loop \<alpha>) X" unfolding loopfp\<tau>_def using game_sem_loop by metis
   let ?\<sigma>\<alpha>loopoff = "the (snd (usubstappp \<sigma> U (Loop \<alpha>)))"
   let ?\<sigma>\<alpha> = "the (snd(usubstappp \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<alpha>))"
   let ?\<sigma>\<alpha>loop = "Loop ?\<sigma>\<alpha>"
   have loopform: "?\<sigma>\<alpha>loopoff = ?\<sigma>\<alpha>loop" using usubstappp_loop
     by (metis (mono_tags, lifting) Loopo.simps(1) def option.exhaust_sel option.inject snd_conv usubstappp_loop_conv)
   let ?\<tau> = "loopfp\<tau> ?\<sigma>\<alpha>loop I"
   let ?\<rho> = "loopfp\<tau> \<alpha> (adjoint \<sigma> I \<omega>)"
   let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
   have fact1: "\<And>V. snd(usubstappp \<sigma> V \<alpha>)\<noteq>undefg \<Longrightarrow>  fst(usubstappp \<sigma> V \<alpha>) \<supseteq> BVG(the (snd(usubstappp \<sigma> V \<alpha>)))" using usubst_taboos by simp
   have fact2: "\<And>V W. snd(usubstappp \<sigma> V \<alpha>)\<noteq>undefg \<Longrightarrow> snd(usubstappp \<sigma> W \<alpha>)\<noteq>undefg \<Longrightarrow> (fst(usubstappp \<sigma> V \<alpha>) \<supseteq> BVG(the (snd(usubstappp \<sigma> W \<alpha>))))" using fact1 usubst_taboos usubstappp_det by metis
   have VgeqBV: "?V \<supseteq> BVG(?\<sigma>\<alpha>)" using usubst_taboos fact2 def usubstappp_loop_conv by simp
   have uvV: "Vagree \<nu> \<omega> (-?V)" using uv
     by (metis Uvariation_Vagree Uvariation_mon double_compl usubst_taboos_mon)  
   have \<tau>eq: "?\<tau>(X) = game_sem I ?\<sigma>\<alpha>loop X" using loopfix by auto
   have \<rho>eq: "?\<rho>(X) = game_sem (adjoint \<sigma> I \<omega>) (Loop \<alpha>) X"  using loopfix by auto
   have \<tau>is\<rho>: "selectlike (?\<tau>(X)) \<omega> (-?V)= selectlike (?\<rho>(X)) \<omega> (-?V)"
   proof-
     let ?f = "\<lambda>Z. X \<union> game_sem I ?\<sigma>\<alpha> Z"
     let ?g = "\<lambda>Y. X \<union> game_sem (adjoint \<sigma> I \<omega>) \<alpha> Y"
     let ?R = "\<lambda>Z Y. selectlike Z \<omega> (-?V) = selectlike Y \<omega> (-?V)"
     have "?R (lfp ?f) (lfp ?g)"
     proof (induction rule: lfp_lockstep_induct[where f=\<open>?f\<close> and g=\<open>?g\<close> and R=\<open>?R\<close>])
       case monof
       then show ?case using game_sem_loop_fixpoint_mono by simp
     next
       case monog
       then show ?case using game_sem_loop_fixpoint_mono by simp
     next
       case (step A B)
       then have IHfp: "selectlike A \<omega> (-?V) = selectlike B \<omega> (-?V)" by simp
       show "selectlike (X \<union> game_sem I ?\<sigma>\<alpha> A) \<omega> (-?V) = selectlike (X \<union> game_sem (adjoint \<sigma> I \<omega>) \<alpha> B) \<omega> (-?V)"
       proof (rule selectlike_equal_cocond_corule
           (*[where \<nu>=\<omega> and V=\<open>?V\<close> and X=\<open>X \<union> game_sem I ?\<sigma>\<alpha> A\<close> and Y=\<open>X \<union> game_sem (adjoint \<sigma> I \<omega>) \<alpha> B\<close>]*))
         fix \<mu>
         assume muvar: "Uvariation \<mu> \<omega> ?V"
         have forw: "(\<mu> \<in> X \<union> game_sem I ?\<sigma>\<alpha> A) = (\<mu> \<in> X \<union> game_sem I ?\<sigma>\<alpha> (selectlike A \<mu> (-BVG(?\<sigma>\<alpha>))))" using boundeffect by auto
 
         have "(\<mu> \<in> X \<union> game_sem (adjoint \<sigma> I \<omega>) \<alpha> B) = (\<mu> \<in> X \<union> game_sem I ?\<sigma>\<alpha> B)" using IH\<alpha>rec[OF muvar]
           using def usubstappp_loop_conv by auto
         also have "... = (\<mu> \<in> X \<union> game_sem I ?\<sigma>\<alpha> (selectlike B \<mu> (-BVG(?\<sigma>\<alpha>))))" using boundeffect by simp
         finally have backw: "(\<mu> \<in>  X \<union> game_sem (adjoint \<sigma> I \<omega>) \<alpha> B) =  (\<mu> \<in> X \<union> game_sem I ?\<sigma>\<alpha> (selectlike B \<mu> (-BVG(?\<sigma>\<alpha>))))" .
 
         have samewin: "selectlike A \<mu> (-BVG(?\<sigma>\<alpha>)) = selectlike B \<mu> (-BVG(?\<sigma>\<alpha>))" using IHfp selectlike_antimon VgeqBV muvar Uvariation_trans selectlike_equal_cocond
             (*by (smt le_iff_sup)*)
         proof -
           have "Vagree \<mu> \<omega> (- fst (usubstappp \<sigma> U \<alpha>))"
             by (metis Uvariation_Vagree double_complement muvar)
           then have "selectlike A \<mu> (- fst (usubstappp \<sigma> U \<alpha>)) = selectlike B \<mu> (- fst (usubstappp \<sigma> U \<alpha>))"
             using IHfp selectlike_Vagree by presburger
           then show ?thesis
             by (metis (no_types) Compl_subset_Compl_iff VgeqBV selectlike_compose sup.absorb_iff2)
         qed
         from forw and backw show "(\<mu> \<in> X \<union> game_sem I ?\<sigma>\<alpha> A) = (\<mu> \<in> X \<union> game_sem (adjoint \<sigma> I \<omega>) \<alpha> B)" using samewin by auto
       qed
 
     next
       case (union M)
       then show ?case using selectlike_Sup[where \<nu>=\<omega> and V=\<open>-?V\<close>] fst_proj_def snd_proj_def by (simp) (blast)
     qed
     then show ?thesis
       using \<tau>eq loopfix loopfp\<tau>_def by auto
   qed
   show ?thesis using \<tau>eq \<rho>eq \<tau>is\<rho> similar_selectlike_mem[OF uvV] by (metis loopform) 
 qed
 
 
 
 lemma usubst_fml_game: 
   assumes vaouter: "Uvariation \<nu> \<omega> U"
   shows "usubstappf \<sigma> U \<phi>\<noteq>undeff \<Longrightarrow> (\<nu> \<in> fml_sem I (the (usubstappf \<sigma> U \<phi>))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)"
     and "snd (usubstappp \<sigma> U \<alpha>)\<noteq>undefg \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)"
 proof-
   show "usubstappf \<sigma> U \<phi>\<noteq>undeff \<Longrightarrow> (\<nu> \<in> fml_sem I (the (usubstappf \<sigma> U \<phi>))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)" 
     and "snd (usubstappp \<sigma> U \<alpha>)\<noteq>undefg \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)" for \<sigma> \<phi> \<alpha>
     using vaouter proof (induction \<phi> and \<alpha> arbitrary: \<nu> \<omega> and \<nu> \<omega> X rule: usubstappfp_induct)
     case (Pred \<sigma> U p \<theta>)
     then have va: "Uvariation \<nu> \<omega> U" by simp
     then show ?case
     proof (cases "SPreds \<sigma> p")
       case None
       then show ?thesis using usubst_term[OF va] adjoint_preds_skip
           (*by (smt Pred.prems(1) fml_sem.simps(1) mem_Collect_eq option.case_eq_if option.sel usubstappf.simps(1))*)
       proof - (*sledgehammer*)
         have "\<forall>p V c t. usubstappf p V (Pred c t) = (if usubstappt p V t = undeft then undeff else case SPreds p c of None \<Rightarrow> Afml (Pred c (the (usubstappt p V t))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt p V t))) {} f else undeff)"
           by (simp add: option.case_eq_if)
         then have f1: "\<forall>p V c t. if usubstappt p V t = undeft then usubstappf p V (Pred c t) = undeff else usubstappf p V (Pred c t) = (case SPreds p c of None \<Rightarrow> Afml (Pred c (the (usubstappt p V t))) | Some f \<Rightarrow> if FVF f \<inter> V = {} then usubstappf (dotsubstt (the (usubstappt p V t))) {} f else undeff)"
           by presburger
         then have "usubstappt \<sigma> U \<theta> \<noteq> undeft"
           by (meson Pred.prems(1))
         then have f2: "usubstappf \<sigma> U (Pred p \<theta>) = Afml (Pred p (the (usubstappt \<sigma> U \<theta>)))"
           using None by force
         have "usubstappt \<sigma> U \<theta> \<noteq> undeft"
           using f1 by (meson Pred.prems(1))
         then show ?thesis
           using f2 by (simp add: None \<open>\<And>\<theta> \<sigma> I. usubstappt \<sigma> U \<theta> \<noteq> undeft \<Longrightarrow> term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu> = term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> \<nu>\<close> adjoint_preds_skip)
       qed
 
     next
       case (Some r)
       then have varcond: "FVF(r)\<inter>U={}" using Pred usubstappf_pred usubstappf_pred2 usubstappf_pred_conv by meson 
       from Pred have subdef: "usubstappt \<sigma> U \<theta> \<noteq> undeft" using usubstappf_pred_conv by auto
       from Pred and Some
       have IHsubsubst: "\<And>\<nu> \<omega>. Uvariation \<nu> \<omega> {} \<Longrightarrow> (\<nu> \<in> fml_sem I (the (usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} r))) = (\<nu> \<in> fml_sem (adjoint (dotsubstt (the (usubstappt \<sigma> U \<theta>))) I \<omega>) r)"
         using subdef varcond by fastforce
 
       let ?d = "term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu>"
       have deq: "?d = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" by (rule usubst_term[OF va subdef])
       let ?dotIa = "adjoint (dotsubstt (the (usubstappt \<sigma> U \<theta>))) I \<nu>"
 
       from Some
       have "(\<nu>\<in>fml_sem I (the (usubstappf \<sigma> U (Pred p \<theta>)))) = (\<nu>\<in>fml_sem I (the (usubstappf (dotsubstt (the (usubstappt \<sigma> U \<theta>))) {} r)))"
         using subdef varcond by force 
       also have "... = (\<nu>\<in>fml_sem ?dotIa r)" using IHsubsubst[where \<nu>=\<nu> and \<omega>=\<nu>] Uvariation_empty by auto
       also have "... = (\<nu>\<in>fml_sem (repc I dotid ?d) r)" using adjoint_dotsubstt[where \<theta>=\<open>the (usubstappt \<sigma> U \<theta>)\<close> and I=I and \<omega>=\<nu>] by simp
       also have "... = (\<omega>\<in>fml_sem (repc I dotid ?d) r)" using coincidence_formula_cor[where \<omega>=\<nu> and \<omega>'=\<omega> and U=U and \<phi>=r and I=\<open>repc I dotid ?d\<close>] va varcond by simp
           (*I.^d\<omega>\<lbrakk>\<sigma>f(\<cdot>)\<rbrakk>  also have "... = term_sem ?dotIa r \<omega>" using coincidence_term_cor[of \<nu> \<omega> U r ?dotIa] uv varcond by simp*)
       also have "... = (Preds (adjoint \<sigma> I \<omega>) p)(?d)" using adjoint_preds_match Some by simp
       also have "... = (Preds (adjoint \<sigma> I \<omega>) p)(term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>)" using deq by simp
       also have "... = (\<nu>\<in>fml_sem (adjoint \<sigma> I \<omega>) (Pred p \<theta>))" by simp
       finally show "(\<nu>\<in>fml_sem I (the (usubstappf \<sigma> U (Pred p \<theta>)))) = (\<nu>\<in>fml_sem (adjoint \<sigma> I \<omega>) (Pred p \<theta>))" .
     qed
 
   next
     case (Geq \<sigma> U \<theta> \<eta>)
       (* then show ?case using usubst_term usubstappf_geq usubstappf_geq_conv
           by (smt fml_sem.simps(2) mem_Collect_eq option.sel)*)
     then have def1: "usubstappt \<sigma> U \<theta> \<noteq> undeft" using usubstappf_geq_conv by simp 
     moreover have def2: "usubstappt \<sigma> U \<eta> \<noteq> undeft" using usubstappf_geq_conv Geq.prems(1) by blast 
     show ?case
       using usubst_term[OF \<open>Uvariation \<nu> \<omega> U\<close>, OF def1] usubst_term[OF \<open>Uvariation \<nu> \<omega> U\<close>,OF def2] usubstappf_geqr[OF \<open>usubstappf \<sigma> U (Geq \<theta> \<eta>) \<noteq> undeff\<close>] by force
   next
     case (Not \<sigma> U \<phi>)
     then show ?case using Noto_undef by auto
   next
     case (And \<sigma> U \<phi> \<psi>)
     then show ?case using Ando_undef by auto
 
   next
     case (Exists \<sigma> U x \<phi>)
     then have IH: "\<And>\<nu> \<omega>. Uvariation \<nu> \<omega> (U\<union>{x}) \<Longrightarrow> (\<nu> \<in> fml_sem I (the (usubstappf \<sigma> (U\<union>{x}) \<phi>))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)" by force
     from Exists have "Uvariation \<nu> \<omega> U" by simp
     (*from Exists have subdef: "usubstappt \<sigma> (U\<union>{x}) \<theta> \<noteq> undeft" by auto*)
 
     then have Uvar: "\<And>d. Uvariation (repv \<nu> x d) \<omega> (U\<union>{x})" using Uvariation_repv Uvariation_trans Uvariation_sym
       using Exists.prems(2) Uvariation_def by auto
     have "(\<nu>\<in>fml_sem I (the (usubstappf \<sigma> U (Exists x \<phi>)))) = (\<nu>\<in>fml_sem I (Exists x (the (usubstappf \<sigma> (U\<union>{x}) \<phi>))))"
       using usubstappf_exists Exists.prems(1) by fastforce
     also have "... = (\<exists>d. (repv \<nu> x d)\<in>fml_sem I (the (usubstappf \<sigma> (U\<union>{x}) \<phi>)))" by simp
     also have "... = (\<exists>d. (repv \<nu> x d)\<in>fml_sem (adjoint \<sigma> I \<omega>) \<phi>)" using IH Uvar by auto
     also have "... = (\<nu>\<in>fml_sem (adjoint \<sigma> I \<omega>) (Exists x \<phi>))" by auto
     finally have "(\<nu>\<in>fml_sem I (the (usubstappf \<sigma> U (Exists x \<phi>)))) =  (\<nu>\<in>fml_sem (adjoint \<sigma> I \<omega>) (Exists x \<phi>))" . 
     from this show ?case by simp
 
   next
     case (Diamond \<sigma> U \<alpha> \<phi>)
     let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
     from Diamond have IH\<alpha>: "\<And>X. Uvariation \<nu> \<omega> U \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)" by fastforce 
     from Diamond have IH\<phi>: "\<And>\<nu> \<omega>. Uvariation \<nu> \<omega> (fst(usubstappp \<sigma> U \<alpha>)) \<Longrightarrow> (\<nu> \<in> fml_sem I (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)"
       by (simp add: Diamondo_undef) 
     from Diamond have uv: "Uvariation \<nu> \<omega> U" by simp
     have "(\<nu> \<in> fml_sem I (the (usubstappf \<sigma> U (Diamond \<alpha> \<phi>)))) = (\<nu> \<in> fml_sem I (let V\<alpha> = usubstappp \<sigma> U \<alpha> in Diamond (the (snd V\<alpha>)) (the (usubstappf \<sigma> (fst V\<alpha>) \<phi>))))"
       by (metis Diamond.prems(1) Diamondo.elims option.sel usubstappf.simps(6)) 
     also have "... = (\<nu> \<in> fml_sem I (Diamond (the (snd(usubstappp \<sigma> U \<alpha>))) (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>))))" by simp
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (fml_sem I (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>))))" by simp
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike (fml_sem I (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>))) \<nu> (-BVG(the (snd(usubstappp \<sigma> U \<alpha>))))))" using boundeffect by auto
     finally have forw: "(\<nu> \<in> fml_sem I (the (usubstappf \<sigma> U (Diamond \<alpha> \<phi>)))) = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike (fml_sem I (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>))) \<nu> (-BVG(the (snd(usubstappp \<sigma> U \<alpha>))))))" .
 
     have "(\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) (Diamond \<alpha> \<phi>)) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> (fml_sem (adjoint \<sigma> I \<omega>) \<phi>))" by simp
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (fml_sem (adjoint \<sigma> I \<omega>) \<phi>))" using IH\<alpha> uv by simp
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike (fml_sem (adjoint \<sigma> I \<omega>) \<phi>) \<nu> (-BVG(the (snd(usubstappp \<sigma> U \<alpha>))))))" using boundeffect by auto
     finally have backw: "(\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) (Diamond \<alpha> \<phi>)) = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike (fml_sem (adjoint \<sigma> I \<omega>) \<phi>) \<nu> (-BVG(the (snd(usubstappp \<sigma> U \<alpha>))))))" .
 
     have samewin: "selectlike (fml_sem I (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>))) \<nu> (-BVG(the (snd(usubstappp \<sigma> U \<alpha>)))) = selectlike (fml_sem (adjoint \<sigma> I \<omega>) \<phi>) \<nu> (-BVG(the (snd(usubstappp \<sigma> U \<alpha>))))"
     proof (rule selectlike_equal_cocond_corule)
       fix \<mu>
       assume muvar: "Uvariation \<mu> \<nu> (BVG(the (snd(usubstappp \<sigma> U \<alpha>))))" 
       have U\<mu>\<omega>: "Uvariation \<mu> \<omega> ?V" using muvar uv Uvariation_trans union_comm usubst_taboos Uvariation_mon
           (*by (smt Diamond.prems(1) Diamondo.simps(2) usubstappf.simps(6))*)
       proof- 
         have U\<mu>\<nu>: "Uvariation \<mu> \<nu> (BVG(the (snd(usubstappp \<sigma> U \<alpha>))))" by (rule muvar)
         have U\<nu>\<omega>: "Uvariation \<nu> \<omega> U" by (rule uv)
         have "Uvariation \<mu> \<omega> (U \<union> BVG(the (snd(usubstappp \<sigma> U \<alpha>))))" using Uvariation_trans[OF U\<mu>\<nu> U\<nu>\<omega>] union_comm by (rule HOL.back_subst)
         thus ?thesis using usubst_taboos Uvariation_mon by (metis (mono_tags, lifting) Diamond.prems(1) Diamondo_undef Uvariation_mon usubst_taboos usubstappf.simps(6))
       qed
       have "(\<mu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>) = (\<mu> \<in> fml_sem I (the (usubstappf \<sigma> (fst(usubstappp \<sigma> U \<alpha>)) \<phi>)))"
         using muvar Uvariation_trans uv IH\<phi> boundeffect Uvariation_mon usubst_taboos U\<mu>\<omega> by auto
       then show "(\<mu> \<in> fml_sem I (the (usubstappf \<sigma> (fst (usubstappp \<sigma> U \<alpha>)) \<phi>))) = (\<mu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)" by simp
     qed
     from forw and backw show "(\<nu> \<in> fml_sem I (the (usubstappf \<sigma> U (Diamond \<alpha> \<phi>)))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) (Diamond \<alpha> \<phi>))" using samewin by auto
 
   next (* games *)
 
     case (Game \<sigma> U a)
     then show ?case using adjoint_games usubstappp_game by (cases "SGames \<sigma> a") auto
 
   next
     case (Assign \<sigma> U x \<theta>)
     then show ?case using usubst_term Assigno_undef
         (*by (smt Assigno.elims game_sem.simps(2) mem_Collect_eq option.sel snd_pair usubstappp.simps(2))*)
     proof - (*sledgehammer*)
       have f1: "usubstappt \<sigma> U \<theta> \<noteq> undeft"
         using Assign.prems(1) Assigno_undef by auto
       { assume "repv \<nu> x (term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> \<nu>) \<in> X"
         then have "repv \<nu> x (term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu>) \<in> X"
           using f1 Assign.prems(2) usubst_term by auto
         then have "repv \<nu> x (term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> \<nu>) \<in> X \<longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (x := \<theta>)))) X) = (\<nu> \<in> game_sem (USubst.adjoint \<sigma> I \<omega>) (x := \<theta>) X)"
           using f1 by force }
       moreover
       { assume "repv \<nu> x (term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> \<nu>) \<notin> X"
         then have "repv \<nu> x (term_sem I (the (usubstappt \<sigma> U \<theta>)) \<nu>) \<notin> X \<and> repv \<nu> x (term_sem (USubst.adjoint \<sigma> I \<omega>) \<theta> \<nu>) \<notin> X"
           using f1 Assign.prems(2) usubst_term by presburger
         then have ?thesis
           using f1 by force }
       ultimately show ?thesis
         by fastforce
     qed
 
   next
     case (Test \<sigma> U \<phi>)
     then show ?case using Testo_undef by auto
 
   next
     case (Choice \<sigma> U \<alpha> \<beta>)
     from Choice have IH\<alpha>: "\<And>X. Uvariation \<nu> \<omega> U \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)" by (simp add: Choiceo_undef) 
     from Choice have IH\<beta>: "\<And>X. Uvariation \<nu> \<omega> U \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<beta>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<beta> X)" by (simp add: Choiceo_undef) 
     from Choice have uv: "Uvariation \<nu> \<omega> U" by simp
     show ?case using IH\<alpha> IH\<beta> uv
         (*by (smt Choice.prems(1) Choiceo.elims game_sem.simps(4) option.sel snd_pair union_or usubstappp_choice) *)
     proof -
       have f1: "Agame (the (snd (usubstappp \<sigma> U \<alpha>))) = snd (usubstappp \<sigma> U \<alpha>)"
         by (meson Choice(3) option.collapse usubstappp_choice_conv)
       have "Agame (the (snd (usubstappp \<sigma> U \<beta>))) = snd (usubstappp \<sigma> U \<beta>)"
         by (meson Choice(3) option.collapse usubstappp_choice_conv)
       then have "snd (usubstappp \<sigma> U (\<alpha> \<union>\<union> \<beta>)) = Agame (the (snd (usubstappp \<sigma> U \<alpha>)) \<union>\<union> the (snd (usubstappp \<sigma> U \<beta>)))"
         using f1 by (metis Choiceo.simps(1) snd_conv usubstappp.simps(4))
       then have f2: "game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X \<union> game_sem I (the (snd (usubstappp \<sigma> U \<beta>))) X = game_sem I (the (snd (usubstappp \<sigma> U (\<alpha> \<union>\<union> \<beta>)))) X"
         by simp
       moreover
       { assume "\<nu> \<notin> game_sem I (the (snd (usubstappp \<sigma> U \<beta>))) X"
         have "(\<nu> \<notin> game_sem I (the (snd (usubstappp \<sigma> U (\<alpha> \<union>\<union> \<beta>)))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (\<alpha> \<union>\<union> \<beta>) X) \<longrightarrow> \<nu> \<notin> game_sem I (the (snd (usubstappp \<sigma> U \<beta>))) X \<and> \<nu> \<notin> game_sem (adjoint \<sigma> I \<omega>) (\<alpha> \<union>\<union> \<beta>) X"
           using f2 Choice(4) IH\<alpha> IH\<beta> by auto
         then have "(\<nu> \<notin> game_sem I (the (snd (usubstappp \<sigma> U (\<alpha> \<union>\<union> \<beta>)))) X) \<noteq> (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (\<alpha> \<union>\<union> \<beta>) X)"
           using f2 Choice(4) IH\<alpha> by auto }
       ultimately show ?thesis
         using Choice(4) IH\<beta> by auto
     qed 
 
   next
     case (Compose \<sigma> U \<alpha> \<beta>)
     let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
     from Compose have IH\<alpha>: "\<And>X. Uvariation \<nu> \<omega> U \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)" by (simp add: Composeo_undef) 
     from Compose have IH\<beta>: "\<And>\<nu> \<omega> X. Uvariation \<nu> \<omega> ?V \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> ?V \<beta>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<beta> X)" by (simp add: Composeo_undef) 
     from Compose have uv: "Uvariation \<nu> \<omega> U" by simp
     have "(\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (Compose \<alpha> \<beta>)))) X) = (\<nu> \<in> game_sem I (Compose (the (snd(usubstappp \<sigma> U \<alpha>))) (the (snd(usubstappp \<sigma> ?V \<beta>)))) X)"
       by (metis (no_types, lifting) Compose.prems(1) Composeo.elims option.sel snd_pair usubstappp.simps(5))
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (game_sem I (the (snd(usubstappp \<sigma> ?V \<beta>))) X))" by simp
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike (game_sem I (the (snd(usubstappp \<sigma> ?V \<beta>))) X) \<nu> (-BVG(the(snd(usubstappp \<sigma> U \<alpha>))))))" using boundeffect by auto
     finally have forw: "(\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (Compose \<alpha> \<beta>)))) X) = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike (game_sem I (the (snd(usubstappp \<sigma> ?V \<beta>))) X) \<nu> (-BVG(the(snd(usubstappp \<sigma> U \<alpha>))))))" .
 
     have "(\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (Compose \<alpha> \<beta>) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> ((game_sem (adjoint \<sigma> I \<omega>) \<beta>) X))" by simp
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) ((game_sem (adjoint \<sigma> I \<omega>) \<beta>) X))" using IH\<alpha>[OF uv] by auto
     also have "... = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike ((game_sem (adjoint \<sigma> I \<omega>) \<beta>) X) \<nu> (-BVG(the(snd(usubstappp \<sigma> U \<alpha>))))))" using boundeffect by auto
     finally have backw: "(\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (Compose \<alpha> \<beta>) X) = (\<nu> \<in> game_sem I (the (snd(usubstappp \<sigma> U \<alpha>))) (selectlike ((game_sem (adjoint \<sigma> I \<omega>) \<beta>) X) \<nu> (-BVG(the(snd(usubstappp \<sigma> U \<alpha>))))))" .
 
     have samewin: "selectlike (game_sem I (the (snd(usubstappp \<sigma> ?V \<beta>))) X) \<nu> (-BVG(the(snd(usubstappp \<sigma> U \<alpha>)))) = selectlike ((game_sem (adjoint \<sigma> I \<omega>) \<beta>) X) \<nu> (-BVG(the(snd(usubstappp \<sigma> U \<alpha>))))"
     proof (rule selectlike_equal_cocond_corule)
       fix \<mu>
       assume muvar: "Uvariation \<mu> \<nu> (BVG(the(snd(usubstappp \<sigma> U \<alpha>))))" 
       have U\<mu>\<omega>: "Uvariation \<mu> \<omega> ?V" using muvar uv Uvariation_trans union_comm usubst_taboos Uvariation_mon
           (*by (smt Compose.prems(1) Composeo_undef snd_pair usubstappp.simps(5))*)
       proof -
         have "Uvariation \<mu> \<omega> (BVG (the (snd (usubstappp \<sigma> U \<alpha>))) \<union> U)" by (meson Uvariation_trans muvar uv)
         then show ?thesis using Uvariation_mon union_comm usubst_taboos
           by (metis (no_types, lifting) Compose.prems(1) Composeo_undef Pair_inject prod.collapse usubstappp_compose) 
             (*by (metis (no_types) Uvariation_mon union_comm usubst_taboos)*)
       qed
       have "(\<mu> \<in> game_sem I (the(snd(usubstappp \<sigma> ?V \<beta>))) X) = (\<mu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<beta> X)"
         using muvar Uvariation_trans uv IH\<beta> boundeffect Uvariation_mon usubst_taboos U\<mu>\<omega> by auto
       then show "(\<mu> \<in> game_sem I (the(snd(usubstappp \<sigma> ?V \<beta>))) X) = (\<mu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<beta> X)" by simp
     qed
     from forw and backw show "(\<nu> \<in> game_sem I (the(snd (usubstappp \<sigma> U (Compose \<alpha> \<beta>)))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (Compose \<alpha> \<beta>) X)" using samewin by auto
 
   next
     case (Loop \<sigma> U \<alpha>)
     let ?V = "fst(usubstappp \<sigma> U \<alpha>)"
     from Loop have selfdef: "snd (usubstappp \<sigma> U (Loop \<alpha>)) \<noteq> undefg" by auto
     from Loop have IH\<alpha>rec: "\<And>\<nu> \<omega> X. Uvariation \<nu> \<omega> ?V \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> ?V \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)" by fastforce 
     from Loop have uv: "Uvariation \<nu> \<omega> U" by simp
     show "(\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (Loop \<alpha>)))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (Loop \<alpha>) X)" 
       using usubst_game_loop IH\<alpha>rec Loop.prems(2) selfdef by blast 
       (*by (rule usubst_game_loop[OF uv (*IH\<alpha>*) IH\<alpha>rec])*)
 
   next
     case (Dual \<sigma> U \<alpha>)
     from Dual have IH\<alpha>: "\<And>X. Uvariation \<nu> \<omega> U \<Longrightarrow> (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)" by force 
     from Dual have uv: "Uvariation \<nu> \<omega> U" by simp
     from Dual have def: "snd (usubstappp \<sigma> U (\<alpha>^d)) \<noteq> undefg" by simp
         (*show ?case using IH\<alpha>[OF uv]
     by (smt Compl_iff Dual.prems(1) Dualo.elims game_sem.simps(7) option.sel snd_pair usubstappp.simps(7))*)
     have "(\<nu> \<in> -game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) (-X)) = (\<nu> \<in> -game_sem (adjoint \<sigma> I \<omega>) \<alpha> (-X))" using IH\<alpha>[OF uv] by simp
     then have "(\<nu> \<in> game_sem I ((the (snd (usubstappp \<sigma> U \<alpha>)))^d) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (\<alpha>^d) X)" using game_sem.simps(7) by auto
     then show ?case using usubstappp_dual Dualo_undef
     proof -
       have "\<And>\<sigma> V \<alpha>. snd (usubstappp \<sigma> U (\<alpha>^d)) = Dualo (snd (usubstappp \<sigma> U \<alpha>))"  by simp
       then have "snd (usubstappp \<sigma> U \<alpha>) \<noteq> undefg" using Dualo_undef def by presburger
       then show ?thesis
         using \<open>(\<nu> \<in> game_sem I ((the (snd (usubstappp \<sigma> U \<alpha>)))^d) X) = (\<nu> \<in> game_sem (USubst.adjoint \<sigma> I \<omega>) (\<alpha>^d) X)\<close> by force
     qed 
 
   next
     case (ODE \<sigma> U x \<theta>)
     then have va: "Uvariation \<nu> \<omega> U" by simp
     from ODE have subdef: "usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta> \<noteq> undeft" by (simp add: ODEo_undef) 
     from ODE have IH: "term_sem I (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)) \<nu> = term_sem (adjoint \<sigma> I \<omega>) \<theta> \<nu>" using va
       by (metis ODEo_undef fst_pair snd_conv usubst_taboos_mon usubst_term usubstappp.simps(8) usubstappt_antimon) 
     have "(\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (ODE x \<theta>)))) X) = (\<nu> \<in> game_sem I (the (ODEo x (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>))) X)" by simp
     also have "... = (\<nu> \<in> game_sem I (ODE x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>))) X)" using subdef by force
     also have "... = (\<exists>F T. Vagree \<nu> (F(0)) (-{DVar x}) \<and> F(T) \<in> X \<and> solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)))" by simp
     also have "... = (\<exists>F T. Uvariation \<nu> (F(0)) {DVar x} \<and> F(T) \<in> X \<and> solves_ODE I F x (the (usubstappt \<sigma> (U\<union>{RVar x,DVar x}) \<theta>)))" using Uvariation_Vagree by (metis double_compl) 
     also have "... = (\<exists>F T. Uvariation \<nu> (F(0)) {DVar x} \<and> F(T) \<in> X \<and> solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta>)" 
       using usubst_ode_ext2[OF subdef] va solves_Vagree_trans Uvariation_trans Uvariation_sym_rel Uvariation_mon by (meson subset_insertI)
     also have "... = (\<exists>F T. Vagree \<nu> (F(0)) (-{DVar x}) \<and> F(T) \<in> X \<and> solves_ODE (adjoint \<sigma> I \<omega>) F x \<theta>)" using Uvariation_Vagree by (metis double_compl) 
     also have "... = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (ODE x \<theta>) X)" using solves_ODE_def by simp
     finally show "(\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U (ODE x \<theta>)))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) (ODE x \<theta>) X)" .
   qed
 qed
 
 text \<open>Lemma 16 of \<^url>\<open>http://arxiv.org/abs/1902.07230\<close>\<close>
 theorem usubst_fml: "Uvariation \<nu> \<omega> U \<Longrightarrow> usubstappf \<sigma> U \<phi> \<noteq> undeff \<Longrightarrow>
     (\<nu> \<in> fml_sem I (the (usubstappf \<sigma> U \<phi>))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)"
   using usubst_fml_game by simp
 
 text \<open>Lemma 17 of \<^url>\<open>http://arxiv.org/abs/1902.07230\<close>\<close>
 theorem usubst_game: "Uvariation \<nu> \<omega> U \<Longrightarrow> snd (usubstappp \<sigma> U \<alpha>) \<noteq> undefg \<Longrightarrow>
     (\<nu> \<in> game_sem I (the (snd (usubstappp \<sigma> U \<alpha>))) X) = (\<nu> \<in> game_sem (adjoint \<sigma> I \<omega>) \<alpha> X)"
   using usubst_fml_game by simp
 
 
 subsection \<open>Soundness of Uniform Substitution of Formulas\<close>
 
 abbreviation usubsta:: "usubst \<Rightarrow> fml \<Rightarrow> fmlo"
   where "usubsta \<sigma> \<phi> \<equiv> usubstappf \<sigma> {} \<phi>"
 
 
 text \<open>Theorem 18 of \<^url>\<open>http://arxiv.org/abs/1902.07230\<close>\<close>
 theorem usubst_sound: "usubsta \<sigma> \<phi> \<noteq> undeff \<Longrightarrow> valid \<phi> \<Longrightarrow> valid (the (usubsta \<sigma> \<phi>))"
 proof-
   assume def: "usubsta \<sigma> \<phi> \<noteq> undeff"
   assume prem: "valid \<phi>"
   from prem have premc: "\<And>I \<omega>. \<omega> \<in> fml_sem I \<phi>" using valid_def by auto
   show "valid (the (usubsta \<sigma> \<phi>))" unfolding valid_def
   proof (clarify)
     fix I \<omega>
     have "(\<omega> \<in> fml_sem I (the (usubsta \<sigma> \<phi>))) = (\<omega> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)" using usubst_fml by (simp add: usubst_fml def)
     also have "... = True" using premc by simp
     finally have "(\<omega> \<in> fml_sem I (the (usubsta \<sigma> \<phi>))) = True" .
     from this show "\<omega> \<in> fml_sem I (the (usubstappf \<sigma> {} \<phi>))" by simp
   qed
 qed
 
 subsection \<open>Soundness of Uniform Substitution of Rules\<close>
 
 text \<open>Uniform Substitution applied to a rule or inference\<close>
 definition usubstr:: "usubst \<Rightarrow> inference \<Rightarrow> inference option"
   where "usubstr \<sigma> R \<equiv> if (usubstappf \<sigma> allvars (snd R) \<noteq> undeff \<and> (\<forall>\<phi>\<in>set (fst R). usubstappf \<sigma> allvars \<phi> \<noteq> undeff)) then
     Some(map(the o (usubstappf \<sigma> allvars))(fst R), the (usubstappf \<sigma> allvars (snd R)))
   else
     None"
 
 text \<open>Simple observations about applying uniform substitutions to a rule\<close>
 
 lemma usubstr_conv: "usubstr \<sigma> R \<noteq> None \<Longrightarrow>
   usubstappf \<sigma> allvars (snd R) \<noteq> undeff \<and>
   (\<forall>\<phi>\<in>set (fst R). usubstappf \<sigma> allvars \<phi> \<noteq> undeff)"
   by (metis usubstr_def)
 
 lemma usubstr_union_undef: "(usubstr \<sigma> ((append A B), C) \<noteq> None) = (usubstr \<sigma> (A, C) \<noteq> None \<and> usubstr \<sigma> (B, C) \<noteq> None)"
   using usubstr_def by auto
 lemma usubstr_union_undef2: "(usubstr \<sigma> ((append A B), C) \<noteq> None) \<Longrightarrow> (usubstr \<sigma> (A, C) \<noteq> None \<and> usubstr \<sigma> (B, C) \<noteq> None)"
   using usubstr_union_undef by blast
 
 lemma usubstr_cons_undef: "(usubstr \<sigma> ((Cons A B), C) \<noteq> None) = (usubstr \<sigma> ([A], C) \<noteq> None \<and> usubstr \<sigma> (B, C) \<noteq> None)"
   using usubstr_def by auto
 lemma usubstr_cons_undef2: "(usubstr \<sigma> ((Cons A B), C) \<noteq> None) \<Longrightarrow> (usubstr \<sigma> ([A], C) \<noteq> None \<and> usubstr \<sigma> (B, C) \<noteq> None)"
   using usubstr_cons_undef by blast
 
 lemma usubstr_cons: "(usubstr \<sigma> ((Cons A B), C) \<noteq> None) \<Longrightarrow>
   the (usubstr \<sigma> ((Cons A B), C)) = (Cons (the (usubstappf \<sigma> allvars A)) (fst (the (usubstr \<sigma> (B, C)))), snd (the (usubstr \<sigma> ([A], C))))"
   using usubstr_union_undef map_cons usubstr_def
 proof-
   assume def: "(usubstr \<sigma> ((Cons A B), C) \<noteq> None)"
   let ?R = "((Cons A B), C)"
   have "the (usubstr \<sigma> ?R) = (map(the o (usubstappf \<sigma> allvars))(fst ?R) , the (usubstappf \<sigma> allvars (snd ?R)))" using def usubstr_def by (metis option.sel)
   also have "... = (Cons (the (usubstappf \<sigma> allvars A)) (map(the o (usubstappf \<sigma> allvars))(B)) , the (usubstappf \<sigma> allvars (snd ?R)))" using map_cons by auto 
   also have "... = (Cons (the (usubstappf \<sigma> allvars A)) (fst (the (usubstr \<sigma> (B, C)))) , the (usubstappf \<sigma> allvars (snd ?R)))" using usubstr_cons_undef2[OF def] usubstr_def by (metis (no_types, lifting) fst_conv option.sel) 
   also have "... = (Cons (the (usubstappf \<sigma> allvars A)) (fst (the (usubstr \<sigma> (B, C)))) , snd (the (usubstr \<sigma> ([A], C))))" using def usubstr_def by auto
   ultimately show "the (usubstr \<sigma> ((Cons A B), C)) = (Cons (the (usubstappf \<sigma> allvars A)) (fst (the (usubstr \<sigma> (B, C)))) , snd (the (usubstr \<sigma> ([A], C))))" by simp
 qed
 
 lemma usubstr_union: "(usubstr \<sigma> ((append A B), C) \<noteq> None) \<Longrightarrow>
   the (usubstr \<sigma> ((append A B), C)) = (append (fst (the (usubstr \<sigma> (A, C)))) (fst (the (usubstr \<sigma> (B, C)))), snd (the (usubstr \<sigma> (A, C))))"
   using usubstr_union_undef2
     (*by (smt fst_pair map_append option.sel snd_pair usubstr_def)*)
 proof-
   assume def: "(usubstr \<sigma> ((append A B), C) \<noteq> None)"  
   let ?R = "((append A B), C)"
   have "the (usubstr \<sigma> ?R) = (map(the o (usubstappf \<sigma> allvars))(fst ?R) , the (usubstappf \<sigma> allvars (snd ?R)))" using def usubstr_def by (metis option.sel)
   also have "... = (map(the o (usubstappf \<sigma> allvars))(fst ?R) , snd (the (usubstr \<sigma> (A, C))))" using usubstr_union_undef2[OF def] usubstr_def by (metis option.sel sndI) 
   also have "... = (append (map(the o (usubstappf \<sigma> allvars))(A)) (map(the o (usubstappf \<sigma> allvars))(B)) , snd (the (usubstr \<sigma> (A, C))))" using usubstr_union_undef2[OF def] map_append by simp
   also have "... = (append (fst (the (usubstr \<sigma> (A, C)))) (fst (the (usubstr \<sigma> (B, C)))), snd (the (usubstr \<sigma> (A, C))))" using usubstr_union_undef2[OF def] usubstr_def by (metis (no_types, lifting) fst_conv option.sel) 
   ultimately show "the (usubstr \<sigma> ((append A B), C)) = (append (fst (the (usubstr \<sigma> (A, C)))) (fst (the (usubstr \<sigma> (B, C)))), snd (the (usubstr \<sigma> (A, C))))" by simp
 qed
 
 lemma usubstr_length: "usubstr \<sigma> R \<noteq> None \<Longrightarrow> length (fst (the (usubstr \<sigma> R))) = length (fst R)"
   by (metis fst_pair length_map option.sel usubstr_def)
 
 lemma usubstr_nth: "usubstr \<sigma> R \<noteq> None \<Longrightarrow> 0\<le>k \<Longrightarrow> k<length (fst R) \<Longrightarrow>
    nth (fst (the (usubstr \<sigma> R))) k = the (usubstappf \<sigma> allvars (nth (fst R) k))"
   (*unfolding usubstr_def using usubstr_length
   by (smt comp_apply fst_pair nth_map option.sel)*)
 proof-
   assume a1: "usubstr \<sigma> R \<noteq> None"
   assume a2: "0\<le>k"
   assume a3: "k<length (fst R)"  
   show "nth (fst (the (usubstr \<sigma> R))) k = the (usubstappf \<sigma> allvars (nth (fst R) k))"
     using a1 a2 a3 proof (induction R arbitrary: k)
     case (Pair A C)
     then show ?case
     proof (induction A arbitrary: k)
       case Nil
       then show ?case by simp 
     next
       case (Cons D E)
       then have IH: "\<And>k. usubstr \<sigma> (E, C) \<noteq> None \<Longrightarrow> 0 \<le> k \<Longrightarrow> k < length E \<Longrightarrow> nth (fst (the (usubstr \<sigma> (E, C)))) k = the (usubstappf \<sigma> allvars (nth E k))" by simp
       then show ?case
       proof (cases k)
         case 0
         then show ?thesis using Cons usubstr_cons by simp
       next
         case (Suc n)
         then have smaller: "n<length E" using Cons.prems(3) by auto 
         have nati: "0\<le>n" by simp
         have def: "usubstr \<sigma> (E, C) \<noteq> None" using usubstr_cons_undef2[OF Cons.prems(1)] by blast
         have "nth (fst (the (usubstr \<sigma> (E, C)))) n = the (usubstappf \<sigma> allvars (nth (fst (E,C)) n))" using IH[OF def, OF nati, OF smaller] by simp
         then show ?thesis using Cons usubstr_cons by (simp add: Suc) 
       qed
     qed
   qed
 qed
 
 text \<open>Theorem 19 of \<^url>\<open>http://arxiv.org/abs/1902.07230\<close>\<close>
 
 theorem usubst_rule_sound: "usubstr \<sigma> R \<noteq> None \<Longrightarrow> locally_sound R \<Longrightarrow> locally_sound (the (usubstr \<sigma> R))"
 proof-
   assume def: "usubstr \<sigma> R \<noteq> None"
   assume prem: "locally_sound R"
   let ?\<sigma>D = "usubstr \<sigma> R"
   fix \<omega>
   from usubst_fml have substeq: "\<And>I \<nu> \<phi>. usubstappf \<sigma> allvars \<phi> \<noteq> undeff \<Longrightarrow> (\<nu> \<in> fml_sem I (the (usubstappf \<sigma> allvars \<phi>))) = (\<nu> \<in> fml_sem (adjoint \<sigma> I \<omega>) \<phi>)" using Uvariation_univ by blast
   then have substval: "\<And>I. usubstappf \<sigma> allvars \<phi> \<noteq> undeff \<Longrightarrow> valid_in I (the (usubstappf \<sigma> allvars \<phi>)) = valid_in (adjoint \<sigma> I \<omega>) \<phi>" unfolding valid_in_def by auto
   show "locally_sound (the (usubstr \<sigma> R))" unfolding locally_sound_def
   proof (clarify)
     fix I
     assume "\<forall>k\<ge>0. k < length (fst (the (usubstr \<sigma> R))) \<longrightarrow> valid_in I (nth (fst (the (usubstr \<sigma> R))) k)"
     then have "\<forall>k\<ge>0. k < length (fst R) \<longrightarrow> valid_in (adjoint \<sigma> I \<omega>) (nth (fst R) k)" using substval usubstr_nth usubstr_length substeq valid_in_def by (metis def nth_mem usubstr_def)
     then have "valid_in (adjoint \<sigma> I \<omega>) (snd R)" using prem unfolding locally_sound_def by simp
     from this show "valid_in I (snd (the (usubstr \<sigma> R)))" using usubst_fml substeq usubstr_def valid_in_def by (metis def option.sel snd_conv)
   qed
 qed
 
 end
diff --git a/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite.thy b/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite.thy
--- a/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite.thy
+++ b/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite.thy
@@ -1,3014 +1,3014 @@
 section \<open>Test Suites\<close>
 
 text \<open>This theory introduces a predicate @{text "implies_completeness"} and proves that
       any test suite satisfying this predicate is sufficient to check the reduction conformance
       relation between two (possibly nondeterministic FSMs)\<close> 
 
 
 theory Test_Suite
 imports Helper_Algorithms Adaptive_Test_Case Traversal_Set 
 begin
 
 subsection \<open>Preliminary Definitions\<close>
 
 
 type_synonym ('a,'b,'c) preamble = "('a,'b,'c) fsm"
 type_synonym ('a,'b,'c) traversal_path = "('a \<times> 'b \<times> 'c \<times> 'a) list"
 type_synonym ('a,'b,'c) separator = "('a,'b,'c) fsm"
 
 text \<open>A test suite contains of
         1) a set of d-reachable states with their associated preambles
         2) a map from d-reachable states to their associated m-traversal paths 
         3) a map from d-reachable states and associated m-traversal paths to the set of states to r-distinguish the targets of those paths from
         4) a map from pairs of r-distinguishable states to a separator\<close>
 datatype ('a,'b,'c,'d) test_suite = Test_Suite "('a \<times> ('a,'b,'c) preamble) set"   
                                                "'a \<Rightarrow> ('a,'b,'c) traversal_path set" 
                                                "('a \<times> ('a,'b,'c) traversal_path) \<Rightarrow> 'a set" 
                                                "('a \<times> 'a) \<Rightarrow> (('d,'b,'c) separator \<times> 'd \<times> 'd) set"
 
 
 
 
 subsection \<open>A Sufficiency Criterion for Reduction Testing\<close>
 
 (* to simplify the soundness proof, this formalisation also requires tps to contain nothing but the m-traversal paths;
    this could be lifted by requiring that for every additional path the suite retains additional paths such that all "non-deadlock"
    (w.r.t. the set of all (tps q) paths) states are output complete for the inputs applied *)  
 
 fun implies_completeness_for_repetition_sets :: "('a,'b,'c,'d) test_suite \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> nat \<Rightarrow> ('a set \<times> 'a set) list \<Rightarrow> bool" where
   "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets separators) M m repetition_sets = 
     ( (initial M,initial_preamble M) \<in> prs 
     \<and> (\<forall> q P . (q,P) \<in> prs \<longrightarrow> (is_preamble P M q) \<and> (tps q) \<noteq> {})
     \<and> (\<forall> q1 q2 A d1 d2 . (A,d1,d2) \<in> separators (q1,q2) \<longrightarrow> (A,d2,d1) \<in> separators (q2,q1) \<and> is_separator M q1 q2 A d1 d2)
     \<and> (\<forall> q . q \<in> states M \<longrightarrow> (\<exists>d \<in> set repetition_sets. q \<in> fst d))
     \<and> (\<forall> d . d \<in> set repetition_sets \<longrightarrow> ((fst d \<subseteq> states M) \<and> (snd d = fst d \<inter> fst ` prs) \<and> (\<forall> q1 q2 . q1 \<in> fst d \<longrightarrow> q2 \<in> fst d \<longrightarrow> q1 \<noteq> q2 \<longrightarrow> separators (q1,q2) \<noteq> {})))
     \<and> (\<forall> q . q \<in> image fst prs \<longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q) 
     \<and> (\<forall> q p d . q \<in> image fst prs \<longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<longrightarrow> 
           ( (\<forall> p1 p2 p3 . p=p1@p2@p3 \<longrightarrow> p2 \<noteq> [] \<longrightarrow> target q p1 \<in> fst d \<longrightarrow> target q (p1@p2) \<in> fst d \<longrightarrow> target q p1 \<noteq> target q (p1@p2) \<longrightarrow> (p1 \<in> tps q \<and> (p1@p2) \<in> tps q \<and> target q p1 \<in> rd_targets (q,(p1@p2)) \<and> target q (p1@p2) \<in> rd_targets (q,p1)))
           \<and> (\<forall> p1 p2 q' . p=p1@p2 \<longrightarrow> q' \<in> image fst prs \<longrightarrow> target q p1 \<in> fst d \<longrightarrow> q' \<in> fst d \<longrightarrow> target q p1 \<noteq> q' \<longrightarrow> (p1 \<in> tps q \<and> [] \<in> tps q' \<and> target q p1 \<in> rd_targets (q',[]) \<and> q' \<in> rd_targets (q,p1))))
           \<and> (\<forall> q1 q2 . q1 \<noteq> q2 \<longrightarrow> q1 \<in> snd d \<longrightarrow> q2 \<in> snd d \<longrightarrow> ([] \<in> tps q1 \<and> [] \<in> tps q2 \<and> q1 \<in> rd_targets (q2,[]) \<and> q2 \<in> rd_targets (q1,[]))))
   )"
 
 definition implies_completeness :: "('a,'b,'c,'d) test_suite \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> nat \<Rightarrow> bool" where
   "implies_completeness T M m = (\<exists> repetition_sets . implies_completeness_for_repetition_sets T M m repetition_sets)"
 
 
 
 lemma implies_completeness_for_repetition_sets_simps : 
   assumes "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets separators) M m repetition_sets"
   shows "(initial M,initial_preamble M) \<in> prs" 
     and "\<And> q P . (q,P) \<in> prs \<Longrightarrow> (is_preamble P M q) \<and> (tps q) \<noteq> {}"
     and "\<And> q1 q2 A d1 d2 . (A,d1,d2) \<in> separators (q1,q2) \<Longrightarrow> (A,d2,d1) \<in> separators (q2,q1) \<and> is_separator M q1 q2 A d1 d2"
     and "\<And> q . q \<in> states M \<Longrightarrow> (\<exists>d \<in> set repetition_sets. q \<in> fst d)"
     and "\<And> d . d \<in> set repetition_sets \<Longrightarrow> (fst d \<subseteq> states M) \<and> (snd d = fst d \<inter> fst ` prs)"
     and "\<And> d q1 q2 . d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> separators (q1,q2) \<noteq> {}"
     and "\<And> q . q \<in> image fst prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q" 
     and "\<And> q p d p1 p2 p3 . q \<in> image fst prs \<Longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow> p=p1@p2@p3 \<Longrightarrow> p2 \<noteq> [] \<Longrightarrow> target q p1 \<in> fst d \<Longrightarrow> target q (p1@p2) \<in> fst d \<Longrightarrow> target q p1 \<noteq> target q (p1@p2) \<Longrightarrow> (p1 \<in> tps q \<and> (p1@p2) \<in> tps q \<and> target q p1 \<in> rd_targets (q,(p1@p2)) \<and> target q (p1@p2) \<in> rd_targets (q,p1))"
     and "\<And> q p d p1 p2 q' . q \<in> image fst prs \<Longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow> p=p1@p2 \<Longrightarrow> q' \<in> image fst prs \<Longrightarrow> target q p1 \<in> fst d \<Longrightarrow> q' \<in> fst d \<Longrightarrow> target q p1 \<noteq> q' \<Longrightarrow> (p1 \<in> tps q \<and> [] \<in> tps q' \<and> target q p1 \<in> rd_targets (q',[]) \<and> q' \<in> rd_targets (q,p1))"
     and "\<And> q p d q1 q2 . q \<in> image fst prs \<Longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> q1 \<in> snd d \<Longrightarrow> q2 \<in> snd d \<Longrightarrow> ([] \<in> tps q1 \<and> [] \<in> tps q2 \<and> q1 \<in> rd_targets (q2,[]) \<and> q2 \<in> rd_targets (q1,[]))"
 proof-
 
   show "(initial M,initial_preamble M) \<in> prs" 
   and  "\<And> q . q \<in> image fst prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using assms unfolding implies_completeness_for_repetition_sets.simps by blast+
 
   show "\<And> q1 q2 A d1 d2 . (A,d1,d2) \<in> separators (q1,q2) \<Longrightarrow> (A,d2,d1) \<in> separators (q2,q1) \<and> is_separator M q1 q2 A d1 d2"
   and  "\<And> q P . (q,P) \<in> prs \<Longrightarrow> (is_preamble P M q) \<and> (tps q) \<noteq> {}"
   and  "\<And> q . q \<in> states M \<Longrightarrow> (\<exists>d \<in> set repetition_sets. q \<in> fst d)"
   and  "\<And> d . d \<in> set repetition_sets \<Longrightarrow> (fst d \<subseteq> states M) \<and> (snd d = fst d \<inter> fst ` prs)"
   and  "\<And> d q1 q2 . d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> separators (q1,q2) \<noteq> {}"
     using assms unfolding implies_completeness_for_repetition_sets.simps by force+
 
   show "\<And> q p d p1 p2 p3 . q \<in> image fst prs \<Longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow> p=p1@p2@p3 \<Longrightarrow> p2 \<noteq> [] \<Longrightarrow> target q p1 \<in> fst d \<Longrightarrow> target q (p1@p2) \<in> fst d \<Longrightarrow> target q p1 \<noteq> target q (p1@p2) \<Longrightarrow> (p1 \<in> tps q \<and> (p1@p2) \<in> tps q \<and> target q p1 \<in> rd_targets (q,(p1@p2)) \<and> target q (p1@p2) \<in> rd_targets (q,p1))"
     using assms unfolding implies_completeness_for_repetition_sets.simps by (metis (no_types, lifting))
 
   show "\<And> q p d p1 p2 q' . q \<in> image fst prs \<Longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow> p=p1@p2 \<Longrightarrow> q' \<in> image fst prs \<Longrightarrow> target q p1 \<in> fst d \<Longrightarrow> q' \<in> fst d \<Longrightarrow> target q p1 \<noteq> q' \<Longrightarrow> (p1 \<in> tps q \<and> [] \<in> tps q' \<and> target q p1 \<in> rd_targets (q',[]) \<and> q' \<in> rd_targets (q,p1))"
     using assms unfolding implies_completeness_for_repetition_sets.simps by (metis (no_types, lifting))
 
   show "\<And> q p d q1 q2 . q \<in> image fst prs \<Longrightarrow> (p,d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> q1 \<in> snd d \<Longrightarrow> q2 \<in> snd d \<Longrightarrow> ([] \<in> tps q1 \<and> [] \<in> tps q2 \<and> q1 \<in> rd_targets (q2,[]) \<and> q2 \<in> rd_targets (q1,[]))"
     using assms unfolding implies_completeness_for_repetition_sets.simps by (metis (no_types, lifting))
 qed
 
 
 
 
 subsection \<open>A Pass Relation for Test Suites and Reduction Testing\<close>
 
 fun passes_test_suite :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c,'d) test_suite \<Rightarrow> ('e,'b,'c) fsm \<Rightarrow> bool" where
   "passes_test_suite M (Test_Suite prs tps rd_targets separators) M' = (
     \<comment> \<open>Reduction on preambles: as the preambles contain all responses of M to their chosen inputs, M' must not exhibit any other response\<close>
     (\<forall> q P io x y y' . (q,P) \<in> prs \<longrightarrow> io@[(x,y)] \<in> L P \<longrightarrow> io@[(x,y')] \<in> L M' \<longrightarrow> io@[(x,y')] \<in> L P) 
     \<comment> \<open>Reduction on traversal-paths applied after preambles (i.e., completed paths in preambles) - note that tps q is not necessarily prefix-complete\<close>
     \<and> (\<forall> q P pP ioT pT x y y' . (q,P) \<in> prs \<longrightarrow> path P (initial P) pP \<longrightarrow> target (initial P) pP = q \<longrightarrow> pT \<in> tps q \<longrightarrow> ioT@[(x,y)] \<in> set (prefixes (p_io pT)) \<longrightarrow> (p_io pP)@ioT@[(x,y')] \<in> L M' \<longrightarrow> (\<exists> pT' . pT' \<in> tps q \<and> ioT@[(x,y')] \<in> set (prefixes (p_io pT'))))
     \<comment> \<open>Passing separators: if M' contains an IO-sequence that in the test suite leads through a preamble and an m-traversal path and the target of the latter is to be r-distinguished from some other state, then M' passes the corresponding ATC\<close>
     \<and> (\<forall> q P pP pT . (q,P) \<in> prs \<longrightarrow> path P (initial P) pP \<longrightarrow> target (initial P) pP = q \<longrightarrow> pT \<in> tps q \<longrightarrow> (p_io pP)@(p_io pT) \<in> L M' \<longrightarrow> (\<forall> q' A d1 d2 qT . q' \<in> rd_targets (q,pT) \<longrightarrow> (A,d1,d2) \<in> separators (target q pT, q') \<longrightarrow> qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M') \<longrightarrow> pass_separator_ATC M' A qT d2))
     )"                                                                                                                                                                                                                                                                                                   
 
 
 
 
 
 subsection \<open>Soundness of Sufficient Test Suites\<close>
 
 
 lemma passes_test_suite_soundness_helper_1 :
   assumes "is_preamble P M q"
   and     "observable M"
   and     "io@[(x,y)] \<in> L P"
   and     "io@[(x,y')] \<in> L M"
 shows     "io@[(x,y')] \<in> L P"
 proof -
   have   "is_submachine P M"
   and *: "\<And> q' x t t' . q'\<in>reachable_states P \<Longrightarrow> x\<in>FSM.inputs M \<Longrightarrow>
             t\<in>FSM.transitions P \<Longrightarrow> t_source t = q' \<Longrightarrow> t_input t = x \<Longrightarrow>
             t'\<in>FSM.transitions M \<Longrightarrow> t_source t' = q' \<Longrightarrow> t_input t' = x \<Longrightarrow> t' \<in> FSM.transitions P"
     using assms(1)  unfolding is_preamble_def by blast+
 
   have "initial P = initial M"
     unfolding submachine_simps[OF \<open>is_submachine P M\<close>]
     by simp
   
   obtain p where "path M (initial M) p" and "p_io p = io @ [(x,y')]"
     using assms(4) unfolding submachine_simps[OF \<open>is_submachine P M\<close>] by auto
   
   obtain p' t where "p = p'@[t]"
     using \<open>p_io p = io @ [(x,y')]\<close> by (induction p rule: rev_induct; auto)
 
   have "path M (initial M) p'" and "t \<in> transitions M" and "t_source t = target (initial M) p'"
     using \<open>path M (initial M) p\<close> path_append_transition_elim
     unfolding \<open>p = p'@[t]\<close> by force+
 
   have "p_io p' = io" and "t_input t = x" and "t_output t = y'"
     using \<open>p_io p = io @ [(x,y')]\<close> unfolding \<open>p = p'@[t]\<close> by force+
      
 
   have "p_io p' \<in> LS P (FSM.initial M)"
     using assms(3) unfolding \<open>p_io p' = io\<close> \<open>initial P = initial M\<close>
     by (meson language_prefix) 
 
   have "FSM.initial M \<in> reachable_states P"
     unfolding submachine_simps(1)[OF \<open>is_submachine P M\<close>, symmetric]
     using reachable_states_initial by blast
   
   obtain pp where "path P (initial P) pp" and "p_io pp = io @ [(x,y)]"
     using assms(3) by auto
   then obtain pp' t' where "pp = pp'@[t']"
   proof -
     assume a1: "\<And>pp' t'. pp = pp' @ [t'] \<Longrightarrow> thesis"
     have "pp \<noteq> []"
       using \<open>p_io pp = io @ [(x, y)]\<close> by auto
     then show ?thesis
       using a1 by (metis (no_types) rev_exhaust)
   qed 
 
   have "path P (initial P) pp'" and "t' \<in> transitions P" and "t_source t' = target (initial P) pp'"
     using \<open>path P (initial P) pp\<close> path_append_transition_elim
     unfolding \<open>pp = pp'@[t']\<close> by force+
   have "p_io pp' = io" and "t_input t' = x"
     using \<open>p_io pp = io @ [(x,y)]\<close> unfolding \<open>pp = pp'@[t']\<close> by force+
 
   have "path M (initial M) pp'"
     using \<open>path P (initial P) pp'\<close> submachine_path_initial[OF \<open>is_submachine P M\<close>] by blast
   
   have "pp' = p'"
     using observable_path_unique[OF assms(2) \<open>path M (initial M) pp'\<close> \<open>path M (initial M) p'\<close> ]
     unfolding \<open>p_io pp' = io\<close> \<open>p_io p' = io\<close>
     by blast
   then have "t_source t' = target (initial M) p'"
     using \<open>t_source t' = target (initial P) pp'\<close> unfolding \<open>initial P = initial M\<close> by blast
 
 
   have "path P (FSM.initial M) p'"
     using observable_preamble_paths[OF assms(1,2) \<open>path M (initial M) p'\<close> 
                                                   \<open>p_io p' \<in> LS P (FSM.initial M)\<close> 
                                                   \<open>FSM.initial M \<in> reachable_states P\<close>]
     by assumption
   then have "target (initial M) p' \<in> reachable_states P"
     using reachable_states_intro unfolding \<open>initial P = initial M\<close>[symmetric] by blast
   moreover have "x \<in> inputs M"
     using \<open>t \<in> transitions M\<close> \<open>t_input t = x\<close> fsm_transition_input by blast
 
 
   have "t \<in> transitions P"
     using *[OF \<open>target (initial M) p' \<in> reachable_states P\<close> \<open>x \<in> inputs M\<close> \<open>t' \<in> transitions P\<close> 
                \<open>t_source t' = target (initial M) p'\<close> \<open>t_input t' = x\<close> \<open>t \<in> transitions M\<close> 
                \<open>t_source t = target (FSM.initial M) p'\<close> \<open>t_input t = x\<close>]
     by assumption
 
   then have "path P (initial P) (p'@[t])"
     using \<open>path P (initial P) pp'\<close> \<open>t_source t = target (initial M) p'\<close>
     unfolding \<open>pp' = p'\<close> \<open>initial P = initial M\<close> 
     using path_append_transition by simp
   then show ?thesis 
     unfolding \<open>p = p'@[t]\<close>[symmetric] LS.simps
     using \<open>p_io p = io@[(x,y')]\<close>
     by force
 qed
 
 
 
 lemma passes_test_suite_soundness :
   assumes "implies_completeness (Test_Suite prs tps rd_targets separators) M m"
   and     "observable M"
   and     "observable M'"
   and     "inputs M' = inputs M"
   and     "completely_specified M"
   and     "L M' \<subseteq> L M"
 shows     "passes_test_suite M (Test_Suite prs tps rd_targets separators) M'"
 proof -
   obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets separators) M m repetition_sets"
     using assms(1) unfolding implies_completeness_def by blast
 
 
   have t1: "(initial M, initial_preamble M) \<in> prs" 
     using implies_completeness_for_repetition_sets_simps(1)[OF repetition_sets_def] by assumption
   have t2: "\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q \<and> tps q \<noteq> {}"
     using implies_completeness_for_repetition_sets_simps(2)[OF repetition_sets_def] by assumption
   have t3: "\<And> q1 q2 A d1 d2. (A, d1, d2) \<in> separators (q1, q2) \<Longrightarrow> (A, d2, d1) \<in> separators (q2, q1) \<and> is_separator M q1 q2 A d1 d2"
     using implies_completeness_for_repetition_sets_simps(3)[OF repetition_sets_def] by assumption
   
   have t5: "\<And>q. q \<in> FSM.states M \<Longrightarrow> (\<exists>d\<in>set repetition_sets. q \<in> fst d)"
     using implies_completeness_for_repetition_sets_simps(4)[OF repetition_sets_def] by assumption
 
   have t6: "\<And> q. q \<in> fst ` prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} 
                                                             \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using implies_completeness_for_repetition_sets_simps(7)[OF repetition_sets_def] by assumption
 
   have t7: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> fst d \<subseteq> FSM.states M"
   and  t8: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d \<subseteq> fst d"
   and  t9: "\<And> d q1 q2. d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> separators (q1, q2) \<noteq> {}"
     using implies_completeness_for_repetition_sets_simps(5,6)[OF repetition_sets_def] 
     by blast+
 
   have t10: "\<And> q p d p1 p2 p3.
               q \<in> fst ` prs \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               p = p1 @ p2 @ p3 \<Longrightarrow>
               p2 \<noteq> [] \<Longrightarrow>
               target q p1 \<in> fst d \<Longrightarrow>
               target q (p1 @ p2) \<in> fst d \<Longrightarrow>
               target q p1 \<noteq> target q (p1 @ p2) \<Longrightarrow>
               p1 \<in> tps q \<and> p1 @ p2 \<in> tps q \<and> target q p1 \<in> rd_targets (q, p1 @ p2) \<and> target q (p1 @ p2) \<in> rd_targets (q, p1)"
     using implies_completeness_for_repetition_sets_simps(8)[OF repetition_sets_def] by assumption
 
   have t11: "\<And> q p d p1 p2 q'.
               q \<in> fst ` prs \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               p = p1 @ p2 \<Longrightarrow>
               q' \<in> fst ` prs \<Longrightarrow>
               target q p1 \<in> fst d \<Longrightarrow>
               q' \<in> fst d \<Longrightarrow> 
               target q p1 \<noteq> q' \<Longrightarrow> 
               p1 \<in> tps q \<and> [] \<in> tps q' \<and> target q p1 \<in> rd_targets (q', []) \<and> q' \<in> rd_targets (q, p1)"
     using implies_completeness_for_repetition_sets_simps(9)[OF repetition_sets_def] by assumption
 
 
   have "\<And> q P io x y y' . (q,P) \<in> prs \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P"
   proof -
     fix q P io x y y' assume "(q,P) \<in> prs" and "io@[(x,y)] \<in> L P" and "io@[(x,y')] \<in> L M'"
 
     have "is_preamble P M q"
       using \<open>(q,P) \<in> prs\<close> \<open>\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q \<and> tps q \<noteq> {}\<close> by blast
 
     have "io@[(x,y')] \<in> L M"
       using \<open>io@[(x,y')] \<in> L M'\<close> assms(6) by blast
 
     show "io@[(x,y')] \<in> L P"
       using passes_test_suite_soundness_helper_1[OF \<open>is_preamble P M q\<close> assms(2) \<open>io@[(x,y)] \<in> L P\<close> \<open>io@[(x,y')] \<in> L M\<close>]
       by assumption
   qed
   then have p1: "(\<forall> q P io x y y' . (q,P) \<in> prs \<longrightarrow> io@[(x,y)] \<in> L P \<longrightarrow> io@[(x,y')] \<in> L M' \<longrightarrow> io@[(x,y')] \<in> L P)"
     by blast
 
 
 
   have "\<And> q P pP ioT pT x x' y y' . (q,P) \<in> prs \<Longrightarrow> 
                                      path P (initial P) pP \<Longrightarrow> 
                                      target (initial P) pP = q \<Longrightarrow> 
                                      pT \<in> tps q \<Longrightarrow> 
                                      ioT @ [(x, y)] \<in> set (prefixes (p_io pT)) \<Longrightarrow> 
                                      (p_io pP)@ioT@[(x',y')] \<in> L M' \<Longrightarrow> 
                                      (\<exists> pT' . pT' \<in> tps q \<and> ioT @ [(x', y')] \<in> set (prefixes (p_io pT')))"
   proof -
     fix q P pP ioT pT x x' y y' 
     assume "(q,P) \<in> prs"  
        and "path P (initial P) pP" 
        and "target (initial P) pP = q" 
        and "pT \<in> tps q" 
        and "ioT @ [(x, y)] \<in> set (prefixes (p_io pT))" 
        and "(p_io pP)@ioT@[(x',y')] \<in> L M'"
 
     have "is_preamble P M q"
       using \<open>(q,P) \<in> prs\<close> \<open>\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q \<and> tps q \<noteq> {}\<close> by blast
     then have "q \<in> states M"
       unfolding is_preamble_def
       by (metis \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> path_target_is_state submachine_path) 
 
 
     have "initial P = initial M"
       using \<open>is_preamble P M q\<close> unfolding is_preamble_def by auto
     have "path M (initial M) pP"
       using \<open>is_preamble P M q\<close> unfolding is_preamble_def using submachine_path_initial
       using \<open>path P (FSM.initial P) pP\<close> by blast
     
 
     have "(p_io pP)@ioT@[(x',y')] \<in> L M"
       using \<open>(p_io pP)@ioT@[(x',y')] \<in> L M'\<close> assms(6) by blast
     then obtain pM' where "path M (initial M) pM'" and "p_io pM' = (p_io pP)@ioT@[(x',y')]" 
       by auto
 
     let ?pP = "take (length pP) pM'"
     let ?pT = "take (length ioT) (drop (length pP) pM')"
     let ?t  = "last pM'"
 
 
     have "pM' = ?pP @ ?pT @ [?t]"
     proof -
       have "length pM' = (length pP) + (length ioT) + 1"
         using \<open>p_io pM' = (p_io pP)@ioT@[(x',y')]\<close> 
         unfolding length_map[of "(\<lambda> t . (t_input t, t_output t))", of pM', symmetric] 
                   length_map[of "(\<lambda> t . (t_input t, t_output t))", of pP, symmetric] 
         by auto
       then show ?thesis
         by (metis (no_types, lifting) add_diff_cancel_right' antisym_conv antisym_conv2 
               append_butlast_last_id append_eq_append_conv2 butlast_conv_take drop_Nil drop_eq_Nil 
               le_add1 less_add_one take_add) 
     qed   
 
     have "p_io ?pP = p_io pP"  
       using \<open>p_io pM' = (p_io pP)@ioT@[(x',y')]\<close>
       by (metis (no_types, lifting) append_eq_conv_conj length_map take_map)
 
     have "p_io ?pT = ioT" 
       using \<open>p_io pM' = (p_io pP)@ioT@[(x',y')]\<close>
       using \<open>pM' = ?pP @ ?pT @ [?t]\<close>
       by (metis (no_types, lifting) append_eq_conv_conj length_map map_append take_map) 
       
     have "p_io [?t] = [(x',y')]"
       using \<open>p_io pM' = (p_io pP)@ioT@[(x',y')]\<close>
       using \<open>pM' = ?pP @ ?pT @ [?t]\<close>
       by (metis (no_types, lifting) append_is_Nil_conv last_appendR last_map last_snoc list.simps(8) list.simps(9))
 
     have "path M (initial M) ?pP"
       using \<open>path M (initial M) pM'\<close> \<open>pM' = ?pP @ ?pT @ [?t]\<close>
       by (meson path_prefix_take)
       
     have "?pP = pP"
       using observable_path_unique[OF \<open>observable M\<close> \<open>path M (initial M) ?pP\<close> \<open>path M (initial M) pP\<close> \<open>p_io ?pP = p_io pP\<close>]
       by assumption
     then have "path M q (?pT@[?t])"
       by (metis \<open>FSM.initial P = FSM.initial M\<close> \<open>pM' = take (length pP) pM' @ take (length ioT) (drop (length pP) pM') @ [last pM']\<close> \<open>path M (FSM.initial M) pM'\<close> \<open>target (FSM.initial P) pP = q\<close> path_suffix)
     then have "path M q ?pT" 
          and  "?t \<in> transitions M" 
          and  "t_source ?t = target q ?pT"
       by auto
 
     have "inputs M \<noteq> {}"
       using language_io(1)[OF \<open>(p_io pP)@ioT@[(x',y')] \<in> L M\<close>, of x' y']
       by auto 
 
     have "q \<in> fst ` prs"
       using \<open>(q,P) \<in> prs\<close>
       using image_iff by fastforce 
 
     obtain ioT' where "p_io pT = (ioT @ [(x, y)]) @ ioT'"
       using \<open>ioT @ [(x, y)] \<in> set (prefixes (p_io pT))\<close>
-      unfolding prefixes_set 
-      by moura
+      unfolding prefixes_set mem_Collect_eq by metis
     then have "length pT > length ioT"
       using length_map[of "(\<lambda> t . (t_input t, t_output t))" pT] 
       by auto
     
     obtain pT' d' where "(pT @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
       using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pT \<in> tps q\<close>
       by blast
 
     let ?p = "pT @ pT'"
 
     have "path M q ?p"
     and  "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)) repetition_sets = Some d'"
     and  "\<And> p' p''. ?p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
       using \<open>(pT @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m\<close>
             m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m] 
       by blast+
 
     let ?pIO = "take (length ioT) pT"
     have "?pIO = take (length ioT) ?p" 
       using \<open>length pT > length ioT\<close> by auto
     then have "?p = ?pIO@(drop (length ioT) ?p)"
       by auto
     have "(drop (length ioT) ?p) \<noteq> []" 
       using \<open>length pT > length ioT\<close> by auto
 
     have "p_io ?pIO = ioT" 
     proof -
       have "p_io ?pIO = take (length ioT) (p_io pT)"
         by (simp add: take_map)
       moreover have "take (length ioT) (p_io pT) = ioT"
         using \<open>p_io pT = (ioT @ [(x, y)]) @ ioT'\<close> by auto
       ultimately show ?thesis by simp
     qed
     then have "p_io ?pIO = p_io ?pT"
       using \<open>p_io ?pT = ioT\<close> by simp
     
     have "path M q ?pIO"
       using \<open>path M q ?p\<close> unfolding \<open>?pIO = take (length ioT) ?p\<close> 
       using path_prefix_take by metis
 
     have "?pT = ?pIO"
       using observable_path_unique[OF \<open>observable M\<close> \<open>path M q ?pIO\<close> \<open>path M q ?pT\<close> \<open>p_io ?pIO = p_io ?pT\<close>] 
       by simp
 
     show "(\<exists> pT' . pT' \<in> tps q \<and> ioT @ [(x', y')] \<in> set (prefixes (p_io pT')))"
     proof (cases "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (?pT@[?t]))) repetition_sets = None")
       case True
 
       obtain pT' d' where "(?pT @ [?t] @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
         using m_traversal_path_extension_exist[OF \<open>completely_specified M\<close> \<open>q \<in> states M\<close> \<open>inputs M \<noteq> {}\<close> t5 t8 \<open>path M q (?pT@[?t])\<close> True]
         by auto
       then have "?pT @ [?t] @ pT' \<in> tps q"
         using t6[OF \<open>q \<in> fst ` prs\<close>] by force
 
       moreover have "ioT @ [(x', y')] \<in> set (prefixes (p_io (?pT @ [?t] @ pT')))"
         using \<open>p_io ?pIO = ioT\<close> \<open>p_io [?t] = [(x',y')]\<close> 
         unfolding \<open>?pT = ?pIO\<close> prefixes_set by force
 
       ultimately show ?thesis 
         by blast
     next
       case False
       
       note \<open>path M q (?pT @ [?t])\<close> 
       moreover obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (?pT@[?t]))) repetition_sets = Some d'"
         using False by blast
 
       moreover have "\<forall> p' p''. (?pT @ [?t]) = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
       proof -
         have "\<And> p' p''. (?pT @ [?t]) = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
         proof -
           fix p' p'' assume "(?pT @ [?t]) = p' @ p''" and "p'' \<noteq> []" 
           then obtain pIO' where "?pIO = p' @ pIO'"
             unfolding \<open>?pT = ?pIO\<close>
             by (metis butlast_append butlast_snoc)
           then have "?p = p'@pIO'@(drop (length ioT) ?p)"
             using \<open>?p = ?pIO@((drop (length ioT) ?p))\<close>
             by (metis append.assoc) 
   
           have "pIO' @ drop (length ioT) (pT @ pT') \<noteq> []"
             using \<open>(drop (length ioT) ?p) \<noteq> []\<close> by auto
   
           show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
             using \<open>\<And> p' p''. ?p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None\<close>
                   [of p' "pIO'@(drop (length ioT) ?p)", OF \<open>?p = p'@pIO'@(drop (length ioT) ?p)\<close> \<open>pIO' @ drop (length ioT) (pT @ pT') \<noteq> []\<close>]
             by assumption
         qed
         then show ?thesis by blast
       qed
 
       ultimately have "((?pT @ [?t]),d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
         using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m] 
         by auto
       then have "(?pT @ [?t]) \<in> tps q"
         using t6[OF \<open>q \<in> fst ` prs\<close>] by force
       moreover have "ioT @ [(x', y')] \<in> set (prefixes (p_io (?pT @ [?t])))"
         using \<open>p_io ?pT = ioT\<close> \<open>p_io [?t] = [(x',y')]\<close>
         unfolding prefixes_set by force
 
       ultimately show ?thesis 
         by blast
     qed
   qed
   then have p2: "(\<forall> q P pP ioT pT x y y' . (q,P) \<in> prs \<longrightarrow> 
                                             path P (initial P) pP \<longrightarrow> 
                                             target (initial P) pP = q \<longrightarrow> 
                                             pT \<in> tps q \<longrightarrow> 
                                             ioT @ [(x, y)] \<in> set (prefixes (p_io pT)) \<longrightarrow> 
                                             (p_io pP)@ioT@[(x,y')] \<in> L M' \<longrightarrow> 
                                             (\<exists> pT' . pT' \<in> tps q \<and> ioT @ [(x, y')] \<in> set (prefixes (p_io pT'))))"
     by blast
 
 
   have "\<And> q P pP pT q' A d1 d2 qT . (q,P) \<in> prs \<Longrightarrow> 
                                       path P (initial P) pP \<Longrightarrow> 
                                       target (initial P) pP = q \<Longrightarrow> 
                                       pT \<in> tps q \<Longrightarrow> 
                                       q' \<in> rd_targets (q,pT) \<Longrightarrow> 
                                       (A,d1,d2) \<in> separators (target q pT, q') \<Longrightarrow> 
                                       qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M') \<Longrightarrow> 
                                       pass_separator_ATC M' A qT d2"
   proof -
     fix q P pP pT q' A d1 d2 qT
     assume "(q,P) \<in> prs" 
     and    "path P (initial P) pP" 
     and    "target (initial P) pP = q" 
     and    "pT \<in> tps q"  
     and    "q' \<in> rd_targets (q,pT)" 
     and    "(A,d1,d2) \<in> separators (target q pT, q')" 
     and    "qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M')"
 
     have "q \<in> fst ` prs"
       using \<open>(q,P) \<in> prs\<close> by force
     have "is_preamble P M q"
       using \<open>(q,P) \<in> prs\<close> \<open>\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q \<and> tps q \<noteq> {}\<close> by blast
     then have "q \<in> states M"
       unfolding is_preamble_def
       by (metis \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> path_target_is_state submachine_path) 
 
     have "initial P = initial M"
       using \<open>is_preamble P M q\<close> unfolding is_preamble_def by auto
     have "path M (initial M) pP"
       using \<open>is_preamble P M q\<close> unfolding is_preamble_def using submachine_path_initial
       using \<open>path P (FSM.initial P) pP\<close> by blast
 
     have "is_separator M (target q pT) q' A d1 d2"
       using t3[OF \<open>(A,d1,d2) \<in> separators (target q pT, q')\<close>]
       by blast
 
     have "qT \<in> states M'"
       using \<open>qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M')\<close>
             io_targets_states
       by (metis (no_types, lifting) subsetD) 
 
     obtain pT' d' where "(pT @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
       using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pT \<in> tps q\<close> 
       by blast
     then have "path M q pT"
       using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m] 
       by auto
     then have "target q pT \<in> FSM.states M"
       using path_target_is_state by metis
 
     have "q' \<in> FSM.states M"
       using is_separator_separated_state_is_state[OF \<open>is_separator M (target q pT) q' A d1 d2\<close>] by simp
 
     have "\<not> pass_separator_ATC M' A qT d2 \<Longrightarrow> \<not> LS M' qT \<subseteq> LS M (target q pT)"
       using pass_separator_ATC_fail_no_reduction[OF \<open>observable M'\<close> \<open>observable M\<close> \<open>qT \<in> states M'\<close>
                                                     \<open>target q pT \<in> FSM.states M\<close> \<open>q' \<in> FSM.states M\<close> 
                                                     \<open>is_separator M (target q pT) q' A d1 d2\<close> \<open>inputs M' = inputs M\<close>]
       by assumption
 
     moreover have "LS M' qT \<subseteq> LS M (target q pT)"
     proof -
       have "(target q pT) = target (initial M) (pP@pT)"
         using \<open>target (initial P) pP = q\<close> unfolding \<open>initial P = initial M\<close> by auto
 
       have "path M (initial M) (pP@pT)"
         using \<open>path M (initial M) pP\<close> \<open>target (initial P) pP = q\<close> \<open>path M q pT\<close> unfolding \<open>initial P = initial M\<close> by auto
       
       then have "(target q pT) \<in> io_targets M (p_io pP @ p_io pT) (FSM.initial M)"
         unfolding io_targets.simps \<open>(target q pT) = target (initial M) (pP@pT)\<close>
         using map_append by blast 
       
       show ?thesis
         using observable_language_target[OF \<open>observable M\<close> \<open>(target q pT) \<in> io_targets M (p_io pP @ p_io pT) (FSM.initial M)\<close> 
                                             \<open>qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M')\<close> \<open>L M' \<subseteq> L M\<close>]
         by assumption
     qed
 
     ultimately show "pass_separator_ATC M' A qT d2"
       by blast
   qed
   then have p3: "(\<forall> q P pP pT . (q,P) \<in> prs \<longrightarrow> 
                                   path P (initial P) pP \<longrightarrow> 
                                   target (initial P) pP = q \<longrightarrow> 
                                   pT \<in> tps q \<longrightarrow> 
                                   (p_io pP)@(p_io pT) \<in> L M' \<longrightarrow> 
                                   (\<forall> q' A d1 d2 qT . q' \<in> rd_targets (q,pT) \<longrightarrow> 
                                   (A,d1,d2) \<in> separators (target q pT, q') \<longrightarrow> 
                                   qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M') \<longrightarrow> 
                                   pass_separator_ATC M' A qT d2))"
     by blast
 
 
   show ?thesis 
     using p1 p2 p3
     unfolding passes_test_suite.simps 
     by blast
 qed
 
 
 
 
 subsection \<open>Exhaustiveness of Sufficient Test Suites\<close>
 
 text \<open>This subsection shows that test suites satisfying the sufficiency criterion are exhaustive.
       That is, for a System Under Test with at most m states that contains an error (i.e.: is not
       a reduction) a test suite sufficient for m will not pass.\<close>
 
 
 subsubsection \<open>R Functions\<close>
 
 
 (* collect all proper suffixes of p that target q' if applied to q *)
 definition R :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list set" where
   "R M q q' pP p = {pP @ p' | p' . p' \<noteq> [] \<and> target q p' = q' \<and> (\<exists> p'' . p = p'@p'')}" 
 
 (* add one completed path of some Preamble of q' to R if a preamble exists *)
 definition RP :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list \<Rightarrow> ('a \<times> ('a,'b,'c) preamble) set \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list set" where
   "RP M q q' pP p PS M' = (if \<exists> P' .  (q',P') \<in> PS then insert (SOME pP' . \<exists> P' .  (q',P') \<in> PS \<and> path P' (initial P') pP' \<and> target (initial P') pP' = q' \<and> p_io pP' \<in> L M') (R M q q' pP p) else (R M q q' pP p))" 
 
 
 
 lemma RP_from_R :
   assumes "\<And> q P . (q,P) \<in> PS \<Longrightarrow> is_preamble P M q"
   and     "\<And> q P io x y y' . (q,P) \<in> PS \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P"
   and     "completely_specified M'"
   and     "inputs M' = inputs M"
 shows "(RP M q q' pP p PS M' = R M q q' pP p) 
           \<or> (\<exists> P' pP' . (q',P') \<in> PS \<and> 
                         path P' (initial P') pP' \<and> 
                         target (initial P') pP' = q' \<and> 
                         path M (initial M) pP' \<and> 
                         target (initial M) pP' = q' \<and> 
                         p_io pP' \<in> L M' \<and> 
                         RP M q q' pP p PS M' = 
                         insert pP' (R M q q' pP p))"
 proof (rule ccontr)
   assume "\<not> (RP M q q' pP p PS M' = R M q q' pP p \<or> (\<exists> P' pP' . (q',P') \<in> PS \<and> path P' (initial P') pP' \<and> target (initial P') pP' = q' \<and> path M (initial M) pP' \<and> target (initial M) pP' = q' \<and> p_io pP' \<in> L M' \<and> RP M q q' pP p PS M' = insert pP' (R M q q' pP p)))"
   then have "(RP M q q' pP p PS M' \<noteq> R M q q' pP p)"
        and  "\<not> (\<exists> P' pP' . (q',P') \<in> PS \<and> 
                             path P' (initial P') pP' \<and> 
                             target (initial P') pP' = q' \<and> 
                             path M (initial M) pP' \<and> 
                             target (initial M) pP' = q' \<and> 
                             p_io pP' \<in> L M' \<and> 
                             RP M q q' pP p PS M' = insert pP' (R M q q' pP p))"
     by blast+
 
   let ?p = "SOME pP' . \<exists> P' .  (q',P') \<in> PS \<and> path P' (initial P') pP' \<and> target (initial P') pP' = q' \<and> p_io pP' \<in> L M'"
 
   have "\<exists> P' .  (q',P') \<in> PS"
     using \<open>(RP M q q' pP p PS M' \<noteq> R M q q' pP p)\<close> unfolding RP_def by auto
   then obtain P' where "(q',P') \<in> PS"
     by auto
   then have "is_preamble P' M q'"
     using assms by blast
 
   obtain pP' where "path P' (initial P') pP'" and "target (initial P') pP' = q'" and "p_io pP' \<in> L M'"
     using preamble_pass_path[OF \<open>is_preamble P' M q'\<close>  
           assms(2)[OF \<open>(q',P') \<in> PS\<close>] assms(3,4)] 
     by force
   then have "\<exists> pP' . \<exists> P' .  (q',P') \<in> PS \<and> path P' (initial P') pP' \<and> target (initial P') pP' = q' \<and> p_io pP' \<in> L M'"
     using \<open>(q',P') \<in> PS\<close> by blast
   have "\<exists> P' .  (q',P') \<in> PS \<and> path P' (initial P') ?p \<and> target (initial P') ?p = q' \<and> p_io ?p \<in> L M'"
     using someI_ex[OF \<open>\<exists> pP' . \<exists> P' .  (q',P') \<in> PS \<and> path P' (initial P') pP' \<and> target (initial P') pP' = q' \<and> p_io pP' \<in> L M'\<close>] 
     by blast
 
   then obtain P'' where "(q',P'') \<in> PS" and "path P'' (initial P'') ?p" and "target (initial P'') ?p = q'" and "p_io ?p \<in> L M'"
     by auto
   then have "is_preamble P'' M q'"
     using assms by blast
 
   
   have "initial P'' = initial M"
     using \<open>is_preamble P'' M q'\<close> unfolding is_preamble_def by auto
   have "path M (initial M) ?p"
     using \<open>is_preamble P'' M q'\<close> unfolding is_preamble_def using submachine_path_initial
     using \<open>path P'' (FSM.initial P'') ?p\<close> by blast
   have "target (initial M) ?p = q'"
     using \<open>target (initial P'') ?p = q'\<close> unfolding \<open>initial P'' = initial M\<close> by assumption
 
   have "RP M q q' pP p PS M' = insert ?p (R M q q' pP p)"
     using \<open>\<exists> P' .  (q',P') \<in> PS\<close> unfolding RP_def by auto
 
   then have "(\<exists> P' pP' . (q',P') \<in> PS \<and> 
                           path P' (initial P') pP' \<and> 
                           target (initial P') pP' = q' \<and> 
                           path M (initial M) pP' \<and> 
                           target (initial M) pP' = q' \<and> 
                           p_io pP' \<in> L M' \<and> 
                           RP M q q' pP p PS M' = insert pP' (R M q q' pP p))"
     using \<open>(q',P'') \<in> PS\<close> \<open>path P'' (initial P'') ?p\<close> \<open>target (initial P'') ?p = q'\<close> 
           \<open>path M (initial M) ?p\<close> \<open>target (initial M) ?p = q'\<close> \<open>p_io ?p \<in> L M'\<close> by blast
   then show "False"
     using \<open>\<not> (\<exists> P' pP' . (q',P') \<in> PS \<and> path P' (initial P') pP' \<and> target (initial P') pP' = q' \<and> path M (initial M) pP' \<and> target (initial M) pP' = q' \<and> p_io pP' \<in> L M' \<and> RP M q q' pP p PS M' = insert pP' (R M q q' pP p))\<close>
     by blast
 qed
 
 
 lemma RP_from_R_inserted :
   assumes "\<And> q P . (q,P) \<in> PS \<Longrightarrow> is_preamble P M q"
   and     "\<And> q P io x y y' . (q,P) \<in> PS \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P"
   and     "completely_specified M'"
   and     "inputs M' = inputs M"
   and     "pP' \<in> RP M q q' pP p PS M'"
   and     "pP' \<notin> R M q q' pP p"
 obtains P' where  "(q',P') \<in> PS" 
                   "path P' (initial P') pP'" 
                   "target (initial P') pP' = q'" 
                   "path M (initial M) pP'"
                   "target (initial M) pP' = q'"
                   "p_io pP' \<in> L M'"
                   "RP M q q' pP p PS M' = insert pP' (R M q q' pP p)"
 proof -
   have "(RP M q q' pP p PS M' \<noteq> R M q q' pP p)"
     using assms(5,6) by blast
 
   then have "(\<exists>P' pP'.
               (q', P') \<in> PS \<and>
               path P' (FSM.initial P') pP' \<and>
               target (FSM.initial P') pP' = q' \<and>
               path M (FSM.initial M) pP' \<and> target (FSM.initial M) pP' = q' \<and> p_io pP' \<in> L M' \<and> RP M q q' pP p PS M' = insert pP' (R M q q' pP p))"
         using RP_from_R[OF assms(1-4), of PS _ _ q q' pP p] by force
   then obtain P' pP'' where "(q', P') \<in> PS"
                             "path P' (FSM.initial P') pP''"
                             "target (FSM.initial P') pP'' = q'"
                             "path M (FSM.initial M) pP''" 
                             "target (FSM.initial M) pP'' = q'" 
                             "p_io pP'' \<in> L M'"
                             "RP M q q' pP p PS M' = insert pP'' (R M q q' pP p)"
     by blast
 
   moreover have "pP'' = pP'" using \<open>RP M q q' pP p PS M' = insert pP'' (R M q q' pP p)\<close> assms(5,6) by simp
   ultimately show ?thesis using that[of P'] unfolding \<open>pP'' = pP'\<close> by blast
 qed
 
 
 lemma finite_R :
   assumes "path M q p"
   shows "finite (R M q q' pP p)"
 proof -
   have "\<And> p' . p' \<in> (R M q q' pP p) \<Longrightarrow> p' \<in> set (prefixes (pP@p))"
   proof -
     fix p' assume "p' \<in> (R M q q' pP p)"
     then obtain p'' where "p' = pP @ p''"
       unfolding R_def by blast
     then obtain p''' where "p = p'' @ p'''"
       using \<open>p' \<in> (R M q q' pP p)\<close> unfolding R_def by blast
     
     show "p' \<in> set (prefixes (pP@p))"
       unfolding prefixes_set \<open>p' = pP @ p''\<close> \<open>p = p'' @ p'''\<close> by auto
   qed
   then have "(R M q q' pP p) \<subseteq> set (prefixes (pP@p))"
     by blast
   then show ?thesis
     using rev_finite_subset by auto 
 qed
 
 lemma finite_RP :
   assumes "path M q p"
   and     "\<And> q P . (q,P) \<in> PS \<Longrightarrow> is_preamble P M q"
   and     "\<And> q P io x y y' . (q,P) \<in> PS \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P"
   and     "completely_specified M'"
   and     "inputs M' = inputs M"
 shows "finite (RP M q q' pP p PS M')"
   using finite_R[OF assms(1), of q' pP ]
         RP_from_R[OF assms(2,3,4,5), of PS _ _ q q' pP p] by force
   
 
 lemma R_component_ob :
   assumes "pR' \<in> R M q q' pP p"
   obtains pR where "pR' = pP@pR"
   using assms unfolding R_def by blast
 
 
 lemma R_component :
   assumes "(pP@pR) \<in> R M q q' pP p" 
 shows "pR = take (length pR) p"
 and   "length pR \<le> length p"
 and   "t_target (p ! (length pR - 1)) = q'"
 and   "pR \<noteq> []"
 proof -
   let ?R = "R M q q' p"
 
   have "pR \<noteq> []" and "target q pR = q'" and "\<exists> p'' . p = pR@p''"
     using \<open>pP@pR \<in> R M q q' pP p\<close> unfolding R_def by blast+
   then obtain pR' where "p = pR@pR'"
     by blast
 
   then show "pR = take (length pR) p" and "length pR \<le> length p"
     by auto
   
   show "t_target (p ! (length pR - 1)) = q'"
     using \<open>pR \<noteq> []\<close> \<open>target q pR = q'\<close> unfolding target.simps visited_states.simps
     by (metis (no_types, lifting) Suc_diff_1 \<open>pR = take (length pR) p\<close> 
           append_butlast_last_id last.simps last_map length_butlast lessI list.map_disc_iff 
           not_gr_zero nth_append_length nth_take take_eq_Nil) 
 
   show "pR \<noteq> []" 
     using \<open>pR \<noteq> []\<close> 
     by assumption
 qed
 
 
 lemma R_component_observable :
   assumes "pP@pR \<in> R M (target (initial M) pP) q' pP p"
   and     "observable M"
   and     "path M (initial M) pP"
   and     "path M (target (initial M) pP) p"
 shows "io_targets M (p_io pP @ p_io pR) (initial M) = {target (target (initial M) pP) (take (length pR) p)}"
 proof -
   have "pR = take (length pR) p"
   and  "length pR \<le> length p"
   and  "t_target (p ! (length pR - 1)) = q'"
     using R_component[OF assms(1)] by blast+
 
   let ?q = "(target (initial M) pP)"
   have "path M ?q (take (length pR) p)"
     using assms(4) by (simp add: path_prefix_take) 
   have "p_io (take (length pR) p) = p_io pR"
     using \<open>pR = take (length pR) p\<close> by auto
     
 
   have *:"path M (initial M) (pP @ (take (length pR) p))"
     using \<open>path M (initial M) pP\<close> \<open>path M ?q (take (length pR) p)\<close> by auto
   have **:"p_io (pP @ (take (length pR) p)) = (p_io pP @ p_io pR)"
     using \<open>p_io (take (length pR) p) = p_io pR\<close> by auto
   
   have "target (initial M) (pP @ (take (length pR) p)) = target ?q (take (length pR) p)"
     by auto 
   then have "target ?q (take (length pR) p) \<in> io_targets M (p_io pP @ p_io pR) (initial M)"
     unfolding io_targets.simps using * **
     by (metis (mono_tags, lifting) mem_Collect_eq) 
 
   show "io_targets M (p_io pP @ p_io pR) (initial M) = {target ?q (take (length pR) p)}"
     using observable_io_targets[OF \<open>observable M\<close> language_state_containment[OF * **]]
     by (metis (no_types) \<open>target (target (FSM.initial M) pP) (take (length pR) p) \<in> io_targets M (p_io pP @ p_io pR) (FSM.initial M)\<close> singleton_iff)
 qed
 
 
 lemma R_count :                        
   assumes "minimal_sequence_to_failure_extending_preamble_path M M' PS pP io"
   and     "observable M"
   and     "observable M'"
   and     "\<And> q P. (q, P) \<in> PS \<Longrightarrow> is_preamble P M q"
   and     "path M (target (initial M) pP) p"
   and     "butlast io = p_io p @ ioX"
 shows "card (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) (R M (target (initial M) pP) q' pP p))) = card (R M (target (initial M) pP) q' pP p)"
   (is "card ?Tgts = card ?R")
 and   "\<And> pR . pR \<in> (R M (target (initial M) pP) q' pP p) \<Longrightarrow> \<exists> q . io_targets M' (p_io pR) (initial M') = {q}"
 and   "\<And> pR1 pR2 . pR1 \<in> (R M (target (initial M) pP) q' pP p) \<Longrightarrow> 
                     pR2 \<in> (R M (target (initial M) pP) q' pP p) \<Longrightarrow> 
                     pR1 \<noteq> pR2 \<Longrightarrow> 
                     io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
 proof -
 
   have "sequence_to_failure_extending_preamble_path M M' PS pP io"
   and  "\<And> p' io' . sequence_to_failure_extending_preamble_path M M' PS p' io' \<Longrightarrow> length io \<le> length io'"
     using \<open>minimal_sequence_to_failure_extending_preamble_path M M' PS pP io\<close>
     unfolding minimal_sequence_to_failure_extending_preamble_path_def   
     by blast+
 
   obtain q P where "(q,P) \<in> PS"
               and  "path P (initial P) pP"
               and  "target (initial P) pP = q"
               and  "((p_io pP) @ butlast io) \<in> L M" 
               and  "((p_io pP) @ io) \<notin> L M"
               and  "((p_io pP) @ io) \<in> L M'"
 
     using \<open>sequence_to_failure_extending_preamble_path M M' PS pP io\<close>
     unfolding sequence_to_failure_extending_preamble_path_def  
     by blast
 
   have "is_preamble P M q"
     using \<open>(q,P) \<in> PS\<close> \<open>\<And> q P. (q, P) \<in> PS \<Longrightarrow> is_preamble P M q\<close> by blast
   then have "q \<in> states M"
     unfolding is_preamble_def
     by (metis \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> path_target_is_state submachine_path) 
 
   have "initial P = initial M"
     using \<open>is_preamble P M q\<close> unfolding is_preamble_def by auto
   have "path M (initial M) pP"
     using \<open>is_preamble P M q\<close> unfolding is_preamble_def using submachine_path_initial
     using \<open>path P (FSM.initial P) pP\<close> by blast
   have "target (initial M) pP = q"
     using \<open>target (initial P) pP = q\<close> unfolding \<open>initial P = initial M\<close> by assumption
 
   then have "path M q p"
     using \<open>path M (target (initial M) pP) p\<close> by auto
 
   have "io \<noteq> []"
     using \<open>((p_io pP) @ butlast io) \<in> L M\<close> \<open>((p_io pP) @ io) \<notin> L M\<close> by auto
 
 
   (* get the full path along (butlast io) in M, of which p is a (possibly proper) prefix *)
 
   obtain pX where "path M (target (initial M) pP) (p@pX)" and "p_io (p@pX) = butlast io"
   proof -
     have "p_io pP @ p_io p @ ioX \<in> L M"
       using \<open>((p_io pP) @ butlast io) \<in> L M\<close> 
       unfolding \<open>butlast io = p_io p @ ioX\<close> 
       by assumption
 
     obtain p1 p23 where "path M (FSM.initial M) p1" 
                     and "path M (target (FSM.initial M) p1) p23"
                     and "p_io p1 = p_io pP" 
                     and "p_io p23 = p_io p @ ioX"
       using language_state_split[OF \<open>p_io pP @ p_io p @ ioX \<in> L M\<close>] 
       by blast
 
     have "p1 = pP"
       using observable_path_unique[OF \<open>observable M\<close> \<open>path M (FSM.initial M) p1\<close> \<open>path M (FSM.initial M) pP\<close> \<open>p_io p1 = p_io pP\<close>] 
       by assumption
     then have "path M (target (FSM.initial M) pP) p23"
       using \<open>path M (target (FSM.initial M) p1) p23\<close> by auto
     then have "p_io p @ ioX \<in> LS M (target (initial M) pP)"
       using \<open>p_io p23 = p_io p @ ioX\<close> language_state_containment by auto
 
     obtain p2 p3 where "path M (target (FSM.initial M) pP) p2" 
                    and "path M (target (target (FSM.initial M) pP) p2) p3" 
                    and "p_io p2 = p_io p" 
                    and "p_io p3 = ioX"
       using language_state_split[OF \<open>p_io p @ ioX \<in> LS M (target (initial M) pP)\<close>] 
       by blast
 
     have "p2 = p"
       using observable_path_unique[OF \<open>observable M\<close> \<open>path M (target (FSM.initial M) pP) p2\<close> \<open>path M (target (FSM.initial M) pP) p\<close> \<open>p_io p2 = p_io p\<close>] 
       by assumption
     then have "path M (target (FSM.initial M) pP) (p@p3)"
       using \<open>path M (target (FSM.initial M) pP) p\<close> \<open>path M (target (target (FSM.initial M) pP) p2) p3\<close> 
       by auto
     moreover have "p_io (p@p3) = butlast io"
       unfolding \<open>butlast io = p_io p @ ioX\<close> using \<open>p_io p3 = ioX\<close> 
       by auto
     ultimately show ?thesis 
       using that[of p3] 
       by simp
   qed
 
 
   (* finiteness properties *)
 
   have "finite ?R"
     using finite_R[OF \<open>path M (target (initial M) pP) p\<close>]
     by assumption
   moreover have "\<And> pR . pR \<in> ?R \<Longrightarrow> finite (io_targets M' (p_io pR) (initial M'))"
     using io_targets_finite by metis
   ultimately have "finite ?Tgts"
     by blast
 
 
   (* path properties *)
   
   obtain pP' p' where "path M' (FSM.initial M') pP'" 
                 and   "path M' (target (FSM.initial M') pP') p'" 
                 and   "p_io pP' = p_io pP" 
                 and   "p_io p' = io"
     using language_state_split[OF \<open>((p_io pP) @ io) \<in> L M'\<close>]
     by blast
 
   have "length p \<le> length (butlast io)"
     using \<open>butlast io = p_io p @ ioX\<close> by auto
   moreover have "length (butlast io) < length io"
     using \<open>io \<noteq> []\<close> by auto
   ultimately have "length p < length p'"
     unfolding \<open>p_io p' = io\<close> length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric] by simp
 
 
   let ?q = "(target (FSM.initial M') pP')"
 
   have "\<And> pR . pP@pR \<in> ?R \<Longrightarrow> path M' ?q (take (length pR) p') \<and> p_io (take (length pR) p') = p_io pR"
   proof -
     fix pR assume "pP@pR \<in> ?R"
     then have  "pR = take (length pR) p \<and> length pR \<le> length p"
       using R_component(1,2) by metis
     then have "p_io pR = take (length pR) (butlast io)"
       unfolding \<open>butlast io = p_io p @ ioX\<close>
       by (metis (no_types, lifting) length_map take_le take_map)
     moreover have "p_io (take (length pR) p') = take (length pR) io"
       by (metis (full_types) \<open>p_io p' = io\<close> take_map)
     moreover have "take (length pR) (butlast io) = take (length pR) io"
       by (meson \<open>length (butlast io) < length io\<close> \<open>length p \<le> length (butlast io)\<close> 
             \<open>pR = take (length pR) p \<and> length pR \<le> length p\<close> dual_order.strict_trans2 take_butlast)
     ultimately have "p_io (take (length pR) p') = p_io pR"
       by simp 
     moreover have "path M' ?q (take (length pR) p')"
       using \<open>path M' (target (FSM.initial M') pP') p'\<close>
       by (simp add: path_prefix_take) 
     ultimately show "path M' ?q (take (length pR) p') \<and> p_io (take (length pR) p') = p_io pR"
       by blast
   qed
 
 
   (* every element in R reaches exactly one state in M' *)
 
   have singleton_prop': "\<And> pR . pP@pR \<in> ?R \<Longrightarrow> io_targets M' (p_io (pP@pR)) (initial M') = {target ?q (take (length pR) p')}"
   proof -
     fix pR assume "pP@pR \<in> ?R"
     then have "path M' ?q (take (length pR) p')" and "p_io (take (length pR) p') = p_io pR"
       using \<open>\<And> pR . pP@pR \<in> ?R \<Longrightarrow> path M' ?q (take (length pR) p') \<and> p_io (take (length pR) p') = p_io pR\<close> by blast+
 
     have *:"path M' (initial M') (pP' @ (take (length pR) p'))"
       using \<open>path M' (initial M') pP'\<close> \<open>path M' ?q (take (length pR) p')\<close> by auto
     have **:"p_io (pP' @ (take (length pR) p')) = (p_io (pP@pR))"
       using \<open>p_io pP' = p_io pP\<close> \<open>p_io (take (length pR) p') = p_io pR\<close> by auto
     
     have "target (initial M') (pP' @ (take (length pR) p')) = target ?q (take (length pR) p')"
       by auto 
     then have "target ?q (take (length pR) p') \<in> io_targets M' (p_io (pP@pR)) (initial M')"
       unfolding io_targets.simps using * **
       by (metis (mono_tags, lifting) mem_Collect_eq) 
 
     show "io_targets M' (p_io (pP@pR)) (initial M') = {target ?q (take (length pR) p')}"
       using observable_io_targets[OF \<open>observable M'\<close> language_state_containment[OF * **]]
       by (metis (no_types) \<open>target (target (FSM.initial M') pP') (take (length pR) p') \<in> io_targets M' (p_io (pP@pR)) (FSM.initial M')\<close> singleton_iff)
   qed
 
   have singleton_prop: "\<And> pR . pR \<in> ?R \<Longrightarrow> io_targets M' (p_io pR) (initial M') = {target ?q (take (length pR - length pP) p')}"
   proof -
     fix pR assume "pR \<in> ?R"
     then obtain pR' where "pR = pP@pR'"
       using R_component_ob[of _ M "(target (FSM.initial M) pP)" q' pP p] by blast
     have **: "(length (pP @ pR') - length pP) = length pR'"
       by auto
 
     show "io_targets M' (p_io pR) (initial M') = {target ?q (take (length pR - length pP) p')}"
       using singleton_prop'[of pR'] \<open>pR \<in> ?R\<close> unfolding \<open>pR = pP@pR'\<close> ** by blast
   qed
   then show "\<And> pR . pR \<in> ?R \<Longrightarrow> \<exists> q . io_targets M' (p_io pR) (initial M') = {q}"
     by blast
 
   (* distinct elements in R reach distinct states in M' *)
   have pairwise_dist_prop': "\<And> pR1 pR2 . pP@pR1 \<in> ?R \<Longrightarrow> pP@pR2 \<in> ?R \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io (pP@pR1)) (initial M') \<inter> io_targets M' (p_io (pP@pR2)) (initial M') = {}"
   proof -
     
     have diff_prop: "\<And> pR1 pR2 . pP@pR1 \<in> ?R \<Longrightarrow> pP@pR2 \<in> ?R \<Longrightarrow> length pR1 < length pR2 \<Longrightarrow> io_targets M' (p_io (pP@pR1)) (initial M') \<inter> io_targets M' (p_io (pP@pR2)) (initial M') = {}"
     proof -
       fix pR1 pR2 assume "pP@pR1 \<in> ?R" and "pP@pR2 \<in> ?R" and "length pR1 < length pR2"
 
       let ?i = "length pR1 - 1"
       let ?j = "length pR2 - 1"
 
       have "pR1 = take (length pR1) p" and \<open>length pR1 \<le> length p\<close> and "t_target (p ! ?i) = q'"
         using R_component[OF \<open>pP@pR1 \<in> ?R\<close>]
         by simp+
       have "length pR1 \<noteq> 0"
         using \<open>pP@pR1 \<in> ?R\<close> unfolding R_def
         by simp 
       then have "?i < ?j" 
         using \<open>length pR1 < length pR2\<close>
         by (simp add: less_diff_conv) 
 
 
       have "pR2 = take (length pR2) p" and \<open>length pR2 \<le> length p\<close> and "t_target (p ! ?j) = q'"
         using R_component[OF \<open>pP@pR2 \<in> ?R\<close>]
         by simp+
       then have "?j < length (butlast io)"
         using \<open>length p \<le> length (butlast io)\<close> \<open>length pR1 < length pR2\<close> by linarith
 
 
       have "?q \<in> io_targets M' (p_io pP) (FSM.initial M')"
         unfolding \<open>p_io pP' = p_io pP\<close>[symmetric] io_targets.simps
         using \<open>path M' (initial M') pP'\<close> by auto
 
       have "t_target (p ! ?i) = t_target (p ! ?j)"
         using \<open>t_target (p ! ?i) = q'\<close> \<open>t_target (p ! ?j) = q'\<close> by simp
       moreover have "(p @ pX) ! ?i = p ! ?i"
         by (meson \<open>length pR1 < length pR2\<close> \<open>length pR2 \<le> length p\<close> less_imp_diff_less less_le_trans nth_append)
       moreover have "(p @ pX) ! ?j = p ! ?j"
         by (metis (no_types) \<open>length pR1 < length pR2\<close> \<open>pR2 = take (length pR2) p\<close> diff_less less_imp_diff_less less_nat_zero_code less_numeral_extra(1) not_le_imp_less not_less_iff_gr_or_eq nth_append take_all)
       ultimately have "t_target (p' ! ?i) \<noteq> t_target (p' ! ?j)"
         using minimal_sequence_to_failure_extending_preamble_no_repetitions_along_path[OF assms(1,2) \<open>path M (target (initial M) pP) (p@pX)\<close> \<open>p_io (p @ pX) = butlast io\<close> \<open>?q \<in> io_targets M' (p_io pP) (FSM.initial M')\<close> \<open>path M' (target (FSM.initial M') pP') p'\<close> \<open>p_io p' = io\<close> \<open>?i < ?j\<close> \<open>?j < length (butlast io)\<close> assms(4)]
         by auto
 
       have t1: "io_targets M' (p_io (pP@pR1)) (initial M') = {t_target (p' ! ?i)}"
       proof -
         have "(p' ! ?i) = last (take (length pR1) p')"
           using \<open>length pR1 \<le> length p\<close> \<open>length p < length p'\<close>
           by (metis Suc_diff_1 \<open>length pR1 \<noteq> 0\<close> dual_order.strict_trans2 length_0_conv length_greater_0_conv less_imp_diff_less take_last_index)
         then have *: "target (target (FSM.initial M') pP') (take (length pR1) p') = t_target (p' ! ?i)"
           unfolding target.simps visited_states.simps
           by (metis (no_types, lifting) \<open>length p < length p'\<close> \<open>length pR1 \<noteq> 0\<close> gr_implies_not_zero last.simps last_map length_0_conv map_is_Nil_conv take_eq_Nil) 
         have **: "(length (pP @ pR1) - length pP) = length pR1"
           by auto
         show ?thesis
           using singleton_prop[OF \<open>pP@pR1 \<in> ?R\<close>]
           unfolding * ** by assumption
       qed
 
       have t2: "io_targets M' (p_io (pP@pR2)) (initial M') = {t_target (p' ! ?j)}"
       proof -
         have "(p' ! ?j) = last (take (length pR2) p')"
           using \<open>length pR2 \<le> length p\<close> \<open>length p < length p'\<close>
           by (metis Suc_diff_1 \<open>length pR1 - 1 < length pR2 - 1\<close> le_less_trans less_imp_diff_less 
                 linorder_neqE_nat not_less_zero take_last_index zero_less_diff)
         then have *: "target (target (FSM.initial M') pP') (take (length pR2) p') = t_target (p' ! ?j)"
           unfolding target.simps visited_states.simps
           by (metis (no_types, lifting) Nil_is_map_conv \<open>length p < length p'\<close> \<open>length pR1 < length pR2\<close> 
                 last.simps last_map list.size(3) not_less_zero take_eq_Nil)
         have **: "(length (pP @ pR2) - length pP) = length pR2"
           by auto  
         show ?thesis
           using singleton_prop'[OF \<open>pP@pR2 \<in> ?R\<close>]
           unfolding * ** by assumption
       qed
 
       show "io_targets M' (p_io (pP@pR1)) (initial M') \<inter> io_targets M' (p_io (pP@pR2)) (initial M') = {}"
         using \<open>t_target (p' ! ?i) \<noteq> t_target (p' ! ?j)\<close>
         unfolding t1 t2 by simp
     qed
 
 
     fix pR1 pR2 assume "pP@pR1 \<in> ?R" and "pP@pR2 \<in> ?R" and "pR1 \<noteq> pR2"
     then have "length pR1 \<noteq> length pR2"
       unfolding R_def
       by auto 
 
     then consider (a) "length pR1 < length pR2" | (b) "length pR2 < length pR1"
       using nat_neq_iff by blast 
     then show "io_targets M' (p_io (pP@pR1)) (initial M') \<inter> io_targets M' (p_io (pP@pR2)) (initial M') = {}"
     proof cases
       case a
       show ?thesis using diff_prop[OF \<open>pP@pR1 \<in> ?R\<close> \<open>pP@pR2 \<in> ?R\<close> a] by blast
     next
       case b
       show ?thesis using diff_prop[OF \<open>pP@pR2 \<in> ?R\<close> \<open>pP@pR1 \<in> ?R\<close> b] by blast
     qed
   qed
 
   then show pairwise_dist_prop: "\<And> pR1 pR2 . pR1 \<in> ?R \<Longrightarrow> pR2 \<in> ?R \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}" 
     using R_component_ob
     by (metis (no_types, lifting)) 
 
 
   (* combining results *)
 
   let ?f = "(\<lambda> pR . io_targets M' (p_io pR) (initial M'))"
   
   have p1: "(\<And>S1 S2. S1 \<in> ?R \<Longrightarrow> S2 \<in> ?R \<Longrightarrow> S1 = S2 \<or> ?f S1 \<inter> ?f S2 = {})"
     using pairwise_dist_prop by blast
   have p2: "(\<And>S. S \<in> R M (target (FSM.initial M) pP) q' pP p \<Longrightarrow> io_targets M' (p_io S) (FSM.initial M') \<noteq> {})"
     using singleton_prop by blast
   have c1: "card (R M (target (FSM.initial M) pP) q' pP p) = card ((\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` R M (target (FSM.initial M) pP) q' pP p)"
     using card_union_of_distinct[of ?R, OF p1 \<open>finite ?R\<close> p2] by force
 
   have p3: "(\<And>S. S \<in> (\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` R M (target (FSM.initial M) pP) q' pP p \<Longrightarrow> \<exists>t. S = {t})"
     using singleton_prop by blast
   have c2:"card ((\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` R M (target (FSM.initial M) pP) q' pP p) = card (\<Union>S\<in>R M (target (FSM.initial M) pP) q' pP p. io_targets M' (p_io S) (FSM.initial M'))"
     using card_union_of_singletons[of "((\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` R M (target (FSM.initial M) pP) q' pP p)", OF p3] by force
 
     
   show "card ?Tgts = card ?R"
     unfolding c1 c2 by blast
 qed
 
 
 lemma R_update :
   "R M q q' pP (p@[t]) = (if (target q (p@[t]) = q')
                           then insert (pP@p@[t]) (R M q q' pP p)
                           else (R M q q' pP p))"
   (is "?R1 = ?R2")
 proof (cases "(target q (p@[t]) = q')")
   case True
   then have *: "?R2 = insert (pP@p@[t]) (R M q q' pP p)"
     by auto
   
   have "\<And> p' . p' \<in> R M q q' pP (p@[t]) \<Longrightarrow> p' \<in> insert (pP@p@[t]) (R M q q' pP p)"
   proof -
     fix p' assume "p' \<in> R M q q' pP (p@[t])"
 
     obtain p'' where "p' = pP @ p''"
       using R_component_ob[OF \<open>p' \<in> R M q q' pP (p@[t])\<close>] by blast
 
     obtain p''' where "p'' \<noteq> []" and "target q p'' = q'" and "p @ [t] = p'' @ p'''"
       using \<open>p' \<in> R M q q' pP (p@[t])\<close> unfolding R_def \<open>p' = pP @ p''\<close>
       by auto 
 
     show "p' \<in> insert (pP@p@[t]) (R M q q' pP p)"
     proof (cases p''' rule: rev_cases)
       case Nil
       then have "p' = pP@(p@[t])" using \<open>p' = pP @ p''\<close> \<open>p @ [t] = p'' @ p'''\<close> by auto
       then show ?thesis by blast
     next
       case (snoc p'''' t')
       then have "p = p'' @ p''''" using \<open>p @ [t] = p'' @ p'''\<close> by auto
       then show ?thesis 
         unfolding R_def using \<open>p'' \<noteq> []\<close> \<open>target q p'' = q'\<close>
         by (simp add: \<open>p' = pP @ p''\<close>) 
     qed
   qed
   moreover have "\<And> p' . p' \<in> insert (pP@p@[t]) (R M q q' pP p) \<Longrightarrow> p' \<in> R M q q' pP (p@[t])"
   proof -
     fix p' assume "p' \<in> insert (pP@p@[t]) (R M q q' pP p)"
     then consider (a) "p' = (pP@p@[t])" | (b) "p' \<in> (R M q q' pP p)" by blast
     then show "p' \<in> R M q q' pP (p@[t])" proof cases
       case a
       then show ?thesis using True unfolding R_def
         by simp 
     next
       case b
       then show ?thesis unfolding R_def
         using append.assoc by blast 
     qed 
   qed
   ultimately show ?thesis 
     unfolding * by blast
 next
   case False
   then have *: "?R2 = (R M q q' pP p)"
     by auto
 
   have "\<And> p' . p' \<in> R M q q' pP (p@[t]) \<Longrightarrow> p' \<in> (R M q q' pP p)"
   proof -
     fix p' assume "p' \<in> R M q q' pP (p@[t])"
 
     obtain p'' where "p' = pP @ p''"
       using R_component_ob[OF \<open>p' \<in> R M q q' pP (p@[t])\<close>] by blast
 
     obtain p''' where "p'' \<noteq> []" and "target q p'' = q'" and "p @ [t] = p'' @ p'''"
       using \<open>p' \<in> R M q q' pP (p@[t])\<close> unfolding R_def \<open>p' = pP @ p''\<close> by blast
 
     show "p' \<in> (R M q q' pP p)"
     proof (cases p''' rule: rev_cases)
       case Nil
       then have "p' = pP@(p@[t])" using \<open>p' = pP @ p''\<close> \<open>p @ [t] = p'' @ p'''\<close> by auto
       then show ?thesis
         using False \<open>p @ [t] = p'' @ p'''\<close> \<open>target q p'' = q'\<close> local.Nil by auto
     next
       case (snoc p'''' t')
       then have "p = p'' @ p''''" using \<open>p @ [t] = p'' @ p'''\<close> by auto
       then show ?thesis 
         unfolding R_def using \<open>p'' \<noteq> []\<close> \<open>target q p'' = q'\<close>
         by (simp add: \<open>p' = pP @ p''\<close>) 
     qed
   qed
   moreover have "\<And> p' . p' \<in> (R M q q' pP p) \<Longrightarrow> p' \<in> R M q q' pP (p@[t])"
   proof -
     fix p' assume "p' \<in> (R M q q' pP p)"
     then show "p' \<in> R M q q' pP (p@[t])" unfolding R_def
       using append.assoc by blast 
   qed
   ultimately show ?thesis 
     unfolding * by blast
 qed
 
 
 lemma R_union_card_is_suffix_length :
   assumes "path M (initial M) pP"
   and     "path M (target (initial M) pP) p"
 shows "(\<Sum> q \<in> states M . card (R M (target (initial M) pP) q pP p)) = length p"
 using assms(2) proof (induction p rule: rev_induct)
   case Nil
   have "\<And> q' . R M (target (initial M) pP) q' pP [] = {}"
     unfolding R_def by auto 
   then show ?case
     by simp 
 next
   case (snoc t p)
   then have "path M (target (initial M) pP) p"
     by auto
 
   let ?q = "(target (initial M) pP)"
   let ?q' = "target ?q (p @ [t])"
 
   have "\<And> q . q \<noteq> ?q' \<Longrightarrow> R M ?q q pP (p@[t]) = R M ?q q pP p"
     using R_update[of M ?q _ pP p t] by force
   then have *: "(\<Sum> q \<in> states M - {?q'} . card (R M (target (initial M) pP) q pP (p@[t]))) 
                   = (\<Sum> q \<in> states M - {?q'} . card (R M (target (initial M) pP) q pP p))"
     by force
 
 
 
   have "R M ?q ?q' pP (p@[t]) = insert (pP@p@[t]) (R M ?q ?q' pP p)"
     using R_update[of M ?q ?q' pP p t] by force 
   moreover have "(pP@p@[t]) \<notin> (R M ?q ?q' pP p)"
     unfolding R_def by simp 
   ultimately have **: "card (R M (target (initial M) pP) ?q' pP (p@[t])) = Suc (card (R M (target (initial M) pP) ?q' pP p))"
     using finite_R[OF \<open>path M (target (initial M) pP) (p@[t])\<close>] finite_R[OF \<open>path M (target (initial M) pP) p\<close>]
     by simp
 
 
   have "?q' \<in> states M"
     using path_target_is_state[OF \<open>path M (target (FSM.initial M) pP) (p @ [t])\<close>] by assumption
   then have ***: "(\<Sum> q \<in> states M . card (R M (target (initial M) pP) q pP (p@[t]))) 
                     = (\<Sum> q \<in> states M - {?q'} . card (R M (target (initial M) pP) q pP (p@[t]))) + (card (R M (target (initial M) pP) ?q' pP (p@[t])))"
        and ****: "(\<Sum> q \<in> states M . card (R M (target (initial M) pP) q pP p)) 
                     = (\<Sum> q \<in> states M - {?q'} . card (R M (target (initial M) pP) q pP p)) + (card (R M (target (initial M) pP) ?q' pP p))"
     by (metis (no_types, lifting) Diff_insert_absorb add.commute finite_Diff fsm_states_finite mk_disjoint_insert sum.insert)+
 
   have "(\<Sum> q \<in> states M . card (R M (target (initial M) pP) q pP (p@[t]))) = Suc (\<Sum> q \<in> states M . card (R M (target (initial M) pP) q pP p))"
     unfolding **** *** ** * by simp
 
   then show ?case
     unfolding snoc.IH[OF \<open>path M (target (initial M) pP) p\<close>] by auto
 qed
 
 
 
 lemma RP_count :                        
   assumes "minimal_sequence_to_failure_extending_preamble_path M M' PS pP io"
   and     "observable M"
   and     "observable M'"
   and     "\<And> q P. (q, P) \<in> PS \<Longrightarrow> is_preamble P M q"
   and     "path M (target (initial M) pP) p"
   and     "butlast io = p_io p @ ioX"
   and     "\<And> q P io x y y' . (q,P) \<in> PS \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P"
   and     "completely_specified M'"
   and     "inputs M' = inputs M"
 shows "card (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) (RP M (target (initial M) pP) q' pP p PS M'))) 
         = card (RP M (target (initial M) pP) q' pP p PS M')"
   (is "card ?Tgts = card ?RP")
 and "\<And> pR . pR \<in> (RP M (target (initial M) pP) q' pP p PS M') \<Longrightarrow> \<exists> q . io_targets M' (p_io pR) (initial M') = {q}"
 and "\<And> pR1 pR2 . pR1 \<in> (RP M (target (initial M) pP) q' pP p PS M') \<Longrightarrow> pR2 \<in> (RP M (target (initial M) pP) q' pP p PS M') \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
 proof -
   let ?P1 = "card (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) (RP M (target (initial M) pP) q' pP p PS M'))) = card (RP M (target (initial M) pP) q' pP p PS M')"
   let ?P2 = "\<forall> pR . pR \<in> (RP M (target (initial M) pP) q' pP p PS M') \<longrightarrow> (\<exists> q . io_targets M' (p_io pR) (initial M') = {q})"
   let ?P3 = "\<forall> pR1 pR2 . pR1 \<in> (RP M (target (initial M) pP) q' pP p PS M') \<longrightarrow> pR2 \<in> (RP M (target (initial M) pP) q' pP p PS M') \<longrightarrow> pR1 \<noteq> pR2 \<longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
   let ?combined_goals = "?P1 \<and> ?P2 \<and> ?P3"
     
   let ?q = "(target (initial M) pP)"
   let ?R = "R M ?q q' pP p"
 
   consider (a) "(?RP = ?R)" |
            (b) "(\<exists> P' pP' . (q',P') \<in> PS \<and> 
                             path P' (initial P') pP' \<and> 
                             target (initial P') pP' = q' \<and> 
                             path M (initial M) pP' \<and> 
                             target (initial M) pP' = q' \<and> 
                             p_io pP' \<in> L M' \<and> 
                             ?RP = insert pP' ?R)"
     using RP_from_R[OF assms(4,7,8,9), of PS _ _ ?q q' pP p] by force
 
   then have ?combined_goals proof cases
     case a
     show ?thesis unfolding a using R_count[OF assms(1-6)] by blast
   next
     case b
     
 
     (* properties from R_count *)
 
     have "sequence_to_failure_extending_preamble_path M M' PS pP io"
     and  "\<And> p' io' . sequence_to_failure_extending_preamble_path M M' PS p' io' \<Longrightarrow> length io \<le> length io'"
       using \<open>minimal_sequence_to_failure_extending_preamble_path M M' PS pP io\<close>
       unfolding minimal_sequence_to_failure_extending_preamble_path_def   
       by blast+
   
     obtain q P where "(q,P) \<in> PS"
                 and  "path P (initial P) pP"
                 and  "target (initial P) pP = q"
                 and  "((p_io pP) @ butlast io) \<in> L M" 
                 and  "((p_io pP) @ io) \<notin> L M"
                 and  "((p_io pP) @ io) \<in> L M'"
   
       using \<open>sequence_to_failure_extending_preamble_path M M' PS pP io\<close>
       unfolding sequence_to_failure_extending_preamble_path_def  
       by blast
   
     have "is_preamble P M q"
       using \<open>(q,P) \<in> PS\<close> \<open>\<And> q P. (q, P) \<in> PS \<Longrightarrow> is_preamble P M q\<close> by blast
     then have "q \<in> states M"
       unfolding is_preamble_def
       by (metis \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> path_target_is_state submachine_path) 
   
     have "initial P = initial M"
       using \<open>is_preamble P M q\<close> unfolding is_preamble_def by auto
     have "path M (initial M) pP"
       using \<open>is_preamble P M q\<close> unfolding is_preamble_def using submachine_path_initial
       using \<open>path P (FSM.initial P) pP\<close> by blast
     have "target (initial M) pP = q"
       using \<open>target (initial P) pP = q\<close> unfolding \<open>initial P = initial M\<close> by assumption
   
     then have "path M q p"
       using \<open>path M (target (initial M) pP) p\<close> by auto
   
     have "io \<noteq> []"
       using \<open>((p_io pP) @ butlast io) \<in> L M\<close> \<open>((p_io pP) @ io) \<notin> L M\<close> by auto
   
   
     (* finiteness properties *)
   
     have "finite ?RP"                                          
       using finite_RP[OF \<open>path M (target (initial M) pP) p\<close> assms(4,7,8,9)] by force
     moreover have "\<And> pR . pR \<in> ?RP \<Longrightarrow> finite (io_targets M' (p_io pR) (initial M'))"
       using io_targets_finite by metis
     ultimately have "finite ?Tgts"
       by blast
   
   
     (* path properties *)
     
     obtain pP' p' where "path M' (FSM.initial M') pP'" 
                   and   "path M' (target (FSM.initial M') pP') p'" 
                   and   "p_io pP' = p_io pP" 
                   and   "p_io p' = io"
       using language_state_split[OF \<open>((p_io pP) @ io) \<in> L M'\<close>]
       by blast
   
     have "length p \<le> length (butlast io)"
       using \<open>butlast io = p_io p @ ioX\<close> by auto
     moreover have "length (butlast io) < length io"
       using \<open>io \<noteq> []\<close> by auto
     ultimately have "length p < length p'"
       unfolding \<open>p_io p' = io\<close> length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric] by simp
   
     let ?q = "(target (FSM.initial M') pP')"
   
     have "\<And> pR . pP@pR \<in> ?R \<Longrightarrow> path M' ?q (take (length pR) p') \<and> p_io (take (length pR) p') = p_io pR"
     proof -
       fix pR assume "pP@pR \<in> ?R"
       then have  "pR = take (length pR) p \<and> length pR \<le> length p"
         using R_component(1,2) by metis
       then have "p_io pR = take (length pR) (butlast io)"
         by (metis (no_types, lifting) assms(6) length_map take_le take_map) 
       moreover have "p_io (take (length pR) p') = take (length pR) io"
         by (metis (full_types) \<open>p_io p' = io\<close> take_map)
       moreover have "take (length pR) (butlast io) = take (length pR) io"
         using \<open>length p \<le> length (butlast io)\<close> \<open>pR = take (length pR) p \<and> length pR \<le> length p\<close>
               butlast_take_le dual_order.trans 
         by blast
       ultimately have "p_io (take (length pR) p') = p_io pR"
         by simp 
       moreover have "path M' ?q (take (length pR) p')"
         using \<open>path M' (target (FSM.initial M') pP') p'\<close>
         by (simp add: path_prefix_take) 
       ultimately show "path M' ?q (take (length pR) p') \<and> p_io (take (length pR) p') = p_io pR"
         by blast
     qed
   
   
     (* every element in R reaches exactly one state in M' *)
   
     have singleton_prop'_R: "\<And> pR . pP@pR \<in> ?R \<Longrightarrow> io_targets M' (p_io (pP@pR)) (initial M') = {target ?q (take (length pR) p')}"
     proof -
       fix pR assume "pP@pR \<in> ?R"
       then have "path M' ?q (take (length pR) p')" and "p_io (take (length pR) p') = p_io pR"
         using \<open>\<And> pR . pP@pR \<in> ?R \<Longrightarrow> path M' ?q (take (length pR) p') \<and> p_io (take (length pR) p') = p_io pR\<close> by blast+
   
       have *:"path M' (initial M') (pP' @ (take (length pR) p'))"
         using \<open>path M' (initial M') pP'\<close> \<open>path M' ?q (take (length pR) p')\<close> by auto
       have **:"p_io (pP' @ (take (length pR) p')) = (p_io (pP@pR))"
         using \<open>p_io pP' = p_io pP\<close> \<open>p_io (take (length pR) p') = p_io pR\<close> by auto
       
       have "target (initial M') (pP' @ (take (length pR) p')) = target ?q (take (length pR) p')"
         by auto 
       then have "target ?q (take (length pR) p') \<in> io_targets M' (p_io (pP@pR)) (initial M')"
         unfolding io_targets.simps using * **
         by (metis (mono_tags, lifting) mem_Collect_eq) 
   
       show "io_targets M' (p_io (pP@pR)) (initial M') = {target ?q (take (length pR) p')}"
         using observable_io_targets[OF \<open>observable M'\<close> language_state_containment[OF * **]]
         by (metis (no_types) \<open>target (target (FSM.initial M') pP') (take (length pR) p') \<in> io_targets M' (p_io (pP@pR)) (FSM.initial M')\<close> singleton_iff)
     qed
   
     have singleton_prop_R: "\<And> pR . pR \<in> ?R \<Longrightarrow> io_targets M' (p_io pR) (initial M') = {target ?q (take (length pR - length pP) p')}"
     proof -
       fix pR assume "pR \<in> ?R"
       then obtain pR' where "pR = pP@pR'"
         using R_component_ob[of _ M "(target (FSM.initial M) pP)" q' pP p] by blast
       have **: "(length (pP @ pR') - length pP) = length pR'"
         by auto
   
       show "io_targets M' (p_io pR) (initial M') = {target ?q (take (length pR - length pP) p')}"
         using singleton_prop'_R[of pR'] \<open>pR \<in> ?R\<close> unfolding \<open>pR = pP@pR'\<close> ** by blast
     qed
 
 
     (* RP props *)
 
     from b obtain P' pP'' where "(q',P') \<in> PS"
                           and   "path P' (initial P') pP''"
                           and   "target (initial P') pP'' = q'"
                           and   "path M (initial M) pP''"
                           and   "target (initial M) pP'' = q'"
                           and   "p_io pP'' \<in> L M'"
                           and   "?RP = insert pP'' ?R"
       by blast
     have "initial P' = initial M"
       using assms(4)[OF \<open>(q',P') \<in> PS\<close>] unfolding is_preamble_def by auto
 
     
 
     (* revisiting singleton_prop *)
 
     have "\<And> pR . pR \<in> ?RP \<Longrightarrow> pR \<in> ?R \<or> pR = pP''"
       using \<open>?RP = insert pP'' ?R\<close> by blast
     then have rp_cases[consumes 1, case_names in_R inserted]: "\<And> pR P . (pR \<in> ?RP) \<Longrightarrow> (pR \<in> ?R \<Longrightarrow> P) \<Longrightarrow> (pR = pP'' \<Longrightarrow> P) \<Longrightarrow> P" 
       by force 
 
     have singleton_prop_RP: "\<And> pR . pR \<in> ?RP \<Longrightarrow> \<exists> q . io_targets M' (p_io pR) (initial M') = {q}"
     proof - 
       fix pR assume "pR \<in> ?RP"
       then show "\<exists> q . io_targets M' (p_io pR) (initial M') = {q}" 
       proof (cases rule: rp_cases)
         case in_R
         then show ?thesis using singleton_prop_R by blast
       next
         case inserted
         show ?thesis 
           using observable_io_targets[OF \<open>observable M'\<close> \<open>p_io pP'' \<in> L M'\<close>] unfolding inserted
           by meson 
       qed
     qed
     then have ?P2 by blast
 
 
     (* distinctness in RP *)
 
     have pairwise_dist_prop_RP: "\<And> pR1 pR2 . pR1 \<in> ?RP \<Longrightarrow> pR2 \<in> ?RP \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
     proof -
       
       have pairwise_dist_prop_R: "\<And> pR1 pR2 . pR1 \<in> ?R \<Longrightarrow> pR2 \<in> ?R \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}" 
         using R_count(3)[OF assms(1-6)] by force
 
       have pairwise_dist_prop_PS: "\<And> pR1 . pR1 \<in> ?RP \<Longrightarrow> pR1 \<noteq> pP'' \<Longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pP'') (initial M') = {}"
       proof -
         fix pR1 assume "pR1 \<in> ?RP" and "pR1 \<noteq> pP''"
         then have "pR1 \<in> ?R"
           using \<open>\<And> pR . pR \<in> ?RP \<Longrightarrow> pR \<in> ?R \<or> pR = pP''\<close> by blast
         
         obtain pR' where "pR1 = pP@pR'"
           using R_component_ob[OF \<open>pR1 \<in> ?R\<close>] by blast
         then have "pP@pR' \<in> ?R"
           using \<open>pR1 \<in> ?R\<close> by blast
 
         have "pR' = take (length pR') p" 
          and "length pR' \<le> length p" 
          and "t_target (p ! (length pR' - 1)) = q'" 
          and "pR' \<noteq> []"
           using R_component[OF \<open>pP@pR' \<in> ?R\<close>] by blast+
 
         let ?i = "(length pR') - 1"
         have "?i < length p"
           using \<open>length pR' \<le> length p\<close> \<open>pR' \<noteq> []\<close>
           using diff_less dual_order.strict_trans1 less_numeral_extra(1) by blast 
         then have "?i < length (butlast io)"
           using \<open>length p \<le> length (butlast io)\<close> less_le_trans by blast 
 
 
         have "io_targets M' (p_io pR1) (initial M') = {t_target (p' ! ?i)}"
         proof -
           have "(p' ! ?i) = last (take (length pR') p')"
             using \<open>length pR' \<le> length p\<close> \<open>length p < length p'\<close>
             by (metis Suc_diff_1 \<open>pR' \<noteq> []\<close> dual_order.strict_trans2 length_greater_0_conv less_imp_diff_less take_last_index)
           then have *: "target ?q (take (length pR') p') = t_target (p' ! ?i)"
             unfolding target.simps visited_states.simps
             by (metis (no_types, lifting) \<open>length p < length p'\<close> \<open>pR' \<noteq> []\<close> gr_implies_not_zero last.simps 
                   last_map length_0_conv map_is_Nil_conv take_eq_Nil) 
           moreover have "io_targets M' (p_io pR1) (initial M') = {target ?q (take (length pR') p')}"
             using singleton_prop'_R \<open>pR1 \<in> ?R\<close> unfolding \<open>pR1 = pP@pR'\<close> by auto
           ultimately show ?thesis by auto
         qed
 
         have "t_target (p' ! (length pR' - 1)) \<notin> io_targets M' (p_io pP'') (FSM.initial M')"
         proof -
           (* get the full path along (butlast io) in M, of which p is a (possibly proper) prefix *)
 
           obtain pX where "path M (target (initial M) pP) (p@pX)" and "p_io (p@pX) = butlast io"
           proof -
             have "p_io pP @ p_io p @ ioX \<in> L M"
               using \<open>((p_io pP) @ butlast io) \<in> L M\<close> 
               unfolding \<open>butlast io = p_io p @ ioX\<close> 
               by assumption
         
             obtain p1 p23 where "path M (FSM.initial M) p1" and "path M (target (FSM.initial M) p1) p23" 
                             and "p_io p1 = p_io pP" and "p_io p23 = p_io p @ ioX"
               using language_state_split[OF \<open>p_io pP @ p_io p @ ioX \<in> L M\<close>] by blast
         
             have "p1 = pP"
               using observable_path_unique[OF \<open>observable M\<close> \<open>path M (FSM.initial M) p1\<close> \<open>path M (FSM.initial M) pP\<close> \<open>p_io p1 = p_io pP\<close>] 
               by assumption
             then have "path M (target (FSM.initial M) pP) p23"
               using \<open>path M (target (FSM.initial M) p1) p23\<close> by auto
             then have "p_io p @ ioX \<in> LS M (target (initial M) pP)"
               using \<open>p_io p23 = p_io p @ ioX\<close> language_state_containment by auto
         
             obtain p2 p3 where "path M (target (FSM.initial M) pP) p2" 
                            and "path M (target (target (FSM.initial M) pP) p2) p3" 
                            and "p_io p2 = p_io p" 
                            and "p_io p3 = ioX"
               using language_state_split[OF \<open>p_io p @ ioX \<in> LS M (target (initial M) pP)\<close>] 
               by blast
         
             have "p2 = p"
               using observable_path_unique[OF \<open>observable M\<close> \<open>path M (target (FSM.initial M) pP) p2\<close> \<open>path M (target (FSM.initial M) pP) p\<close> \<open>p_io p2 = p_io p\<close>] 
               by assumption
             then have "path M (target (FSM.initial M) pP) (p@p3)"
               using \<open>path M (target (FSM.initial M) pP) p\<close> \<open>path M (target (target (FSM.initial M) pP) p2) p3\<close> 
               by auto
             moreover have "p_io (p@p3) = butlast io"
               unfolding \<open>butlast io = p_io p @ ioX\<close> 
               using \<open>p_io p3 = ioX\<close> 
               by auto
             ultimately show ?thesis 
               using that[of p3] 
               by simp
           qed
 
           (* get index properties *)
 
           have "target (FSM.initial M') pP' \<in> io_targets M' (p_io pP) (FSM.initial M')"
             using \<open>p_io pP' = p_io pP\<close> \<open>path M' (FSM.initial M') pP'\<close> observable_path_io_target by auto 
   
           have "(t_target (p ! (length pR' - 1)), P') \<in> PS"
             using \<open>(q',P') \<in> PS\<close> unfolding \<open>t_target (p ! (length pR' - 1)) = q'\<close> by assumption
           then have "(t_target ((p @ pX) ! ?i), P') \<in> PS"
             by (metis \<open>length pR' - 1 < length p\<close> nth_append)
   
           have "target (FSM.initial P') pP'' = t_target (p ! (length pR' - 1))"
             unfolding \<open>target (initial M) pP'' = q'\<close> \<open>t_target (p ! (length pR' - 1)) = q'\<close> \<open>initial P' = initial M\<close> by simp
           then have "target (FSM.initial P') pP'' = t_target ((p @ pX) ! ?i)"
             by (metis \<open>length pR' - 1 < length p\<close> nth_append)
             
 
           show ?thesis
             using minimal_sequence_to_failure_extending_preamble_no_repetitions_with_other_preambles
                     [OF assms(1,2) \<open>path M (target (initial M) pP) (p@pX)\<close> \<open>p_io (p@pX) = butlast io\<close> 
                         \<open>target (FSM.initial M') pP' \<in> io_targets M' (p_io pP) (FSM.initial M')\<close> 
                         \<open>path M' (target (FSM.initial M') pP') p'\<close> \<open>p_io p' = io\<close> assms(4) 
                         \<open>?i < length (butlast io)\<close> \<open>(t_target ((p @ pX) ! ?i), P') \<in> PS\<close> 
                         \<open>path P' (initial P') pP''\<close> \<open>target (FSM.initial P') pP'' = t_target ((p @ pX) ! ?i)\<close>]
             by blast
         qed
         then show "io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pP'') (initial M') = {}"
           unfolding \<open>io_targets M' (p_io pR1) (initial M') = {t_target (p' ! ?i)}\<close> 
           by blast
       qed
 
 
       fix pR1 pR2 assume "pR1 \<in> ?RP" and "pR2 \<in> ?RP" and "pR1 \<noteq> pR2"
 
       then consider (a) "pR1 \<in> ?R \<and> pR2 \<in> ?R" |
                     (b) "pR1 = pP''" |
                     (c) "pR2 = pP''" 
         using \<open>\<And> pR . pR \<in> ?RP \<Longrightarrow> pR \<in> ?R \<or> pR = pP''\<close> \<open>pR1 \<noteq> pR2\<close> by blast
       then show "io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
       proof cases
         case a
         then show ?thesis using pairwise_dist_prop_R[of pR1 pR2, OF _ _ \<open>pR1 \<noteq> pR2\<close>] by blast
       next
         case b
         then show ?thesis using pairwise_dist_prop_PS[OF \<open>pR2 \<in> ?RP\<close>] \<open>pR1 \<noteq> pR2\<close> by blast
       next
         case c
         then show ?thesis using pairwise_dist_prop_PS[OF \<open>pR1 \<in> ?RP\<close>] \<open>pR1 \<noteq> pR2\<close> by blast
       qed
     qed
     then have ?P3 by blast
 
 
     let ?f = "(\<lambda> pR . io_targets M' (p_io pR) (initial M'))"
   
     have p1: "(\<And>S1 S2. S1 \<in> ?RP \<Longrightarrow> S2 \<in> ?RP \<Longrightarrow> S1 = S2 \<or> ?f S1 \<inter> ?f S2 = {})"
       using pairwise_dist_prop_RP by blast
     have p2: "(\<And>S. S \<in> ?RP \<Longrightarrow> io_targets M' (p_io S) (FSM.initial M') \<noteq> {})"
       using singleton_prop_RP by blast
     have c1: "card ?RP = card ((\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` ?RP)"
       using card_union_of_distinct[of ?RP, OF p1 \<open>finite ?RP\<close> p2] by force
   
     have p3: "(\<And>S. S \<in> (\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` ?RP \<Longrightarrow> \<exists>t. S = {t})"
       using singleton_prop_RP by blast
     have c2:"card ((\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` ?RP) = card (\<Union>S\<in>?RP. io_targets M' (p_io S) (FSM.initial M'))"
       using card_union_of_singletons[of "((\<lambda>S. io_targets M' (p_io S) (FSM.initial M')) ` ?RP)", OF p3] by force
         
     have ?P1
       unfolding c1 c2 by blast
 
     show ?combined_goals 
       using \<open>?P1\<close> \<open>?P2\<close> \<open>?P3\<close> 
       by blast
   qed
 
   
 
   then show "card (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) (RP M (target (initial M) pP) q' pP p PS M'))) = card (RP M (target (initial M) pP) q' pP p PS M')"
        and  "\<And> pR . pR \<in> (RP M (target (initial M) pP) q' pP p PS M') \<Longrightarrow> \<exists> q . io_targets M' (p_io pR) (initial M') = {q}"
        and  "\<And> pR1 pR2 . pR1 \<in> (RP M (target (initial M) pP) q' pP p PS M') \<Longrightarrow> pR2 \<in> (RP M (target (initial M) pP) q' pP p PS M') \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
     by blast+
 qed
 
 
 
 lemma RP_target: 
   assumes "pR \<in> (RP M q q' pP p PS M')" 
   assumes "\<And> q P . (q,P) \<in> PS \<Longrightarrow> is_preamble P M q"
   and     "\<And> q P io x y y' . (q,P) \<in> PS \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P"
   and     "completely_specified M'"
   and     "inputs M' = inputs M"
 shows "target (initial M) pR = q'"
 proof -
   show "target (initial M) pR = q'"
   proof (cases "pR \<in> R M q q' pP p")
     case True
     then show ?thesis unfolding R_def by force
   next
     case False
     then have "RP M q q' pP p PS M' \<noteq> R M q q' pP p"
       using assms(1) by blast
     then have "(\<exists>P' pP'.
         (q', P') \<in> PS \<and>
         path P' (FSM.initial P') pP' \<and>
         target (FSM.initial P') pP' = q' \<and>
         path M (FSM.initial M) pP' \<and> target (FSM.initial M) pP' = q' \<and> p_io pP' \<in> L M' \<and> RP M q q' pP p PS M' = insert pP' (R M q q' pP p))"
       using RP_from_R[OF assms(2-5), of PS _ _ q q' pP p] by force
     then obtain pP' where "target (FSM.initial M) pP' = q'" and "RP M q q' pP p PS M' = insert pP' (R M q q' pP p)"
       by blast
     
     have "pR = pP'"
       using \<open>RP M q q' pP p PS M' = insert pP' (R M q q' pP p)\<close> \<open>pR \<in> (RP M q q' pP p PS M')\<close> False by blast
 
     show ?thesis using \<open>target (FSM.initial M) pP' = q'\<close> unfolding \<open>pR = pP'\<close> by assumption
   qed
 qed 
 
 
 subsubsection \<open>Proof of Exhaustiveness\<close>
 
 lemma passes_test_suite_exhaustiveness_helper_1 :
   assumes "completely_specified M'"
   and     "inputs M' = inputs M"
   and     "observable M"
   and     "observable M'"
   and     "(q,P) \<in> PS"
   and     "path P (initial P) pP"
   and     "target (initial P) pP = q"
   and     "p_io pP @ p_io p \<in> L M'"  
   and     "(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m"
   and     "implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets"
   and     "passes_test_suite M (Test_Suite PS tps rd_targets separators) M'"
   and     "q' \<noteq> q''"
   and     "q' \<in> fst d"
   and     "q'' \<in> fst d"
   and     "pR1 \<in> (RP M q q' pP p PS M')"
   and     "pR2 \<in> (RP M q q'' pP p PS M')"
 shows "io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
 proof -
 
   let ?RP1 = "(RP M q q' pP p PS M')"
   let ?RP2 = "(RP M q q'' pP p PS M')"
   let ?R1  = "(R M q q' pP p)"
   let ?R2  = "(R M q q'' pP p)"
 
   (* sufficiency properties *)
 
 
   have t1: "(initial M, initial_preamble M) \<in> PS" 
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps by blast
   have t2: "\<And> q P. (q, P) \<in> PS \<Longrightarrow> is_preamble P M q"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps by force
   have t3: "\<And> q1 q2 A d1 d2. (A, d1, d2) \<in> separators (q1, q2) \<Longrightarrow> (A, d2, d1) \<in> separators (q2, q1) \<and> is_separator M q1 q2 A d1 d2"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps by force  
 
 
   have t5: "\<And>q. q \<in> FSM.states M \<Longrightarrow> (\<exists>d\<in>set repetition_sets. q \<in> fst d)"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps by force
 
   have t6: "\<And> q. q \<in> fst ` PS \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps by auto
 
   have "\<And> d. d \<in> set repetition_sets \<Longrightarrow> fst d \<subseteq> FSM.states M \<and> snd d = fst d \<inter> fst ` PS \<and> (\<forall>q1 q2. q1 \<in> fst d \<longrightarrow> q2 \<in> fst d \<longrightarrow> q1 \<noteq> q2 \<longrightarrow> separators (q1, q2) \<noteq> {})"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps by force
   then have t7: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> fst d \<subseteq> FSM.states M"
   and  t8: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d \<subseteq> fst d"
   and  t8': "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d = fst d \<inter> fst ` PS"
   and  t9: "\<And> d q1 q2. d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> separators (q1, q2) \<noteq> {}"
     by blast+
 
   have t10: "\<And> q p d p1 p2 p3.
               q \<in> fst ` PS \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               p = p1 @ p2 @ p3 \<Longrightarrow>
               p2 \<noteq> [] \<Longrightarrow>
               target q p1 \<in> fst d \<Longrightarrow>
               target q (p1 @ p2) \<in> fst d \<Longrightarrow>
               target q p1 \<noteq> target q (p1 @ p2) \<Longrightarrow>
               p1 \<in> tps q \<and> p1 @ p2 \<in> tps q \<and> target q p1 \<in> rd_targets (q, p1 @ p2) \<and> target q (p1 @ p2) \<in> rd_targets (q, p1)"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps
     by (metis (no_types, lifting)) 
 
   have t11: "\<And> q p d p1 p2 q'.
               q \<in> fst ` PS \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               p = p1 @ p2 \<Longrightarrow>
               q' \<in> fst ` PS \<Longrightarrow>
               target q p1 \<in> fst d \<Longrightarrow>
               q' \<in> fst d \<Longrightarrow> 
               target q p1 \<noteq> q' \<Longrightarrow> 
               p1 \<in> tps q \<and> [] \<in> tps q' \<and> target q p1 \<in> rd_targets (q', []) \<and> q' \<in> rd_targets (q, p1)"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps
     by (metis (no_types, lifting)) 
 
   have t12: "\<And> q p d q1 q2.
               q \<in> fst ` PS \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               q1 \<noteq> q2 \<Longrightarrow>
               q1 \<in> snd d \<Longrightarrow> 
               q2 \<in> snd d \<Longrightarrow> 
               [] \<in> tps q1 \<and> [] \<in> tps q2 \<and> q1 \<in> rd_targets (q2, []) \<and> q2 \<in> rd_targets (q1, [])"
     using \<open>implies_completeness_for_repetition_sets (Test_Suite PS tps rd_targets separators) M m repetition_sets\<close> 
     unfolding implies_completeness_for_repetition_sets.simps
     by (metis (no_types, lifting)) 
 
 
   (* pass properties *)
 
   have pass1: "\<And> q P io x y y' . (q,P) \<in> PS \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P" 
     using \<open>passes_test_suite M (Test_Suite PS tps rd_targets separators) M'\<close>
     unfolding passes_test_suite.simps
     by meson 
 
   have pass2: "\<And> q P pP ioT pT x y y' . (q,P) \<in> PS \<Longrightarrow> path P (initial P) pP \<Longrightarrow> target (initial P) pP = q \<Longrightarrow> pT \<in> tps q \<Longrightarrow> ioT@[(x,y)] \<in> set (prefixes (p_io pT)) \<Longrightarrow> (p_io pP)@ioT@[(x,y')] \<in> L M' \<Longrightarrow> (\<exists> pT' . pT' \<in> tps q \<and> ioT@[(x,y')] \<in> set (prefixes (p_io pT')))"
     using \<open>passes_test_suite M (Test_Suite PS tps rd_targets separators) M'\<close>
     unfolding passes_test_suite.simps by blast
 
   have pass3: "\<And> q P pP pT q' A d1 d2 qT . (q,P) \<in> PS \<Longrightarrow> path P (initial P) pP \<Longrightarrow> target (initial P) pP = q \<Longrightarrow> pT \<in> tps q \<Longrightarrow> (p_io pP)@(p_io pT) \<in> L M' \<Longrightarrow> q' \<in> rd_targets (q,pT) \<Longrightarrow> (A,d1,d2) \<in> separators (target q pT, q') \<Longrightarrow> qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M') \<Longrightarrow> pass_separator_ATC M' A qT d2"  
     using \<open>passes_test_suite M (Test_Suite PS tps rd_targets separators) M'\<close>
     unfolding passes_test_suite.simps by blast
 
 
   (* additional props *)
 
   have "is_preamble P M q"
     using \<open>(q,P) \<in> PS\<close> \<open>\<And> q P. (q, P) \<in> PS \<Longrightarrow> is_preamble P M q\<close> 
     by blast
   then have "q \<in> states M"
     unfolding is_preamble_def
     by (metis \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> path_target_is_state submachine_path) 
 
   have "initial P = initial M"
     using \<open>is_preamble P M q\<close> unfolding is_preamble_def
     by auto
   have "path M (initial M) pP"
     using \<open>is_preamble P M q\<close> submachine_path_initial \<open>path P (FSM.initial P) pP\<close> 
     unfolding is_preamble_def  
     by blast
   moreover have "target (initial M) pP = q"
     using \<open>target (initial P) pP = q\<close> 
     unfolding \<open>initial P = initial M\<close> 
     by assumption
   ultimately have "q \<in> states M"
     using path_target_is_state 
     by metis
 
 
   have "q \<in> fst ` PS"
     using \<open>(q,P) \<in> PS\<close> by force
 
   have "d \<in> set repetition_sets" 
     using \<open>(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close> 
     using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m]
     using find_set by force
 
   have "q' \<in> states M"
     by (meson \<open>d \<in> set repetition_sets\<close> assms(13) subset_iff t7)
   have "q'' \<in> states M"
     by (meson \<open>d \<in> set repetition_sets\<close> assms(14) subset_iff t7)
 
 
   have "target (initial M) pR1 = q'"
     using RP_target[OF \<open>pR1 \<in> ?RP1\<close> t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>] by force
   then have "target (initial M) pR1 \<in> fst d"
     using \<open>q' \<in> fst d\<close> by blast
     
 
   have "target (initial M) pR2 = q''"
     using RP_target[OF \<open>pR2 \<in> ?RP2\<close> t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>] by force
   then have "target (initial M) pR2 \<in> fst d"
     using \<open>q'' \<in> fst d\<close> by blast
 
   have "pR1 \<noteq> pR2"
     using \<open>target (initial M) pR1 = q'\<close> \<open>target (initial M) pR2 = q''\<close> \<open>q' \<noteq> q''\<close> by auto
 
 
   obtain A t1 t2 where "(A,t1,t2) \<in> separators (q',q'')"
     using t9[OF \<open>d \<in> set repetition_sets\<close> \<open>q' \<in> fst d\<close> \<open>q'' \<in> fst d\<close> \<open>q' \<noteq> q''\<close>]
     by auto
   have "(A,t2,t1) \<in> separators (q'',q')" and "is_separator M q' q'' A t1 t2"
     using t3[OF \<open>(A,t1,t2) \<in> separators (q',q'')\<close>] by simp+
   then have "is_separator M q'' q' A t2 t1"
     using is_separator_sym by force
 
   show "io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}" 
   proof (rule ccontr) 
     assume "io_targets M' (p_io pR1) (FSM.initial M') \<inter> io_targets M' (p_io pR2) (FSM.initial M') \<noteq> {}"
     then obtain qT where "qT \<in> io_targets M' (p_io pR1) (FSM.initial M')"
                    and   "qT \<in> io_targets M' (p_io pR2) (FSM.initial M')"
       by blast
 
     then have "qT \<in> states M'"
       using path_target_is_state unfolding io_targets.simps by force
 
     consider (a) "pR1 \<in> ?R1 \<and> pR2 \<in> ?R2" |
              (b) "pR1 \<in> ?R1 \<and> pR2 \<notin> ?R2" |
              (c) "pR1 \<notin> ?R1 \<and> pR2 \<in> ?R2" |
              (d) "pR1 \<notin> ?R1 \<and> pR2 \<notin> ?R2"
       by blast
 
     then show "False" proof cases
       case a
       then have "pR1 \<in> ?R1" and "pR2 \<in> ?R2" by auto
                 
       obtain pR1' where "pR1 = pP@pR1'" using R_component_ob[OF \<open>pR1 \<in> ?R1\<close>] by blast
       obtain pR2' where "pR2 = pP@pR2'" using R_component_ob[OF \<open>pR2 \<in> ?R2\<close>] by blast
 
       have "pR1' = take (length pR1') p" and "length pR1' \<le> length p" and "t_target (p ! (length pR1' - 1)) = q'" and "pR1' \<noteq> []"
         using R_component[of pP pR1' M q q' p] \<open>pR1 \<in> ?R1\<close> unfolding \<open>pR1 = pP@pR1'\<close> by blast+ 
 
       have "pR2' = take (length pR2') p" and "length pR2' \<le> length p" and "t_target (p ! (length pR2' - 1)) = q''" and "pR2' \<noteq> []"
         using R_component[of pP pR2' M q q'' p] \<open>pR2 \<in> ?R2\<close> unfolding \<open>pR2 = pP@pR2'\<close> by blast+ 
 
       have "target q pR1' = q'"
         using \<open>target (initial M) pR1 = q'\<close> \<open>pR1' \<noteq> []\<close> unfolding target.simps visited_states.simps \<open>pR1 = pP@pR1'\<close> by simp 
       then have "target q pR1' \<in> fst d"
         using \<open>q' \<in> fst d\<close> by blast
 
       have "target q pR2' = q''"
         using \<open>target (initial M) pR2 = q''\<close> \<open>pR2' \<noteq> []\<close> unfolding target.simps visited_states.simps \<open>pR2 = pP@pR2'\<close> by simp 
       then have "target q pR2' \<in> fst d"
         using \<open>q'' \<in> fst d\<close> by blast
 
       have "pR1' \<noteq> pR2'"
         using \<open>pR1 \<noteq> pR2\<close> unfolding \<open>pR1 = pP@pR1'\<close> \<open>pR2 = pP@pR2'\<close> by simp
       then have "length pR1' \<noteq> length pR2'"
         using \<open>pR1' = take (length pR1') p\<close> \<open>pR2' = take (length pR2') p\<close> by auto
       then consider (a1) "length pR1' < length pR2'" | (a2) "length pR2' < length pR1'"
         using nat_neq_iff by blast 
       then have "pR1' \<in> tps q \<and> pR2' \<in> tps q \<and> q' \<in> rd_targets (q, pR2') \<and> q'' \<in> rd_targets (q, pR1')"
       proof cases
         case a1
         then have "pR2' = pR1' @ (drop (length pR1') pR2')"
           using \<open>pR1' = take (length pR1') p\<close> \<open>pR2' = take (length pR2') p\<close>
           by (metis append_take_drop_id less_imp_le_nat take_le) 
         then have "p = pR1' @ (drop (length pR1') pR2') @ (drop (length pR2') p)"
           using \<open>pR2' = take (length pR2') p\<close>
           by (metis append.assoc append_take_drop_id)
 
         have "(drop (length pR1') pR2') \<noteq> []"
           using a1 \<open>pR2' = take (length pR2') p\<close> by auto
         have "target q (pR1' @ drop (length pR1') pR2') \<in> fst d"
           using \<open>pR2' = pR1' @ (drop (length pR1') pR2')\<close>[symmetric] \<open>target q pR2' \<in> fst d\<close> by auto
 
         show ?thesis
           using t10[OF \<open>q \<in> fst ` PS\<close> \<open>(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close> 
                        \<open>p = pR1' @ (drop (length pR1') pR2') @ (drop (length pR2') p)\<close> 
                        \<open>(drop (length pR1') pR2') \<noteq> []\<close> \<open>target q pR1' \<in> fst d\<close> 
                        \<open>target q (pR1' @ drop (length pR1') pR2') \<in> fst d\<close>]
           unfolding \<open>pR2' = pR1' @ (drop (length pR1') pR2')\<close>[symmetric] \<open>target q pR1' = q'\<close>  \<open>target q pR2' = q''\<close>
           using \<open>q' \<noteq> q''\<close>
           by blast
       next
         case a2
         then have "pR1' = pR2' @ (drop (length pR2') pR1')"
           using \<open>pR1' = take (length pR1') p\<close> \<open>pR2' = take (length pR2') p\<close>
           by (metis append_take_drop_id less_imp_le_nat take_le) 
         then have "p = pR2' @ (drop (length pR2') pR1') @ (drop (length pR1') p)"
           using \<open>pR1' = take (length pR1') p\<close>
           by (metis append.assoc append_take_drop_id)
 
         have "(drop (length pR2') pR1') \<noteq> []"
           using a2 \<open>pR1' = take (length pR1') p\<close> by auto
         have "target q (pR2' @ drop (length pR2') pR1') \<in> fst d"
           using \<open>pR1' = pR2' @ (drop (length pR2') pR1')\<close>[symmetric] \<open>target q pR1' \<in> fst d\<close> by auto
 
         show ?thesis
           using t10[OF \<open>q \<in> fst ` PS\<close> \<open>(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close>
                        \<open>p = pR2' @ (drop (length pR2') pR1') @ (drop (length pR1') p)\<close> 
                        \<open>(drop (length pR2') pR1') \<noteq> []\<close> \<open>target q pR2' \<in> fst d\<close> 
                        \<open>target q (pR2' @ drop (length pR2') pR1') \<in> fst d\<close>]
           unfolding \<open>pR1' = pR2' @ (drop (length pR2') pR1')\<close>[symmetric] \<open>target q pR1' = q'\<close> \<open>target q pR2' = q''\<close>
           using \<open>q' \<noteq> q''\<close>
           by blast
       qed 
       then have "pR1' \<in> tps q" and "pR2' \<in> tps q" and "q' \<in> rd_targets (q, pR2')" and "q'' \<in> rd_targets (q, pR1')"
         by simp+
 
       
 
       have "p_io pP @ p_io pR1' \<in> L M'"
         using language_prefix_append[OF \<open>p_io pP @ p_io p \<in> L M'\<close>, of "length pR1'"]
         using \<open>pR1' = take (length pR1') p\<close> by simp
       have "pass_separator_ATC M' A qT t2"
         using pass3[OF \<open>(q, P) \<in> PS\<close> \<open>path P (initial P) pP\<close> \<open>target (initial P) pP = q\<close> \<open>pR1' \<in> tps q\<close> 
                        \<open>p_io pP @ p_io pR1' \<in> L M'\<close> \<open>q'' \<in> rd_targets (q, pR1')\<close>, of A t1 t2]
               \<open>(A, t1, t2) \<in> separators (q', q'')\<close> \<open>qT \<in> io_targets M' (p_io pR1) (FSM.initial M')\<close> 
         unfolding \<open>target q pR1' = q'\<close> \<open>pR1 = pP @ pR1'\<close> by auto
 
 
       have "p_io pP @ p_io pR2' \<in> L M'"
         using language_prefix_append[OF \<open>p_io pP @ p_io p \<in> L M'\<close>, of "length pR2'"]
         using \<open>pR2' = take (length pR2') p\<close> by simp
       have "pass_separator_ATC M' A qT t1"
         using pass3[OF \<open>(q, P) \<in> PS\<close> \<open>path P (initial P) pP\<close> \<open>target (initial P) pP = q\<close> \<open>pR2' \<in> tps q\<close>
                        \<open>p_io pP @ p_io pR2' \<in> L M'\<close> \<open>q' \<in> rd_targets (q, pR2')\<close>, of A t2 t1]
               \<open>(A, t2, t1) \<in> separators (q'', q')\<close> \<open>qT \<in> io_targets M' (p_io pR2) (FSM.initial M')\<close> 
         unfolding \<open>target q pR2' = q''\<close> \<open>pR2 = pP @ pR2'\<close> by auto
 
       (* the state qT reached by both paths cannot satisfy the ATC that r-distinguishes their respective targets for both targets at the same time *)
 
       have "qT \<noteq> qT"
         using pass_separator_ATC_reduction_distinction[OF \<open>observable M\<close> \<open>observable M'\<close> \<open>inputs M' = inputs M\<close> \<open>pass_separator_ATC M' A qT t2\<close> \<open>pass_separator_ATC M' A qT t1\<close> \<open>q' \<in> states M\<close> \<open>q'' \<in> states M\<close> \<open>q' \<noteq> q''\<close> \<open>qT \<in> states M'\<close> \<open>qT \<in> states M'\<close> \<open>is_separator M q' q'' A t1 t2\<close> \<open>completely_specified M'\<close>]
         by assumption
       then show False
         by simp
 
     next
       case b
 
       then have "pR1 \<in> ?R1" and "pR2 \<notin> ?R2"
         using \<open>pR1 \<in> ?RP1\<close> by auto
                 
       obtain pR1' where "pR1 = pP@pR1'" using R_component_ob[OF \<open>pR1 \<in> ?R1\<close>] by blast
       
 
       have "pR1' = take (length pR1') p" and "length pR1' \<le> length p" and "t_target (p ! (length pR1' - 1)) = q'" and "pR1' \<noteq> []"
         using R_component[of pP pR1' M q q' p] \<open>pR1 \<in> ?R1\<close> unfolding \<open>pR1 = pP@pR1'\<close> by blast+ 
 
       have "target q pR1' = q'"
         using \<open>target (initial M) pR1 = q'\<close> \<open>pR1' \<noteq> []\<close> unfolding target.simps visited_states.simps \<open>pR1 = pP@pR1'\<close> by simp 
       then have "target q pR1' \<in> fst d" and "target q pR1' \<noteq> q''"
         using \<open>q' \<in> fst d\<close> \<open>q' \<noteq> q''\<close> by blast+
 
 
       obtain P' where "(q'', P') \<in> PS"
                       "path P' (FSM.initial P') pR2"
                       "target (FSM.initial P') pR2 = q''"
                       "path M (FSM.initial M) pR2" 
                       "target (FSM.initial M) pR2 = q''" 
                       "p_io pR2 \<in> L M'"
                       "RP M q q'' pP p PS M' = insert pR2 (R M q q'' pP p)"
         using RP_from_R_inserted[OF t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close> \<open>pR2 \<in> ?RP2\<close> \<open>pR2 \<notin> ?R2\<close>, 
                                  of "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y"] 
         by blast
 
 
       
       have "q'' \<in> fst ` PS" using \<open>(q'',P') \<in> PS\<close> by force
       have "p = pR1' @ (drop (length pR1') p)" using \<open>pR1' = take (length pR1') p\<close>
         by (metis append_take_drop_id)
 
       have "pR1' \<in> tps q" and "[] \<in> tps q''" and "target q pR1' \<in> rd_targets (q'', [])" and "q'' \<in> rd_targets (q, pR1')"
         using t11[OF \<open>q \<in> fst ` PS\<close> \<open>(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close>
                      \<open>p = pR1' @ (drop (length pR1') p)\<close> \<open>q'' \<in> fst ` PS\<close> 
                      \<open>target q pR1' \<in> fst d\<close> \<open>q'' \<in> fst d\<close> \<open>target q pR1' \<noteq> q''\<close>]
         by simp+
 
 
       have "p_io pP @ p_io pR1' \<in> L M'"
         using language_prefix_append[OF \<open>p_io pP @ p_io p \<in> L M'\<close>, of "length pR1'"]
         using \<open>pR1' = take (length pR1') p\<close> by simp
       have "pass_separator_ATC M' A qT t2"
         using pass3[OF \<open>(q, P) \<in> PS\<close> \<open>path P (initial P) pP\<close> \<open>target (initial P) pP = q\<close> \<open>pR1' \<in> tps q\<close> 
                        \<open>p_io pP @ p_io pR1' \<in> L M'\<close> \<open>q'' \<in> rd_targets (q, pR1')\<close>, of A t1 t2]
               \<open>(A, t1, t2) \<in> separators (q', q'')\<close> \<open>qT \<in> io_targets M' (p_io pR1) (FSM.initial M')\<close> 
         unfolding \<open>target q pR1' = q'\<close> \<open>pR1 = pP @ pR1'\<close> by auto
 
       have "pass_separator_ATC M' A qT t1"
         using pass3[OF \<open>(q'', P') \<in> PS\<close> \<open>path P' (FSM.initial P') pR2\<close> \<open>target (FSM.initial P') pR2 = q''\<close> 
                        \<open>[] \<in> tps q''\<close> _ \<open>target q pR1' \<in> rd_targets (q'', [])\<close>, of A t2 t1 qT]
               \<open>(A, t2, t1) \<in> separators (q'', q')\<close> \<open>qT \<in> io_targets M' (p_io pR2) (FSM.initial M')\<close> \<open>p_io pR2 \<in> L M'\<close>
         unfolding \<open>target q pR1' = q'\<close> by auto
 
       have "qT \<noteq> qT"
         using pass_separator_ATC_reduction_distinction[OF \<open>observable M\<close> \<open>observable M'\<close> \<open>inputs M' = inputs M\<close> 
                                                           \<open>pass_separator_ATC M' A qT t2\<close> 
                                                           \<open>pass_separator_ATC M' A qT t1\<close> \<open>q' \<in> states M\<close> 
                                                           \<open>q'' \<in> states M\<close> \<open>q' \<noteq> q''\<close> \<open>qT \<in> states M'\<close> 
                                                           \<open>qT \<in> states M'\<close> \<open>is_separator M q' q'' A t1 t2\<close> 
                                                           \<open>completely_specified M'\<close>]
         by assumption
       then show False
         by simp
     next
       case c
       then have "pR2 \<in> ?R2" and "pR1 \<notin> ?R1"
         using \<open>pR2 \<in> ?RP2\<close> by auto
                 
       obtain pR2' where "pR2 = pP@pR2'" using R_component_ob[OF \<open>pR2 \<in> ?R2\<close>] by blast
       
 
       have "pR2' = take (length pR2') p" 
        and "length pR2' \<le> length p" 
        and "t_target (p ! (length pR2' - 1)) = q''" 
        and "pR2' \<noteq> []"
         using R_component[of pP pR2' M q q'' p] \<open>pR2 \<in> ?R2\<close> 
         unfolding \<open>pR2 = pP@pR2'\<close> 
         by blast+ 
 
       have "target q pR2' = q''"
         using \<open>target (initial M) pR2 = q''\<close> \<open>pR2' \<noteq> []\<close> 
         unfolding target.simps visited_states.simps \<open>pR2 = pP@pR2'\<close>
         by simp 
       then have "target q pR2' \<in> fst d" and "target q pR2' \<noteq> q'"
         using \<open>q'' \<in> fst d\<close> \<open>q' \<noteq> q''\<close> by blast+
 
 
       obtain P' where "(q', P') \<in> PS"
                       "path P' (FSM.initial P') pR1"
                       "target (FSM.initial P') pR1 = q'"
                       "path M (FSM.initial M) pR1" 
                       "target (FSM.initial M) pR1 = q'" 
                       "p_io pR1 \<in> L M'"
                       "RP M q q' pP p PS M' = insert pR1 (R M q q' pP p)"
         using RP_from_R_inserted[OF t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close> \<open>pR1 \<in> ?RP1\<close> \<open>pR1 \<notin> ?R1\<close>, 
                                  of "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y"] 
         by blast
 
       
       have "q' \<in> fst ` PS" using \<open>(q',P') \<in> PS\<close> by force
       have "p = pR2' @ (drop (length pR2') p)" using \<open>pR2' = take (length pR2') p\<close>
         by (metis append_take_drop_id)
 
       have "pR2' \<in> tps q" and "[] \<in> tps q'" and "target q pR2' \<in> rd_targets (q', [])" and "q' \<in> rd_targets (q, pR2')"
         using t11[OF \<open>q \<in> fst ` PS\<close> \<open>(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close> 
                      \<open>p = pR2' @ (drop (length pR2') p)\<close> \<open>q' \<in> fst ` PS\<close> \<open>target q pR2' \<in> fst d\<close> 
                      \<open>q' \<in> fst d\<close> \<open>target q pR2' \<noteq> q'\<close>]
         by simp+
 
 
       have "p_io pP @ p_io pR2' \<in> L M'"
         using language_prefix_append[OF \<open>p_io pP @ p_io p \<in> L M'\<close>, of "length pR2'"]
         using \<open>pR2' = take (length pR2') p\<close> by simp
       have "pass_separator_ATC M' A qT t1"
         using pass3[OF \<open>(q, P) \<in> PS\<close> \<open>path P (initial P) pP\<close> \<open>target (initial P) pP = q\<close> \<open>pR2' \<in> tps q\<close> 
                        \<open>p_io pP @ p_io pR2' \<in> L M'\<close> \<open>q' \<in> rd_targets (q, pR2')\<close>, of A t2 t1]
               \<open>(A, t2, t1) \<in> separators (q'', q')\<close> \<open>qT \<in> io_targets M' (p_io pR2) (FSM.initial M')\<close> 
         unfolding \<open>target q pR2' = q''\<close> \<open>pR2 = pP @ pR2'\<close> by auto
 
       have "pass_separator_ATC M' A qT t2"
         using pass3[OF \<open>(q', P') \<in> PS\<close> \<open>path P' (FSM.initial P') pR1\<close> \<open>target (FSM.initial P') pR1 = q'\<close> 
                        \<open>[] \<in> tps q'\<close> _ \<open>target q pR2' \<in> rd_targets (q', [])\<close>, of A t1 t2 qT]
               \<open>(A, t1, t2) \<in> separators (q', q'')\<close> \<open>qT \<in> io_targets M' (p_io pR1) (FSM.initial M')\<close> \<open>p_io pR1 \<in> L M'\<close>
         unfolding \<open>target q pR2' = q''\<close> by auto
 
       have "qT \<noteq> qT"
         using pass_separator_ATC_reduction_distinction[OF \<open>observable M\<close> \<open>observable M'\<close> \<open>inputs M' = inputs M\<close>
                                                           \<open>pass_separator_ATC M' A qT t1\<close> \<open>pass_separator_ATC M' A qT t2\<close> 
                                                           \<open>q'' \<in> states M\<close> \<open>q' \<in> states M\<close> _ \<open>qT \<in> states M'\<close> \<open>qT \<in> states M'\<close> 
                                                           \<open>is_separator M q'' q' A t2 t1\<close> \<open>completely_specified M'\<close>]
               \<open>q' \<noteq> q''\<close> by simp
       then show False
         by simp
     next
       case d
 
       then have "pR1 \<notin> ?R1" and "pR2 \<notin> ?R2"
         by auto
                 
       obtain P' where "(q', P') \<in> PS"
                       "path P' (FSM.initial P') pR1"
                       "target (FSM.initial P') pR1 = q'"
                       "path M (FSM.initial M) pR1" 
                       "target (FSM.initial M) pR1 = q'" 
                       "p_io pR1 \<in> L M'"
                       "RP M q q' pP p PS M' = insert pR1 (R M q q' pP p)"
         using RP_from_R_inserted[OF t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close> 
                                     \<open>pR1 \<in> ?RP1\<close> \<open>pR1 \<notin> ?R1\<close>, of "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y"] 
         by blast
 
       have "q' \<in> snd d"
         by (metis IntI \<open>(q', P') \<in> PS\<close> \<open>d \<in> set repetition_sets\<close> assms(13) fst_eqD image_eqI t8')
 
       obtain P'' where "(q'', P'') \<in> PS"
                       "path P'' (FSM.initial P'') pR2"
                       "target (FSM.initial P'') pR2 = q''"
                       "path M (FSM.initial M) pR2" 
                       "target (FSM.initial M) pR2 = q''" 
                       "p_io pR2 \<in> L M'"
                       "RP M q q'' pP p PS M' = insert pR2 (R M q q'' pP p)"
         using RP_from_R_inserted[OF t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close> \<open>pR2 \<in> ?RP2\<close> \<open>pR2 \<notin> ?R2\<close>, 
                                  of "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y"] 
         by blast
 
       have "q'' \<in> snd d"
         by (metis IntI \<open>(q'', P'') \<in> PS\<close> \<open>d \<in> set repetition_sets\<close> assms(14) fst_eqD image_eqI t8')
 
       have "[] \<in> tps q'" and "[] \<in> tps q''" and "q' \<in> rd_targets (q'', [])" and "q'' \<in> rd_targets (q', [])"
         using t12[OF \<open>q \<in> fst ` PS\<close> \<open>(p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close> \<open>q' \<noteq> q''\<close> \<open>q' \<in> snd d\<close> \<open>q'' \<in> snd d\<close>]
         by simp+
 
 
       have "pass_separator_ATC M' A qT t1"
         using pass3[OF \<open>(q'', P'') \<in> PS\<close> \<open>path P'' (initial P'') pR2\<close> \<open>target (initial P'') pR2 = q''\<close> 
                        \<open>[] \<in> tps q''\<close> _ \<open>q' \<in> rd_targets (q'', [])\<close>, of A t2 t1 qT]
               \<open>p_io pR2 \<in> L M'\<close> \<open>(A, t2, t1) \<in> separators (q'', q')\<close> \<open>qT \<in> io_targets M' (p_io pR2) (FSM.initial M')\<close> 
         by auto
       
       have "pass_separator_ATC M' A qT t2"
         using pass3[OF \<open>(q', P') \<in> PS\<close> \<open>path P' (initial P') pR1\<close> \<open>target (initial P') pR1 = q'\<close> 
                        \<open>[] \<in> tps q'\<close> _ \<open>q'' \<in> rd_targets (q', [])\<close>, of A t1 t2 qT]
               \<open>p_io pR1 \<in> L M'\<close> \<open>(A, t1, t2) \<in> separators (q', q'')\<close> \<open>qT \<in> io_targets M' (p_io pR1) (FSM.initial M')\<close> 
         by auto
 
       have "qT \<noteq> qT"
         using pass_separator_ATC_reduction_distinction[OF \<open>observable M\<close> \<open>observable M'\<close> 
                                                           \<open>inputs M' = inputs M\<close> \<open>pass_separator_ATC M' A qT t1\<close>
                                                           \<open>pass_separator_ATC M' A qT t2\<close> \<open>q'' \<in> states M\<close> 
                                                           \<open>q' \<in> states M\<close> _ \<open>qT \<in> states M'\<close> \<open>qT \<in> states M'\<close> 
                                                           \<open>is_separator M q'' q' A t2 t1\<close> \<open>completely_specified M'\<close>]
               \<open>q' \<noteq> q''\<close> by simp
       then show False
         by simp
     qed
   qed
 qed
 
 
 
 
 lemma passes_test_suite_exhaustiveness :
   assumes "passes_test_suite M (Test_Suite prs tps rd_targets separators) M'"
   and     "implies_completeness (Test_Suite prs tps rd_targets separators) M m"
   and     "observable M" 
   and     "observable M'"
   and     "inputs M' = inputs M"
   and     "inputs M \<noteq> {}"
   and     "completely_specified M"
   and     "completely_specified M'"
   and     "size M' \<le> m"
 shows     "L M' \<subseteq> L M"
 proof (rule ccontr)
   assume "\<not> L M' \<subseteq> L M"
 
   (* sufficiency properties *)
 
   obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets separators) M m repetition_sets"
     using assms(2) unfolding implies_completeness_def by blast
 
 
   have t1: "(initial M, initial_preamble M) \<in> prs" 
     using implies_completeness_for_repetition_sets_simps(1)[OF repetition_sets_def] 
     by assumption
   have t2: "\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q"
     using implies_completeness_for_repetition_sets_simps(2)[OF repetition_sets_def] 
     by blast
   have t3: "\<And> q1 q2 A d1 d2. (A, d1, d2) \<in> separators (q1, q2) \<Longrightarrow> (A, d2, d1) \<in> separators (q2, q1) \<and> is_separator M q1 q2 A d1 d2"
     using implies_completeness_for_repetition_sets_simps(3)[OF repetition_sets_def] 
     by assumption
   have t5: "\<And>q. q \<in> FSM.states M \<Longrightarrow> (\<exists>d\<in>set repetition_sets. q \<in> fst d)"
     using implies_completeness_for_repetition_sets_simps(4)[OF repetition_sets_def]
     by assumption
   have t6: "\<And> q. q \<in> fst ` prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using implies_completeness_for_repetition_sets_simps(7)[OF repetition_sets_def] 
     by assumption
 
   have t7: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> fst d \<subseteq> FSM.states M"
   and  t8: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d \<subseteq> fst d"
   and  t8':  "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d = fst d \<inter> fst ` prs"
   and  t9: "\<And> d q1 q2. d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> separators (q1, q2) \<noteq> {}"
     using implies_completeness_for_repetition_sets_simps(5,6)[OF repetition_sets_def] 
     by blast+
 
   have t10: "\<And> q p d p1 p2 p3.
               q \<in> fst ` prs \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               p = p1 @ p2 @ p3 \<Longrightarrow>
               p2 \<noteq> [] \<Longrightarrow>
               target q p1 \<in> fst d \<Longrightarrow>
               target q (p1 @ p2) \<in> fst d \<Longrightarrow>
               target q p1 \<noteq> target q (p1 @ p2) \<Longrightarrow>
               p1 \<in> tps q \<and> p1 @ p2 \<in> tps q \<and> target q p1 \<in> rd_targets (q, p1 @ p2) \<and> target q (p1 @ p2) \<in> rd_targets (q, p1)"
     using implies_completeness_for_repetition_sets_simps(8)[OF repetition_sets_def] by assumption
 
   have t11: "\<And> q p d p1 p2 q'.
               q \<in> fst ` prs \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               p = p1 @ p2 \<Longrightarrow>
               q' \<in> fst ` prs \<Longrightarrow>
               target q p1 \<in> fst d \<Longrightarrow>
               q' \<in> fst d \<Longrightarrow> 
               target q p1 \<noteq> q' \<Longrightarrow> 
               p1 \<in> tps q \<and> [] \<in> tps q' \<and> target q p1 \<in> rd_targets (q', []) \<and> q' \<in> rd_targets (q, p1)"
     using implies_completeness_for_repetition_sets_simps(9)[OF repetition_sets_def] by assumption
   
   have t12: "\<And> q p d q1 q2.
               q \<in> fst ` prs \<Longrightarrow>
               (p, d) \<in> m_traversal_paths_with_witness M q repetition_sets m \<Longrightarrow>
               q1 \<noteq> q2 \<Longrightarrow>
               q1 \<in> snd d \<Longrightarrow> 
               q2 \<in> snd d \<Longrightarrow> 
               [] \<in> tps q1 \<and> [] \<in> tps q2 \<and> q1 \<in> rd_targets (q2, []) \<and> q2 \<in> rd_targets (q1, [])"
     using implies_completeness_for_repetition_sets_simps(10)[OF repetition_sets_def] by assumption
   
 
 
   (* pass properties *)
 
   have pass1: "\<And> q P io x y y' . (q,P) \<in> prs \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P" 
     using \<open>passes_test_suite M (Test_Suite prs tps rd_targets separators) M'\<close>
     unfolding passes_test_suite.simps
     by meson 
 
   have pass2: "\<And> q P pP ioT pT x y y' . (q,P) \<in> prs \<Longrightarrow> path P (initial P) pP \<Longrightarrow> target (initial P) pP = q \<Longrightarrow> pT \<in> tps q \<Longrightarrow> ioT@[(x,y)] \<in> set (prefixes (p_io pT)) \<Longrightarrow> (p_io pP)@ioT@[(x,y')] \<in> L M' \<Longrightarrow> (\<exists> pT' . pT' \<in> tps q \<and> ioT@[(x,y')] \<in> set (prefixes (p_io pT')))"
     using \<open>passes_test_suite M (Test_Suite prs tps rd_targets separators) M'\<close>
     unfolding passes_test_suite.simps 
     by blast
 
   have pass3: "\<And> q P pP pT q' A d1 d2 qT . (q,P) \<in> prs \<Longrightarrow> path P (initial P) pP \<Longrightarrow> target (initial P) pP = q \<Longrightarrow> pT \<in> tps q \<Longrightarrow> (p_io pP)@(p_io pT) \<in> L M' \<Longrightarrow> q' \<in> rd_targets (q,pT) \<Longrightarrow> (A,d1,d2) \<in> separators (target q pT, q') \<Longrightarrow> qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M') \<Longrightarrow> pass_separator_ATC M' A qT d2"  
     using \<open>passes_test_suite M (Test_Suite prs tps rd_targets separators) M'\<close>
     unfolding passes_test_suite.simps 
     by blast
 
 
   (* seq to failure *)
 
 
   obtain pP io where "minimal_sequence_to_failure_extending_preamble_path M M' prs pP io"
     using minimal_sequence_to_failure_extending_preamble_ex[OF t1 \<open>\<not> L M' \<subseteq> L M\<close>] 
     by blast
 
   then have "sequence_to_failure_extending_preamble_path M M' prs pP io" 
             "\<And> io'. sequence_to_failure_extending_preamble_path M M' prs pP io' \<Longrightarrow> length io \<le> length io'"
     unfolding minimal_sequence_to_failure_extending_preamble_path_def
     by blast+
 
   obtain q P where "q \<in> states M"
                and "(q,P) \<in> prs"
                and "path P (initial P) pP"
                and "target (initial P) pP = q"
                and "((p_io pP) @ butlast io) \<in> L M" 
                and "((p_io pP) @ io) \<notin> L M"
                and "((p_io pP) @ io) \<in> L M'"
     using \<open>sequence_to_failure_extending_preamble_path M M' prs pP io\<close>
     unfolding sequence_to_failure_extending_preamble_path_def 
     by blast
 
   let ?xF = "fst (last io)"
   let ?yF = "snd (last io)"
   let ?xyF = "(?xF,?yF)"
   let ?ioF = "butlast io"
   have "io \<noteq> []"
     using \<open>((p_io pP) @ io) \<notin> L M\<close> \<open>((p_io pP) @ butlast io) \<in> L M\<close> by auto
   then have "io = ?ioF@[?xyF]"
     by auto
 
   have "?xF \<in> inputs M'"
     using language_io(1)[OF \<open>((p_io pP) @ io) \<in> L M'\<close>, of ?xF ?yF] \<open>io \<noteq> []\<close> by auto 
   then have "?xF \<in> inputs M"
     using \<open>inputs M' = inputs M\<close> by simp
 
   have "q \<in> fst ` prs"
     using \<open>(q,P) \<in> prs\<close> by force
   have "is_preamble P M q"
     using \<open>(q,P) \<in> prs\<close> t2 by blast
   then have "q \<in> states M"
     unfolding is_preamble_def
     by (metis \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> path_target_is_state submachine_path) 
 
   have "initial P = initial M"
     using \<open>is_preamble P M q\<close> unfolding is_preamble_def by auto
   have "path M (initial M) pP"
     using \<open>is_preamble P M q\<close> unfolding is_preamble_def using submachine_path_initial
     using \<open>path P (FSM.initial P) pP\<close> by blast
   have "target (initial M) pP = q"
     using \<open>target (initial P) pP = q\<close> unfolding \<open>initial P = initial M\<close> by assumption
 
 
   (* io must be a proper extension of some m-traversal path, as all m-traversal paths pass *)
   obtain pM dM ioEx where "(pM,dM) \<in> m_traversal_paths_with_witness M q repetition_sets m"
                     and   "io = (p_io pM)@ioEx"
                     and   "ioEx \<noteq> []"
   proof -
     
     obtain pF where "path M q pF" and "p_io pF = ?ioF"
       using observable_path_suffix[OF \<open>((p_io pP) @ ?ioF) \<in> L M\<close> \<open>path M (initial M) pP\<close> \<open>observable M\<close> ]
       unfolding \<open>target (initial M) pP = q\<close>
       by blast
 
     obtain tM where "tM \<in> transitions M" and "t_source tM = target q pF" and "t_input tM = ?xF"
       using \<open>?xF \<in> inputs M\<close> path_target_is_state[OF \<open>path M q pF\<close>]
             \<open>completely_specified M\<close>
       unfolding completely_specified.simps
       by blast
 
     then have "path M q (pF@[tM])"
       using \<open>path M q pF\<close> path_append_transition by simp
 
     show ?thesis proof (cases "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (pF@[tM]))) repetition_sets")
       case None
 
       (* if no repetition_sets witness exists for (pF@[tM]), then it is a proper prefix of some m-traversal path and hence also in L M, providing a contradiction*)
 
       obtain pF' d' where "((pF@[tM]) @ pF', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
         using m_traversal_path_extension_exist[OF \<open>completely_specified M\<close> \<open>q \<in> states M\<close> \<open>inputs M \<noteq> {}\<close> t5 t8 \<open>path M q (pF@[tM])\<close> None]
         by blast
       then have "(pF@[tM]) @ pF' \<in> tps q"
         using t6[OF \<open>q \<in> fst ` prs\<close>] by force
 
       have "(p_io pF) @ [(?xF,t_output tM)] \<in> set (prefixes (p_io ((pF@[tM])@pF')))"
         using \<open>t_input tM = ?xF\<close>
         unfolding prefixes_set by auto
 
       have "p_io pP @ p_io pF @ [?xyF] \<in> L M'"
         using \<open>((p_io pP) @ io) \<in> L M'\<close> unfolding \<open>p_io pF = ?ioF\<close> \<open>io = ?ioF@[?xyF]\<close>[symmetric] by assumption
 
       obtain pT' where "pT' \<in> tps q" 
                  and   "p_io pF @ [(fst (last io), snd (last io))] \<in> set (prefixes (p_io pT'))"
         using pass2[OF \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) pP\<close> \<open>target (initial P) pP = q\<close> \<open>(pF@[tM]) @ pF' \<in> tps q\<close> 
                        \<open>(p_io pF) @ [(?xF,t_output tM)] \<in> set (prefixes (p_io ((pF@[tM])@pF')))\<close> \<open>p_io pP @ p_io pF @ [?xyF] \<in> L M'\<close>]
         by blast
 
       have "path M q pT'"
       proof -
         obtain pT'' d'' where "(pT'@pT'', d'') \<in> m_traversal_paths_with_witness M q repetition_sets m"
           using \<open>pT' \<in> tps q\<close> t6[OF \<open>q \<in> fst ` prs\<close>] 
           by blast
         then have "path M q (pT'@pT'')"
           using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>] 
           by force
         then show ?thesis 
           by auto
       qed
       then have "path M (initial M) (pP@pT')"
         using \<open>path M (initial M) pP\<close> \<open>target (initial M) pP = q\<close> by auto
       then have "(p_io (pP@pT')) \<in> L M"
         unfolding LS.simps by blast
       then have "(p_io pP)@(p_io pT') \<in> L M"
         by auto
       
 
 
       have "io \<in> set (prefixes (p_io pT'))"
         using \<open>p_io pF @ [(fst (last io), snd (last io))] \<in> set (prefixes (p_io pT'))\<close>
         unfolding \<open>p_io pF = ?ioF\<close> \<open>io = ?ioF@[?xyF]\<close>[symmetric] by assumption
       then obtain io' where "p_io pT' = io @ io'"
-        unfolding prefixes_set by moura
+        unfolding prefixes_set mem_Collect_eq by metis
       
       have " p_io pP @ io \<in> L M"
         using \<open>(p_io pP)@(p_io pT') \<in> L M\<close> 
         unfolding \<open>p_io pT' = io @ io'\<close>
         unfolding append.assoc[symmetric]
         using language_prefix[of "p_io pP @ io" io', of M "initial M"] 
         by blast
       
       then show ?thesis
         using \<open>(p_io pP) @ io \<notin> L M\<close> by simp
     next
       case (Some d)
 
       (* get the shortest prefix of pF that still has a RepSet witness *)
 
       let ?ps = "{ p1 . \<exists> p2 . (pF@[tM]) = p1 @ p2 \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) repetition_sets \<noteq> None}"
 
       have "finite ?ps"
       proof -
         have "?ps \<subseteq> set (prefixes (pF@[tM]))"
           unfolding prefixes_set by force
         moreover have "finite (set (prefixes (pF@[tM])))"
           by simp
         ultimately show ?thesis
           by (simp add: finite_subset) 
       qed
       moreover have "?ps \<noteq> {}"
       proof -
         have "pF @ [tM] = (pF @ [tM]) @ [] \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (pF @ [tM]))) repetition_sets \<noteq> None"
           using Some by auto
         then have "(pF@[tM]) \<in> ?ps"
           by blast
         then show ?thesis by blast
       qed
       ultimately obtain pMin where "pMin \<in> ?ps" and "\<And> p' . p' \<in> ?ps \<Longrightarrow> length pMin \<le> length p'"
         by (meson leI min_length_elem) 
 
       obtain pMin' dMin where "(pF@[tM]) = pMin @ pMin'"
                           and "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) pMin)) repetition_sets = Some dMin"
         using \<open>pMin \<in> ?ps\<close> by blast
       then have "path M q pMin"
         using \<open>path M q (pF@[tM])\<close> by auto
 
       moreover have "(\<forall>p' p''. pMin = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None)"
       proof -
         have "\<And> p' p''. pMin = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
         proof -
           fix p' p'' assume "pMin = p' @ p''" and "p'' \<noteq> []"
           show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
           proof (rule ccontr) 
             assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets \<noteq> None"
             then have "p' \<in> ?ps"
               using \<open>(pF@[tM]) = pMin @ pMin'\<close> unfolding \<open>pMin = p' @ p''\<close> append.assoc by blast
             
             have "length p' < length pMin"
               using \<open>pMin = p' @ p''\<close> \<open>p'' \<noteq> []\<close> by auto
             then show "False"
               using \<open>\<And> p' . p' \<in> ?ps \<Longrightarrow> length pMin \<le> length p'\<close>[OF \<open>p' \<in> ?ps\<close>] by simp
           qed
         qed
         then show ?thesis by blast
       qed
       
       ultimately have "(pMin,dMin) \<in> m_traversal_paths_with_witness M q repetition_sets m"
         using \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) pMin)) repetition_sets = Some dMin\<close>
               m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m]
         by blast
       then have "pMin \<in> tps q"
         using t6[OF \<open>q \<in> fst ` prs\<close>]
         by force
   
       show ?thesis proof (cases "pMin = (pF@[tM])")
         (* if the m-traversal path is not shorter than io, then again the failure is observed *)
         case True 
         then have "?ioF @ [(?xF, t_output tM)] \<in> set (prefixes (p_io pMin))"
           using \<open>p_io pF = ?ioF\<close> \<open>t_input tM = ?xF\<close> unfolding prefixes_set by force
 
         obtain pMinF where "pMinF \<in> tps q" and "io \<in> set (prefixes (p_io pMinF))"
           using pass2[OF \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) pP\<close> \<open>target (initial P) pP = q\<close> \<open>pMin \<in> tps q\<close> \<open>?ioF @ [(?xF, t_output tM)] \<in> set (prefixes (p_io pMin))\<close>, of ?yF]
           using \<open>p_io pP @ io \<in> L M'\<close>
           unfolding \<open>io = ?ioF@[?xyF]\<close>[symmetric]
           by blast
 
         have "path M q pMinF"
         proof -
           obtain pT'' d'' where "(pMinF@pT'', d'') \<in> m_traversal_paths_with_witness M q repetition_sets m"
             using \<open>pMinF \<in> tps q\<close> t6[OF \<open>q \<in> fst ` prs\<close>] by blast
           then have "path M q (pMinF@pT'')"
             using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>] 
             by force
           then show ?thesis by auto
         qed
         then have "path M (initial M) (pP@pMinF)"
           using \<open>path M (initial M) pP\<close> \<open>target (initial M) pP = q\<close> by auto
         then have "(p_io (pP@pMinF)) \<in> L M"
           unfolding LS.simps by blast
         then have "(p_io pP)@(p_io pMinF) \<in> L M"
           by auto
         
         obtain io' where "p_io pMinF = io @ io'"
-          using \<open>io \<in> set (prefixes (p_io pMinF))\<close> unfolding prefixes_set by moura
+          using \<open>io \<in> set (prefixes (p_io pMinF))\<close>
+          unfolding prefixes_set mem_Collect_eq by metis
         
         have " p_io pP @ io \<in> L M"
           using \<open>(p_io pP)@(p_io pMinF) \<in> L M\<close> 
           unfolding \<open>p_io pMinF = io @ io'\<close>
           unfolding append.assoc[symmetric]
           using language_prefix[of "p_io pP @ io" io', of M "initial M"] 
           by blast        
         then show ?thesis
           using \<open>(p_io pP) @ io \<notin> L M\<close> by simp
       next
         case False
         then obtain pMin'' where "pF = pMin @ pMin''"
           using \<open>(pF@[tM]) = pMin @ pMin'\<close>
           by (metis butlast_append butlast_snoc) 
         then have "io = (p_io pMin) @ (p_io pMin'') @ [?xyF]"
           using \<open>io = ?ioF @ [?xyF]\<close> \<open>p_io pF = ?ioF\<close>
           by (metis (no_types, lifting) append_assoc map_append)
         then show ?thesis 
           using that[OF \<open>(pMin,dMin) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close>, of "(p_io pMin'') @ [?xyF]"] 
           by auto
       qed
     qed
   qed
 
 
   (* collect length properties on pM to ultimately show that M' must have at least m+1 states *)
 
   have "p_io pP @ p_io pM \<in> L M'"
     using \<open>((p_io pP) @ io) \<in> L M'\<close> unfolding \<open>io = (p_io pM)@ioEx\<close> append.assoc[symmetric]
     using language_prefix[of "p_io pP @ p_io pM" ioEx M' "initial M'"] by blast
 
   have no_shared_targets_for_distinct_states : "\<And> q' q'' pR1 pR2. q' \<noteq> q'' \<Longrightarrow>
                                                   q' \<in> fst dM \<Longrightarrow>
                                                   q'' \<in> fst dM \<Longrightarrow>
                                                   pR1 \<in> RP M q q' pP pM prs M' \<Longrightarrow>
                                                   pR2 \<in> RP M q q'' pP pM prs M' \<Longrightarrow> 
                                                   io_targets M' (p_io pR1) (initial M') \<inter> io_targets M' (p_io pR2) (initial M') = {}"
     using passes_test_suite_exhaustiveness_helper_1[OF \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close> \<open>observable M\<close> \<open>observable M'\<close> \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>p_io pP @ p_io pM \<in> L M'\<close> \<open>(pM, dM) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close> repetition_sets_def \<open>passes_test_suite M (Test_Suite prs tps rd_targets separators) M'\<close>]
     by blast
 
 
 
   have "path M q pM"
   and  "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) pM)) repetition_sets = Some dM"
     using \<open>(pM,dM) \<in> m_traversal_paths_with_witness M q repetition_sets m\<close>
     using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m] by force+
   then have "path M (target (FSM.initial M) pP) pM"
     unfolding \<open>(target (FSM.initial M) pP) = q\<close> by simp
 
   have "dM \<in> set repetition_sets"
     using find_set[OF \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) pM)) repetition_sets = Some dM\<close>] by assumption
   have "Suc (m - card (snd dM)) \<le> length (filter (\<lambda>t. t_target t \<in> fst dM) pM)"
     using find_condition[OF \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) pM)) repetition_sets = Some dM\<close>] by assumption
 
   obtain ioX where "butlast io = (p_io pM)@ioX"
     using \<open>io = (p_io pM)@ioEx\<close>
     by (simp add: \<open>ioEx \<noteq> []\<close> butlast_append) 
 
 
   have RP_card : "\<And> q' . card (\<Union>pR\<in>RP M (target (FSM.initial M) pP) q' pP pM prs M'. io_targets M' (p_io pR) (FSM.initial M')) = card (RP M (target (FSM.initial M) pP) q' pP pM prs M')"
   and  RP_targets: "\<And> q' pR . pR \<in> RP M (target (FSM.initial M) pP) q' pP pM prs M' \<Longrightarrow> \<exists>q. io_targets M' (p_io pR) (FSM.initial M') = {q}"
   and  no_shared_targets_for_identical_states: "\<And> q' pR1 pR2 . pR1 \<in> RP M (target (FSM.initial M) pP) q' pP pM prs M' \<Longrightarrow> pR2 \<in> RP M (target (FSM.initial M) pP) q' pP pM prs M' \<Longrightarrow> pR1 \<noteq> pR2 \<Longrightarrow> io_targets M' (p_io pR1) (FSM.initial M') \<inter> io_targets M' (p_io pR2) (FSM.initial M') = {}"
     using RP_count[OF \<open>minimal_sequence_to_failure_extending_preamble_path M M' prs pP io\<close> \<open>observable M\<close> \<open>observable M'\<close> t2 \<open>path M (target (FSM.initial M) pP) pM\<close> \<open>butlast io = (p_io pM)@ioX\<close> pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>, of "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y"]
     by blast+
 
   have snd_dM_prop: "\<And> q' . q' \<in> snd dM \<Longrightarrow> (\<Union> pR \<in> (RP M q q' pP pM prs M') . io_targets M' (p_io pR) (initial M')) \<noteq> (\<Union> pR \<in> (R M q q' pP pM) . io_targets M' (p_io pR) (initial M'))"
   proof -
     fix q' assume "q' \<in> snd dM"
 
     let ?RP = "(RP M q q' pP pM prs M')"
     let ?R  = "(R M q q' pP pM)"
     let ?P  = "\<lambda> pP' . \<exists>P'. (q', P') \<in> prs \<and> path P' (FSM.initial P') pP' \<and> target (FSM.initial P') pP' = q' \<and> p_io pP' \<in> L M'"
 
     
     obtain PQ where "(q',PQ) \<in> prs"
       using \<open>q' \<in> snd dM\<close> t8'[OF \<open>dM \<in> set repetition_sets\<close>] by auto
     then have "is_preamble PQ M q'" and "\<exists>P'. (q', P') \<in> prs"
       using t2 by blast+
 
     obtain pq where "path PQ (initial PQ) pq" and "target (initial PQ) pq = q'" and "p_io pq \<in> L M'"
       using preamble_pass_path[OF \<open>is_preamble PQ M q'\<close> pass1[OF \<open>(q',PQ) \<in> prs\<close>] \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>] 
       by force
     then have "\<exists> pP' . ?P pP'"
       using \<open>(q',PQ) \<in> prs\<close> by blast
 
     define pPQ where pPQ_def: "pPQ = (SOME pP'. ?P pP')"
 
     have "?P pPQ"
       unfolding pPQ_def using someI_ex[OF \<open>\<exists> pP' . ?P pP'\<close>] by assumption
     then obtain PQ' where "(q',PQ') \<in> prs" 
                       and "path PQ' (initial PQ') pPQ" 
                       and "target (initial PQ') pPQ = q'" 
                       and "p_io pPQ \<in> L M'"
       by blast
 
     have "?RP = insert pPQ (R M q q' pP pM)"
       unfolding RP_def pPQ_def
       using \<open>\<exists>P'. (q', P') \<in> prs\<close> by auto
 
     obtain pPQ' where "path M' (initial M') pPQ'" and "p_io pPQ' = p_io pPQ"
       using \<open>p_io pPQ \<in> L M'\<close> by auto
 
     then have "io_targets M' (p_io pPQ) (initial M') = {target (initial M') pPQ'}"
       using \<open>observable M'\<close> by (metis (mono_tags, lifting) observable_path_io_target) 
     
     moreover have "target (initial M') pPQ' \<notin> (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) ?R))"
     proof 
       assume "target (initial M') pPQ' \<in> (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) ?R))"
       then obtain pR where "pR \<in> ?R" and "target (initial M') pPQ' \<in> io_targets M' (p_io pR) (initial M')"
         by blast
 
       obtain pR' where "pR = pP@pR'"
         using R_component_ob[OF \<open>pR \<in> ?R\<close>] by blast
       then have "pP@pR' \<in> ?R"
         using \<open>pR \<in> ?R\<close> by simp
       have "pR' = take (length pR') pM" 
        and "length pR' \<le> length pM" 
        and "t_target (pM ! (length pR' - 1)) = q'" 
        and "pR' \<noteq> []"
         using R_component[OF \<open>pP@pR' \<in> ?R\<close>] by auto
 
       
       (* get the full path along (butlast io) in M, of which p is a (possibly proper) prefix *)
 
       obtain pX where "path M (target (initial M) pP) (pM@pX)" and "p_io (pM@pX) = butlast io"
       proof -
         have "p_io pP @ p_io pM @ ioX \<in> L M"
           using \<open>((p_io pP) @ butlast io) \<in> L M\<close> 
           unfolding \<open>butlast io = p_io pM @ ioX\<close> 
           by assumption
     
         obtain p1 p23 where "path M (FSM.initial M) p1" 
                         and "path M (target (FSM.initial M) p1) p23" 
                         and "p_io p1 = p_io pP" 
                         and "p_io p23 = p_io pM @ ioX"
           using language_state_split[OF \<open>p_io pP @ p_io pM @ ioX \<in> L M\<close>] 
           by blast
     
         have "p1 = pP"
           using observable_path_unique[OF \<open>observable M\<close> \<open>path M (FSM.initial M) p1\<close> \<open>path M (FSM.initial M) pP\<close> \<open>p_io p1 = p_io pP\<close>]
           by assumption
         then have "path M (target (FSM.initial M) pP) p23"
           using \<open>path M (target (FSM.initial M) p1) p23\<close> by auto
         then have "p_io pM @ ioX \<in> LS M (target (initial M) pP)"
           using \<open>p_io p23 = p_io pM @ ioX\<close> language_state_containment by auto
     
         obtain p2 p3 where "path M (target (FSM.initial M) pP) p2" 
                        and "path M (target (target (FSM.initial M) pP) p2) p3"
                        and "p_io p2 = p_io pM" 
                        and "p_io p3 = ioX"
           using language_state_split[OF \<open>p_io pM @ ioX \<in> LS M (target (initial M) pP)\<close>] 
           by blast
     
         have "p2 = pM"
           using observable_path_unique[OF \<open>observable M\<close> \<open>path M (target (FSM.initial M) pP) p2\<close> 
                                           \<open>path M (target (FSM.initial M) pP) pM\<close> \<open>p_io p2 = p_io pM\<close>] 
           by assumption
         then have "path M (target (FSM.initial M) pP) (pM@p3)"
           using \<open>path M (target (FSM.initial M) pP) pM\<close> \<open>path M (target (target (FSM.initial M) pP) p2) p3\<close> 
           by auto
         moreover have "p_io (pM@p3) = butlast io"
           unfolding \<open>butlast io = p_io pM @ ioX\<close> using \<open>p_io p3 = ioX\<close> 
           by auto
         ultimately show ?thesis 
           using that[of p3] by simp
       qed
 
       obtain pP' pIO where "path M' (FSM.initial M') pP'" 
                        and "path M' (target (FSM.initial M') pP') pIO" 
                        and "p_io pP' = p_io pP"
                        and "p_io pIO = io"
         using language_state_split[OF \<open>((p_io pP) @ io) \<in> L M'\<close>] 
         by blast
   
       have "target (initial M') pP' \<in> io_targets M' (p_io pP) (FSM.initial M')"
         using \<open>path M' (FSM.initial M') pP'\<close> 
         unfolding \<open>p_io pP' = p_io pP\<close>[symmetric] 
         by auto
 
       let ?i = "length pR' - 1"
       have "?i < length pR'"
         using \<open>pR' \<noteq> []\<close> by auto
       have "?i < length (butlast io)"
         using \<open>pR' = take (length pR') pM\<close> \<open>pR' \<noteq> []\<close>
         unfolding \<open>p_io (pM@pX) = butlast io\<close>[symmetric] 
         using leI by fastforce 
 
       have "t_target ((pM @ pX) ! (length pR' - 1)) = q'"
         by (metis \<open>length pR' - 1 < length pR'\<close> \<open>length pR' \<le> length pM\<close> \<open>t_target (pM ! (length pR' - 1)) = q'\<close> 
               dual_order.strict_trans1 nth_append) 
       then have "(t_target ((pM @ pX) ! (length pR' - 1)), PQ') \<in> prs"
         using \<open>(q',PQ') \<in> prs\<close> by simp
       have "target (FSM.initial PQ') pPQ = t_target ((pM @ pX) ! (length pR' - 1))"
         using \<open>t_target ((pM @ pX) ! (length pR' - 1)) = q'\<close> \<open>target (FSM.initial PQ') pPQ = q'\<close> 
         by blast
 
 
       have "t_target (pIO ! ?i) \<notin> io_targets M' (p_io pPQ) (FSM.initial M')"
         using minimal_sequence_to_failure_extending_preamble_no_repetitions_with_other_preambles
           [OF \<open>minimal_sequence_to_failure_extending_preamble_path M M' prs pP io\<close> \<open>observable M\<close> \<open>
               path M (target (initial M) pP) (pM@pX)\<close> \<open>p_io (pM@pX) = butlast io\<close>
               \<open>target (initial M') pP' \<in> io_targets M' (p_io pP) (FSM.initial M')\<close> 
               \<open>path M' (target (FSM.initial M') pP') pIO\<close> \<open>p_io pIO = io\<close> t2
               \<open>?i < length (butlast io)\<close> \<open>(t_target ((pM @ pX) ! (length pR' - 1)), PQ') \<in> prs\<close>
               \<open>path PQ' (initial PQ') pPQ\<close> \<open>target (FSM.initial PQ') pPQ = t_target ((pM @ pX) ! (length pR' - 1))\<close>]
         by blast
 
       moreover have "io_targets M' (p_io pPQ) (FSM.initial M') = {target (initial M') pPQ'}"
         using \<open>path M' (initial M') pPQ'\<close>
         using \<open>io_targets M' (p_io pPQ) (FSM.initial M') = {target (FSM.initial M') pPQ'}\<close> \<open>p_io pPQ' = p_io pPQ\<close> by auto 
       moreover have "io_targets M' (p_io (pP@pR')) (FSM.initial M') = {t_target (pIO ! ?i)}"
       proof -
         have "(take (length pR') pIO) \<noteq> []" 
           using \<open>p_io pIO = io\<close> \<open>?i < length pR'\<close>
           using \<open>io = p_io pM @ ioEx\<close> \<open>pR' = take (length pR') pM\<close> by auto
         moreover have "pIO ! ?i = last (take (length pR') pIO)" 
           using \<open>p_io pIO = io\<close> \<open>?i < length pR'\<close>
           by (metis (no_types, lifting) \<open>io = p_io pM @ ioEx\<close> \<open>length pR' \<le> length pM\<close> \<open>pR' = take (length pR') pM\<close> 
                 butlast.simps(1) last_conv_nth length_butlast length_map neq_iff nth_take take_le take_map)
         ultimately have "t_target (pIO ! ?i) = target (target (FSM.initial M') pP') (take (length pR') pIO)"
           unfolding target.simps visited_states.simps
           by (simp add: last_map) 
         then have "t_target (pIO ! ?i) = target (initial M') (pP' @ (take (length pR') pIO))"
           by auto 
           
         have "path M' (target (FSM.initial M') pP') (take (length pR') pIO)"
           using \<open>path M' (target (FSM.initial M') pP') pIO\<close>
           by (simp add: path_prefix_take) 
         then have "path M' (initial M') (pP' @ (take (length pR') pIO))"
           using \<open>path M' (FSM.initial M') pP'\<close> by auto
         moreover have "p_io (pP' @ (take (length pR') pIO)) = (p_io (pP@pR'))"
         proof -
           have "p_io (take (length pR') pIO) = p_io pR'"
             using \<open>p_io pIO = io\<close> \<open>pR' = take (length pR') pM\<close> \<open>p_io (pM@pX) = butlast io\<close> \<open>length pR' \<le> length pM\<close>
             by (metis (no_types, lifting) \<open>io = p_io pM @ ioEx\<close> length_map take_le take_map) 
           then show ?thesis
             using \<open>p_io pP' = p_io pP\<close> by auto
         qed
         ultimately have "io_targets M' (p_io (pP@pR')) (FSM.initial M') = {target (initial M') (pP' @ (take (length pR') pIO))}"
           by (metis (mono_tags, lifting) assms(4) observable_path_io_target)
 
         then show ?thesis
           unfolding \<open>t_target (pIO ! ?i) = target (initial M') (pP' @ (take (length pR') pIO))\<close>
           by assumption
       qed
 
       ultimately have "target (initial M') pPQ' \<notin> io_targets M' (p_io pR) (initial M')"
         unfolding \<open>pR = pP@pR'\<close> by auto
       then show "False"
         using \<open>target (initial M') pPQ' \<in> io_targets M' (p_io pR) (initial M')\<close>
         by blast
     qed
 
     ultimately have "io_targets M' (p_io pPQ) (initial M') \<inter> (\<Union> (image (\<lambda> pR . io_targets M' (p_io pR) (initial M')) ?R)) = {}"
       by force
 
     then show "(\<Union> pR \<in> (RP M q q' pP pM prs M') . io_targets M' (p_io pR) (initial M')) \<noteq> (\<Union> pR \<in> (R M q q' pP pM) . io_targets M' (p_io pR) (initial M'))"
       unfolding \<open>?RP = insert pPQ (R M q q' pP pM)\<close>
       using \<open>io_targets M' (p_io pPQ) (FSM.initial M') = {target (FSM.initial M') pPQ'}\<close> 
       by force
   qed
 
   (* create a function that separates the additional entries for the preambles in the RP sets of states in (snd dM) *)
 
   then obtain f where f_def: "\<And> q' . q' \<in> snd dM \<Longrightarrow> (RP M q q' pP pM prs M') = insert (f q') (R M q q' pP pM) \<and> (f q') \<notin> (R M q q' pP pM)"
   proof -
     define f where f_def : "f = (\<lambda> q' . SOME p . (RP M q q' pP pM prs M') = insert p (R M q q' pP pM) \<and> p \<notin> (R M q q' pP pM))"
 
     have "\<And> q' . q' \<in> snd dM \<Longrightarrow> (RP M q q' pP pM prs M') = insert (f q') (R M q q' pP pM) \<and> (RP M q q' pP pM prs M') \<noteq> (R M q q' pP pM)"
     proof -
       fix q' assume "q' \<in> snd dM"
 
       have "(\<Union>pR\<in>RP M q q' pP pM prs M'. io_targets M' (p_io pR) (FSM.initial M')) \<noteq> (\<Union>pR\<in>R M q q' pP pM. io_targets M' (p_io pR) (FSM.initial M'))"
         using snd_dM_prop[OF \<open>q' \<in> snd dM\<close>]
         by assumption
       then have "(RP M q q' pP pM prs M') \<noteq> (R M q q' pP pM)"
         by blast
       then obtain x where "(RP M q q' pP pM prs M') = insert x (R M q q' pP pM)"
         using RP_from_R[OF t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>, of prs "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y" q q' pP pM]
         by force
       then have "x \<notin> (R M q q' pP pM)"
         using \<open>(RP M q q' pP pM prs M') \<noteq> (R M q q' pP pM)\<close>
         by auto 
       then have "\<exists> p . (RP M q q' pP pM prs M') = insert p (R M q q' pP pM) \<and> p \<notin> (R M q q' pP pM)"
         using \<open>(RP M q q' pP pM prs M') = insert x (R M q q' pP pM)\<close> by blast
 
       show "(RP M q q' pP pM prs M') = insert (f q') (R M q q' pP pM) \<and> (RP M q q' pP pM prs M') \<noteq> (R M q q' pP pM)"
         using someI_ex[OF \<open>\<exists> p . (RP M q q' pP pM prs M') = insert p (R M q q' pP pM) \<and> p \<notin> (R M q q' pP pM)\<close>]
         unfolding f_def by auto 
     qed
 
     then show ?thesis using that by force
   qed
 
 
 
   (* 
      combine counting results on RP (from R) to show that the path along pM collects 
      at least m+1 distinct io-targets (i.e. visites at least m+1 distinct states) in M' 
    *)
 
 
   have "(\<Sum> q' \<in> fst dM . card (\<Union> pR \<in> (RP M q q' pP pM prs M') . io_targets M' (p_io pR) (initial M'))) \<ge> Suc m"
   proof -
 
     have "\<And> nds . finite nds \<Longrightarrow> nds \<subseteq> fst dM \<Longrightarrow> (\<Sum> q' \<in> nds . card (RP M q q' pP pM prs M')) \<ge> length (filter (\<lambda>t. t_target t \<in> nds) pM) + card (nds \<inter> snd dM)"
     proof -
       fix nds assume "finite nds" and "nds \<subseteq> fst dM"
       then show "(\<Sum> q' \<in> nds . card (RP M q q' pP pM prs M')) \<ge> length (filter (\<lambda>t. t_target t \<in> nds) pM) + card (nds \<inter> snd dM)"
       proof induction
         case empty
         then show ?case by auto
       next
         case (insert q' nds)
         then have leq1: "length (filter (\<lambda>t. t_target t \<in> nds) pM) + card (nds \<inter> snd dM) \<le> (\<Sum>q'\<in>nds. card (RP M q q' pP pM prs M'))"
           by blast
 
         have p4: "(card (R M q q' pP pM)) = length (filter (\<lambda>t. t_target t = q') pM)" 
         using \<open>path M q pM\<close> proof (induction pM rule: rev_induct)
           case Nil
           then show ?case unfolding R_def by auto
         next
           case (snoc t pM)
           then have "path M q pM" and "card (R M q q' pP pM) = length (filter (\<lambda>t. t_target t = q') pM)"
             by auto
 
           show ?case proof (cases "target q (pM @ [t]) = q'")
             case True
             then have "(R M q q' pP (pM @ [t])) = insert (pP @ pM @ [t]) (R M q q' pP pM)"
               unfolding R_update[of M q q' pP pM t] by simp
             moreover have "(pP @ pM @ [t]) \<notin> (R M q q' pP pM)"
               unfolding R_def by auto
             ultimately have "card (R M q q' pP (pM @ [t])) = Suc (card (R M q q' pP pM))"
               using finite_R[OF \<open>path M q pM\<close>, of q' pP] by simp 
             then show ?thesis 
               using True unfolding \<open>card (R M q q' pP pM) = length (filter (\<lambda>t. t_target t = q') pM)\<close> by auto
           next
             case False
             then have "card (R M q q' pP (pM @ [t])) = card (R M q q' pP pM)"
               unfolding R_update[of M q q' pP pM t] by simp
             then show ?thesis 
               using False unfolding \<open>card (R M q q' pP pM) = length (filter (\<lambda>t. t_target t = q') pM)\<close> by auto
           qed 
         qed
 
         show ?case proof (cases "q' \<in> snd dM")
           case True
           then have p0: "(RP M q q' pP pM prs M') = insert (f q') (R M q q' pP pM)" and "(f q') \<notin> (R M q q' pP pM)"
             using f_def by blast+
           then have "card (RP M q q' pP pM prs M') = Suc (card (R M q q' pP pM))"
             by (simp add: \<open>path M q pM\<close> finite_R)
           then have p1: "(\<Sum>q' \<in> (insert q' nds). card (RP M q q' pP pM prs M')) = (\<Sum>q'\<in>nds. card (RP M q q' pP pM prs M')) + Suc (card (R M q q' pP pM))"
             by (simp add: insert.hyps(1) insert.hyps(2))
 
           have p2: "length (filter (\<lambda>t. t_target t \<in> insert q' nds) pM) = length (filter (\<lambda>t. t_target t \<in> nds) pM) + length (filter (\<lambda>t. t_target t = q') pM)"
             using \<open>q' \<notin> nds\<close> by (induction pM; auto)
           have p3: "card ((insert q' nds) \<inter> snd dM) = Suc (card (nds \<inter> snd dM))"
             using True \<open>finite nds\<close> \<open>q' \<notin> nds\<close> by simp
 
           show ?thesis 
             using leq1
             unfolding  p1 p2 p3 p4 by simp
         next
           case False
 
           have "card (RP M q q' pP pM prs M') \<ge> (card (R M q q' pP pM))"
           proof (cases "(RP M q q' pP pM prs M') = (R M q q' pP pM)")
             case True
             then show ?thesis using finite_R[OF \<open>path M q pM\<close>, of q' pP] by auto
           next
             case False
             then obtain pX where "(RP M q q' pP pM prs M') = insert pX (R M q q' pP pM)"
               using RP_from_R[OF t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>, of prs "\<lambda> q P io x y y' . q" "\<lambda> q P io x y y' . y" q q' pP pM] 
               by force
             then show ?thesis using finite_R[OF \<open>path M q pM\<close>, of q' pP]
               by (simp add: card_insert_le) 
           qed
           then have p1: "(\<Sum>q' \<in> (insert q' nds). card (RP M q q' pP pM prs M')) \<ge> ((\<Sum>q'\<in>nds. card (RP M q q' pP pM prs M')) + (card (R M q q' pP pM)))"
             by (simp add: insert.hyps(1) insert.hyps(2))
 
 
           have p2: "length (filter (\<lambda>t. t_target t \<in> insert q' nds) pM) = length (filter (\<lambda>t. t_target t \<in> nds) pM) + length (filter (\<lambda>t. t_target t = q') pM)"
             using \<open>q' \<notin> nds\<close> by (induction pM; auto)
           have p3: "card ((insert q' nds) \<inter> snd dM) = (card (nds \<inter> snd dM))"
             using False \<open>finite nds\<close> \<open>q' \<notin> nds\<close> by simp
 
           have "length (filter (\<lambda>t. t_target t \<in> nds) pM) + length (filter (\<lambda>t. t_target t = q') pM) + card (nds \<inter> snd dM) \<le> (\<Sum>q'\<in>nds. card (RP M q q' pP pM prs M')) + length (filter (\<lambda>t. t_target t = q') pM)"
             using leq1 add_le_cancel_right by auto 
 
           then show ?thesis 
             using p1 
             unfolding p2 p3 p4 by simp
         qed
       qed 
     qed
 
     moreover have "finite (fst dM)"
       using t7[OF \<open>dM \<in> set repetition_sets\<close>] fsm_states_finite[of M]
       using rev_finite_subset by auto 
     ultimately have "(\<Sum> q' \<in> fst dM . card (RP M q q' pP pM prs M')) \<ge> length (filter (\<lambda>t. t_target t \<in> fst dM) pM) + card (fst dM \<inter> snd dM)"
       by blast
     have "(fst dM \<inter> snd dM) = (snd dM)"
       using t8[OF \<open>dM \<in> set repetition_sets\<close>] by blast
     have "(\<Sum> q' \<in> fst dM . card (RP M q q' pP pM prs M')) \<ge> length (filter (\<lambda>t. t_target t \<in> fst dM) pM) + card (snd dM)"
       using \<open>(\<Sum> q' \<in> fst dM . card (RP M q q' pP pM prs M')) \<ge> length (filter (\<lambda>t. t_target t \<in> fst dM) pM) + card (fst dM \<inter> snd dM)\<close> 
       unfolding \<open>(fst dM \<inter> snd dM) = (snd dM)\<close> 
       by assumption
     moreover have "(\<Sum>q'\<in>fst dM. card (\<Union>pR\<in>RP M q q' pP pM prs M'. io_targets M' (p_io pR) (FSM.initial M'))) = (\<Sum> q' \<in> fst dM . card (RP M q q' pP pM prs M'))"
       using RP_card \<open>FSM.initial P = FSM.initial M\<close> \<open>target (FSM.initial P) pP = q\<close> by auto 
     ultimately have "(\<Sum>q'\<in>fst dM. card (\<Union>pR\<in>RP M q q' pP pM prs M'. io_targets M' (p_io pR) (FSM.initial M'))) \<ge> length (filter (\<lambda>t. t_target t \<in> fst dM) pM) + card (snd dM)"
       by linarith
     moreover have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst dM) pM) + card (snd dM)"
       using \<open>Suc (m - card (snd dM)) \<le> length (filter (\<lambda>t. t_target t \<in> fst dM) pM)\<close>
       by linarith 
     ultimately show ?thesis 
       by linarith
   qed
 
 
   moreover have "(\<Sum> q' \<in> fst dM . card (\<Union> pR \<in> (RP M q q' pP pM prs M') . io_targets M' (p_io pR) (initial M'))) \<le> card (states M')"
   proof -
     have "finite (fst dM)"
       by (meson \<open>dM \<in> set repetition_sets\<close> fsm_states_finite rev_finite_subset t7) 
 
     have "(\<And>x1. finite (RP M q x1 pP pM prs M'))"
       using finite_RP[OF \<open>path M q pM\<close> t2 pass1 \<open>completely_specified M'\<close> \<open>inputs M' = inputs M\<close>] by force
 
     have "(\<And>y1. finite (io_targets M' (p_io y1) (FSM.initial M')))"
       by (meson io_targets_finite)
 
     have "(\<And>y1. io_targets M' (p_io y1) (FSM.initial M') \<subseteq> states M')"
       by (meson io_targets_states)
       
     show ?thesis 
       using distinct_union_union_card
         [ of "fst dM" "\<lambda> q' . (RP M q q' pP pM prs M')" "\<lambda> pR . io_targets M' (p_io pR) (initial M')"
         , OF \<open>finite (fst dM)\<close>
              no_shared_targets_for_distinct_states
              no_shared_targets_for_identical_states
              \<open>(\<And>x1. finite (RP M q x1 pP pM prs M'))\<close>
              io_targets_finite
              io_targets_states
              fsm_states_finite[of M']] 
       unfolding \<open>(target (FSM.initial M) pP) = q\<close> by force
   qed
 
   (* create a contradiction due to the assumption that M' has at most m states *)
 
   moreover have "card (states M') \<le> m"
     using \<open>size M' \<le> m\<close> by auto
 
   ultimately show False
     by linarith
 qed
 
 
 subsection \<open>Completeness of Sufficient Test Suites\<close>
 
 text \<open>This subsection combines the soundness and exhaustiveness properties of sufficient test suites
       to show completeness: for any System Under Test with at most m states a test suite sufficient 
       for m passes if and only if the System Under Test is a reduction of the specification.\<close>
 
 
 lemma passes_test_suite_completeness :
   assumes "implies_completeness T M m"
   and     "observable M" 
   and     "observable M'"
   and     "inputs M' = inputs M"
   and     "inputs M \<noteq> {}"
   and     "completely_specified M"
   and     "completely_specified M'"
   and     "size M' \<le> m"
 shows     "(L M' \<subseteq> L M) \<longleftrightarrow> passes_test_suite M T M'"
   using passes_test_suite_exhaustiveness[OF _ _ assms(2-8)]
         passes_test_suite_soundness[OF _ assms(2,3,4,6)] 
         assms(1) 
         test_suite.exhaust[of T]
   by metis
 
 
 
 
 subsection \<open>Additional Test Suite Properties\<close>
 
 (* Whether a (sufficient) test suite can be represented as a finite set of IO sequences *)
 (* (tps q) must already be finite for a sufficient test suite due to being a subset of the maximal m-traversal paths *)
 fun is_finite_test_suite :: "('a,'b,'c,'d) test_suite \<Rightarrow> bool" where
   "is_finite_test_suite (Test_Suite prs tps rd_targets separators) = 
     ((finite prs) \<and> (\<forall> q p . q \<in> fst ` prs \<longrightarrow> finite (rd_targets (q,p))) \<and> (\<forall> q q' . finite (separators (q,q'))))" 
 
 end
\ No newline at end of file
diff --git a/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite_IO.thy b/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite_IO.thy
--- a/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite_IO.thy
+++ b/thys/FSM_Tests/AdaptiveStateCounting/Test_Suite_IO.thy
@@ -1,1816 +1,1810 @@
 section \<open>Representing Test Suites as Sets of Input-Output Sequences\<close>
 
 text \<open>This theory describes the representation of test suites as sets of input-output sequences
       and defines a pass relation for this representation.\<close>
 
 
 theory Test_Suite_IO
 imports Test_Suite Maximal_Path_Trie
 begin
 
 
 fun test_suite_to_io :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c,'d) test_suite \<Rightarrow> ('b \<times> 'c) list set" where
   "test_suite_to_io M (Test_Suite prs tps rd_targets atcs) =
     (\<Union> (q,P) \<in> prs . L P)
     \<union> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})
     \<union> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
 
 
 lemma test_suite_to_io_language :
   assumes "implies_completeness T M m"
 shows "(test_suite_to_io M T) \<subseteq> L M"
 proof 
   fix io assume "io \<in> test_suite_to_io M T"
 
   obtain prs tps rd_targets atcs where "T = Test_Suite prs tps rd_targets atcs"
     by (meson test_suite.exhaust)
 
   then obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets atcs) M m repetition_sets"
     using assms(1) unfolding implies_completeness_def 
     by blast
   then have "implies_completeness (Test_Suite prs tps rd_targets atcs) M m"
     unfolding implies_completeness_def 
     by blast
 
   have t2: "\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q"
     using implies_completeness_for_repetition_sets_simps(2)[OF repetition_sets_def] 
     by blast
   
   have t5: "\<And>q. q \<in> FSM.states M \<Longrightarrow> (\<exists>d\<in>set repetition_sets. q \<in> fst d)"
     using implies_completeness_for_repetition_sets_simps(4)[OF repetition_sets_def] 
     by assumption
 
   have t6: "\<And> q. q \<in> fst ` prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using implies_completeness_for_repetition_sets_simps(7)[OF repetition_sets_def] 
     by assumption
 
   have t8: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d \<subseteq> fst d"
     using implies_completeness_for_repetition_sets_simps(5,6)[OF repetition_sets_def] 
     by blast
 
 
   from \<open>io \<in> test_suite_to_io M T\<close> consider
     (a) "io \<in> (\<Union> (q,P) \<in> prs . L P)" |
     (b) "io \<in> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})" |
     (c) "io \<in> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> test_suite_to_io.simps
     by blast
 
   then show "io \<in> L M" proof cases
     case a
     then obtain q P  where "(q, P) \<in> prs" and "io \<in> L P"
       by blast
 
     have "is_submachine P M"
       using t2[OF \<open>(q, P) \<in> prs\<close>] unfolding is_preamble_def by blast
 
     show "io \<in> L M"
       using submachine_language[OF \<open>is_submachine P M\<close>] \<open>io \<in> L P\<close> by blast
   next
     case b
     then obtain p pt q P where "io \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))" 
                            and "(q,P) \<in> prs" 
                            and "path P (initial P) p" 
                            and "target (initial P) p = q" 
                            and "pt \<in> tps q"
       by blast 
 
     then obtain io' where "io = p_io p @ io'" and "io' \<in> (set (prefixes (p_io pt)))"
       by blast
 
     then obtain io'' where "p_io pt = io' @ io''" and "io = p_io p @ io'"
-      unfolding prefixes_set
-    proof -
-      assume a1: "io' \<in> {xs'. \<exists>xs''. xs' @ xs'' = p_io pt}"
-      assume "\<And>io''. \<lbrakk>p_io pt = io' @ io''; io = p_io p @ io'\<rbrakk> \<Longrightarrow> thesis"
-      then show ?thesis
-        using a1 \<open>io = p_io p @ io'\<close> by moura
-    qed 
+      unfolding prefixes_set using \<open>io' \<in> set (prefixes (p_io pt))\<close> prefixes_set_ob by blast
 
     have "q \<in> fst ` prs"
       using \<open>(q,P) \<in> prs\<close> 
       by force
 
     have "is_submachine P M"
       using t2[OF \<open>(q, P) \<in> prs\<close>] 
       unfolding is_preamble_def 
       by blast
     then have "initial P = initial M" 
       by auto
 
     have "path M (initial M) p"
       using submachine_path[OF \<open>is_submachine P M\<close> \<open>path P (initial P) p\<close>] 
       unfolding \<open>initial P = initial M\<close> 
       by assumption
 
     have "target (initial M) p = q"
       using \<open>target (initial P) p = q\<close> 
       unfolding \<open>initial P = initial M\<close> 
       by assumption
 
     obtain p2 d where "(pt @ p2, d) \<in> m_traversal_paths_with_witness M q repetition_sets m"
       using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pt \<in> tps q\<close> 
       by blast
     then have "path M q (pt @ p2)"
       using m_traversal_paths_with_witness_set[OF t5 t8 path_target_is_state[OF \<open>path M (initial M) p\<close>], of m]
       unfolding \<open>target (initial M) p = q\<close> 
       by blast
     then have "path M (initial M) (p@pt)"
       using \<open>path M (initial M) p\<close> \<open>target (initial M) p = q\<close> 
       by auto
     then have "p_io p @ p_io pt \<in> L M"
       by (metis (mono_tags, lifting) language_intro map_append)
     
     then show "io \<in> L M"
       unfolding \<open>io = p_io p @ io'\<close> \<open>p_io pt = io' @ io''\<close> append.assoc[symmetric] 
       using language_prefix[of "p_io p @ io'" io'' M "initial M"] 
       by blast
   next
     case c
                                                                                                                       
     then obtain p pt q A P q' t1 t2 where "io \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)"
                                     and   "(q,P) \<in> prs" 
                                     and   "path P (initial P) p"
                                     and   "target (initial P) p = q"
                                     and   "pt \<in> tps q"
                                     and   "q' \<in> rd_targets (q,pt)" 
                                     and   "(A,t1,t2) \<in> atcs (target q pt,q')"
       by blast
 
     obtain ioA where "io = p_io p @ p_io pt @ ioA"
                and   "ioA \<in> (atc_to_io_set (from_FSM M (target q pt)) A)"
       using \<open>io \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)\<close>
       by blast
     then have "ioA \<in> L (from_FSM M (target q pt))"
       unfolding atc_to_io_set.simps by blast
 
 
     have "q \<in> fst ` prs"
       using \<open>(q,P) \<in> prs\<close> by force
     
 
     have "is_submachine P M"
       using t2[OF \<open>(q, P) \<in> prs\<close>] unfolding is_preamble_def by blast
     then have "initial P = initial M" by auto
 
     have "path M (initial M) p"
       using submachine_path[OF \<open>is_submachine P M\<close> \<open>path P (initial P) p\<close>] 
       unfolding \<open>initial P = initial M\<close> 
       by assumption
     have "target (initial M) p = q"
       using \<open>target (initial P) p = q\<close> 
       unfolding \<open>initial P = initial M\<close> 
       by assumption
 
     obtain p2 d where "(pt @ p2, d) \<in> m_traversal_paths_with_witness M q repetition_sets m"
       using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pt \<in> tps q\<close> by blast
 
     then have "path M q (pt @ p2)"
       using m_traversal_paths_with_witness_set[OF t5 t8 path_target_is_state[OF \<open>path M (initial M) p\<close>], of m]
       unfolding \<open>target (initial M) p = q\<close> 
       by blast
     then have "path M (initial M) (p@pt)"
       using \<open>path M (initial M) p\<close> \<open>target (initial M) p = q\<close> 
       by auto
     moreover have "(target q pt) = target (initial M) (p@pt)"
       using \<open>target (initial M) p = q\<close>
       by auto
     ultimately have "(target q pt) \<in> states M"
       using path_target_is_state 
       by metis
 
     have "ioA \<in> LS M (target q pt)"
       using from_FSM_language[OF \<open>(target q pt) \<in> states M\<close>] \<open>ioA \<in> L (from_FSM M (target q pt))\<close>
       by blast
     then obtain pA where "path M (target q pt) pA" and "p_io pA = ioA"
       by auto
     then have "path M (initial M) (p @ pt @ pA)"
       using \<open>path M (initial M) (p@pt)\<close>  unfolding \<open>(target q pt) = target (initial M) (p@pt)\<close> 
       by auto
     then have "p_io p @ p_io pt @ ioA \<in> L M"
       unfolding \<open>p_io pA = ioA\<close>[symmetric]
       using language_intro by fastforce
     then show "io \<in> L M"
       unfolding \<open>io = p_io p @ p_io pt @ ioA\<close> 
       by assumption
   qed
 qed
 
   
 lemma minimal_io_seq_to_failure :
   assumes "\<not> (L M' \<subseteq> L M)"
   and     "inputs M' = inputs M"  
   and     "completely_specified M"
 obtains io x y y' where "io@[(x,y)] \<in> L M" and "io@[(x,y')] \<notin>  L M" and "io@[(x,y')] \<in> L M'" 
 proof -
   obtain ioF where "ioF \<in> L M'" and "ioF \<notin> L M"
     using assms(1) by blast
   
 
   let ?prefs = "{ioF' \<in> set (prefixes ioF) . ioF' \<in> L M' \<and> ioF' \<notin> L M}"
   have "finite ?prefs"
     using prefixes_finite by auto
   moreover have "?prefs \<noteq> {}"
     unfolding prefixes_set using \<open>ioF \<in> L M'\<close> \<open>ioF \<notin> L M\<close> by auto
   ultimately obtain ioF' where "ioF' \<in> ?prefs" and "\<And> ioF'' . ioF'' \<in> ?prefs \<Longrightarrow> length ioF' \<le> length ioF''"
     by (meson leI min_length_elem) 
   
   then have "ioF' \<in> L M'" and "ioF' \<notin> L M"
     by auto
   then have "ioF' \<noteq> []" 
     by auto
   then have "ioF' = (butlast ioF')@[last ioF']" and "length (butlast ioF') < length ioF'"
     by auto
   then have "butlast ioF' \<notin> ?prefs"
     using \<open>\<And> ioF'' . ioF'' \<in> ?prefs \<Longrightarrow> length ioF' \<le> length ioF''\<close> leD by blast 
   moreover have "butlast ioF' \<in> L M'"
     using \<open>ioF' \<in> L M'\<close> language_prefix[of "butlast ioF'" "[last ioF']" M' "initial M'"] 
     unfolding \<open>ioF' = (butlast ioF')@[last ioF']\<close>[symmetric] by blast
   moreover have "butlast ioF' \<in> set (prefixes ioF)"
     using \<open>ioF' = (butlast ioF')@[last ioF']\<close> \<open>ioF' \<in> ?prefs\<close> prefixes_set
   proof -
     have "\<exists>ps. (butlast ioF' @ [last ioF']) @ ps = ioF"
       using \<open>ioF' = butlast ioF' @ [last ioF']\<close> \<open>ioF' \<in> {ioF' \<in> set (prefixes ioF). ioF' \<in> L M' \<and> ioF' \<notin> L M}\<close> 
       unfolding prefixes_set 
       by auto
     then show ?thesis
       using prefixes_set by fastforce
   qed
   ultimately have "butlast ioF' \<in> L M" 
     by blast
   
   have *: "(butlast ioF')@[(fst (last ioF'), snd (last ioF'))] \<in> L M'"
     using \<open>ioF' \<in> L M'\<close> \<open>ioF' = (butlast ioF')@[last ioF']\<close> by auto
   have **: "(butlast ioF')@[(fst (last ioF'), snd (last ioF'))] \<notin> L M"
     using \<open>ioF' \<notin> L M\<close> \<open>ioF' = (butlast ioF')@[last ioF']\<close> by auto
   
   obtain p where "path M (initial M) p" and "p_io p = butlast ioF'"
     using \<open>butlast ioF' \<in> L M\<close> by auto
   moreover obtain t where "t \<in> transitions M" 
                       and "t_source t = target (initial M) p" 
                       and "t_input t = fst (last ioF')"
   proof -
     have "fst (last ioF') \<in> inputs M'"
       using language_io(1)[OF *, of "fst (last ioF')" "snd (last ioF')"] 
       by simp 
     then have "fst (last ioF') \<in> inputs M"
       using assms(2) by auto
     then show ?thesis
       using that \<open>completely_specified M\<close> path_target_is_state[OF \<open>path M (initial M) p\<close>] 
       unfolding completely_specified.simps by blast
   qed
   ultimately have ***: "(butlast ioF')@[(fst (last ioF'), t_output t)] \<in> L M"
   proof -
     have "p_io (p @ [t]) \<in> L M"
       by (metis (no_types) \<open>path M (FSM.initial M) p\<close> \<open>t \<in> FSM.transitions M\<close> \<open>t_source t = target (FSM.initial M) p\<close> 
             language_intro path_append single_transition_path)
     then show ?thesis
       by (simp add: \<open>p_io p = butlast ioF'\<close> \<open>t_input t = fst (last ioF')\<close>)
   qed
 
   show ?thesis 
     using that[OF *** ** *] 
     by assumption
 qed
 
 
 
 lemma observable_minimal_path_to_failure :
   assumes "\<not> (L M' \<subseteq> L M)"
   and     "observable M" 
   and     "observable M'"
   and     "inputs M' = inputs M"  
   and     "completely_specified M"
   and     "completely_specified M'"
 obtains p p' t t' where "path M (initial M) (p@[t])" 
                   and   "path M' (initial M') (p'@[t'])"
                   and   "p_io p' = p_io p"
                   and   "t_input t' = t_input t"
                   and   "\<not>(\<exists> t'' . t'' \<in> transitions M \<and> t_source t'' = target (initial M) p \<and> t_input t'' = t_input t \<and> t_output t'' = t_output t')"
 proof -
                
   obtain io x y y' where "io@[(x,y)] \<in> L M" and "io@[(x,y')] \<notin>  L M" and "io@[(x,y')] \<in> L M'" 
     using minimal_io_seq_to_failure[OF assms(1,4,5)] by blast
 
   obtain p t where "path M (initial M) (p@[t])" and "p_io p = io" and "t_input t = x" and "t_output t = y"
     using language_append_path_ob[OF \<open>io@[(x,y)] \<in> L M\<close>] by blast
 
   moreover obtain p' t' where "path M' (initial M') (p'@[t'])" and "p_io p' = io" and "t_input t' = x" and "t_output t' = y'"
     using language_append_path_ob[OF \<open>io@[(x,y')] \<in> L M'\<close>] by blast
 
   moreover have "\<not>(\<exists> t'' . t'' \<in> transitions M \<and> t_source t'' = target (initial M) p \<and> t_input t'' = t_input t \<and> t_output t'' = t_output t')"
   proof 
     assume "\<exists>t''. t'' \<in> FSM.transitions M \<and> t_source t'' = target (FSM.initial M) p \<and> t_input t'' = t_input t \<and> t_output t'' = t_output t'"
     then obtain t'' where "t'' \<in> FSM.transitions M" and "t_source t'' = target (FSM.initial M) p" and "t_input t'' = x" and "t_output t'' = y'"
       unfolding \<open>t_input t = x\<close> \<open>t_output t' = y'\<close> by blast
 
     then have "path M (initial M) (p@[t''])"
       using \<open>path M (initial M) (p@[t])\<close>
       by (meson path_append_elim path_append_transition)
     moreover have "p_io (p@[t'']) = io@[(x,y')]"
       using \<open>p_io p = io\<close> \<open>t_input t'' = x\<close> \<open>t_output t'' = y'\<close> by auto
     ultimately have "io@[(x,y')] \<in> L M"
       using language_state_containment
       by (metis (mono_tags, lifting)) 
     then show "False"
       using \<open>io@[(x,y')] \<notin> L M\<close> by blast
   qed
 
   ultimately show ?thesis using that[of p t p' t']
     by force
 qed
 
 
 
 lemma test_suite_to_io_pass :
   assumes "implies_completeness T M m"
   and     "observable M" 
   and     "observable M'"
   and     "inputs M' = inputs M"
   and     "inputs M \<noteq> {}"
   and     "completely_specified M"
   and     "completely_specified M'"  
 shows "pass_io_set M' (test_suite_to_io M T) = passes_test_suite M T M'"
 proof -
   obtain prs tps rd_targets atcs where "T = Test_Suite prs tps rd_targets atcs"
     by (meson test_suite.exhaust)
   then obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets atcs) M m repetition_sets"
     using assms(1) unfolding implies_completeness_def by blast
   then have "implies_completeness (Test_Suite prs tps rd_targets atcs) M m"
     unfolding implies_completeness_def by blast
   then have test_suite_language_prop: "test_suite_to_io M (Test_Suite prs tps rd_targets atcs) \<subseteq> L M"
     using test_suite_to_io_language by blast
 
 
   have t1: "(initial M, initial_preamble M) \<in> prs" 
     using implies_completeness_for_repetition_sets_simps(1)[OF repetition_sets_def] 
     by assumption
   have t2: "\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q"
     using implies_completeness_for_repetition_sets_simps(2)[OF repetition_sets_def] 
     by blast
   have t3: "\<And> q1 q2 A d1 d2. (A, d1, d2) \<in> atcs (q1, q2) \<Longrightarrow> (A, d2, d1) \<in> atcs (q2, q1) \<and> is_separator M q1 q2 A d1 d2"
     using implies_completeness_for_repetition_sets_simps(3)[OF repetition_sets_def] 
     by assumption
   
   have t5: "\<And>q. q \<in> FSM.states M \<Longrightarrow> (\<exists>d\<in>set repetition_sets. q \<in> fst d)"
     using implies_completeness_for_repetition_sets_simps(4)[OF repetition_sets_def] 
     by assumption
 
   have t6: "\<And> q. q \<in> fst ` prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using implies_completeness_for_repetition_sets_simps(7)[OF repetition_sets_def] 
     by assumption
 
   have t7: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> fst d \<subseteq> FSM.states M"
   and  t8: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d \<subseteq> fst d"
   and  t8':  "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d = fst d \<inter> fst ` prs"
   and  t9: "\<And> d q1 q2. d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> atcs (q1, q2) \<noteq> {}"
     using implies_completeness_for_repetition_sets_simps(5,6)[OF repetition_sets_def] 
     by blast+
     
 
   have "pass_io_set M' (test_suite_to_io M (Test_Suite prs tps rd_targets atcs)) \<Longrightarrow> passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'"
   proof -
     assume "pass_io_set M' (test_suite_to_io M (Test_Suite prs tps rd_targets atcs))"
 
     then have pass_io_prop: "\<And> io x y y' . io @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs) \<Longrightarrow> io @ [(x, y')] \<in> L M' \<Longrightarrow> io @ [(x, y')] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
       unfolding pass_io_set_def 
       by blast
 
     show "passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'"
     proof (rule ccontr)
       assume "\<not> passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'"
 
 
       then consider (a) "\<not> (\<forall>q P io x y y'. (q, P) \<in> prs \<longrightarrow> io @ [(x, y)] \<in> L P \<longrightarrow> io @ [(x, y')] \<in> L M' \<longrightarrow> io @ [(x, y')] \<in> L P)" |
                     (b) "\<not> ((\<forall>q P pP ioT pT x y y'.
                               (q, P) \<in> prs \<longrightarrow>
                               path P (FSM.initial P) pP \<longrightarrow>
                               target (FSM.initial P) pP = q \<longrightarrow>
                               pT \<in> tps q \<longrightarrow>
                               ioT @ [(x, y)] \<in> set (prefixes (p_io pT)) \<longrightarrow>
                               p_io pP @ ioT @ [(x, y')] \<in> L M' \<longrightarrow> (\<exists>pT'. pT' \<in> tps q \<and> ioT @ [(x, y')] \<in> set (prefixes (p_io pT')))))" |
                     (c) "\<not> ((\<forall>q P pP pT.
                               (q, P) \<in> prs \<longrightarrow>
                               path P (FSM.initial P) pP \<longrightarrow>
                               target (FSM.initial P) pP = q \<longrightarrow>
                               pT \<in> tps q \<longrightarrow>
                               p_io pP @ p_io pT \<in> L M' \<longrightarrow>
                               (\<forall>q' A d1 d2 qT.
                                   q' \<in> rd_targets (q, pT) \<longrightarrow>
                                   (A, d1, d2) \<in> atcs (target q pT, q') \<longrightarrow> qT \<in> io_targets M' (p_io pP @ p_io pT) (FSM.initial M') \<longrightarrow> pass_separator_ATC M' A qT d2)))"  
         unfolding passes_test_suite.simps by blast
       then show False proof cases
         case a
         then obtain q P io x y y' where "(q, P) \<in> prs" 
                                     and "io @ [(x, y)] \<in> L P" 
                                     and "io @ [(x, y')] \<in> L M'" 
                                     and "io @ [(x, y')] \<notin> L P"
           by blast
 
         have "is_preamble P M q"
           using t2[OF \<open>(q, P) \<in> prs\<close>] by assumption
         
 
         have "io @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
           unfolding test_suite_to_io.simps using \<open>(q, P) \<in> prs\<close> \<open>io @ [(x, y)] \<in> L P\<close>
           by fastforce
 
         have "io @ [(x, y')] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
           using pass_io_prop[OF \<open>io @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)\<close> \<open>io @ [(x, y')] \<in> L M'\<close>] 
           by assumption
 
         then have "io @ [(x, y')] \<in> L M"
           using test_suite_language_prop 
           by blast
 
         have "io @ [(x, y')] \<in> L P"
           using passes_test_suite_soundness_helper_1[OF \<open>is_preamble P M q\<close> \<open>observable M\<close> \<open>io @ [(x, y)] \<in> L P\<close> \<open>io @ [(x, y')] \<in> L M\<close>] 
           by assumption
         then show "False"
           using \<open>io @ [(x, y')] \<notin> L P\<close> 
           by blast
 
       next
         case b
         then obtain q P pP ioT pT x y y' where "(q, P) \<in> prs"
                                            and "path P (FSM.initial P) pP"
                                            and "target (FSM.initial P) pP = q"
                                            and "pT \<in> tps q"
                                            and "ioT @ [(x, y)] \<in> set (prefixes (p_io pT))"
                                            and "p_io pP @ ioT @ [(x, y')] \<in> L M'"
                                            and "\<not> (\<exists>pT'. pT' \<in> tps q \<and> ioT @ [(x, y')] \<in> set (prefixes (p_io pT')))"
           by blast
 
         have "\<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) pP \<and> target (FSM.initial P) pP = q \<and> pT \<in> tps q"
           using \<open>(q, P) \<in> prs\<close> \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>pT \<in> tps q\<close> by blast
         moreover have "p_io pP @ ioT @ [(x, y)] \<in> (@) (p_io pP) ` set (prefixes (p_io pT))"
           using \<open>ioT @ [(x, y)] \<in> set (prefixes (p_io pT))\<close> by auto
         ultimately have "p_io pP @ ioT @ [(x, y)] \<in> (\<Union>{(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q})"
           by blast
         then have "p_io pP @ ioT @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
           unfolding test_suite_to_io.simps  
           by blast
         then have *: "(p_io pP @ ioT) @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
           by auto
 
         have **: "(p_io pP @ ioT) @ [(x, y')] \<in> L M'"
           using \<open>p_io pP @ ioT @ [(x, y')] \<in> L M'\<close> by auto
 
         have "(p_io pP @ ioT) @ [(x, y')] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
           using pass_io_prop[OF * ** ] by assumption
         then have "(p_io pP @ ioT) @ [(x, y')] \<in> L M"
           using test_suite_language_prop by blast
 
         have "q \<in> states M"
           using is_preamble_is_state[OF t2[OF \<open>(q, P) \<in> prs\<close>]] by assumption
 
         have "q \<in> fst ` prs" 
           using \<open>(q, P) \<in> prs\<close> by force
 
         obtain pT' d' where "(pT @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
           using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pT \<in> tps q\<close> by blast
 
         then have "path M q (pT @ pT')"
              and  "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (pT @ pT'))) repetition_sets = Some d'"
              and  "\<And> p' p''. (pT @ pT') = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
           using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m]
           by blast+
 
         obtain ioT' where "p_io pT = ioT @ [(x,y)] @ ioT'"
           using prefixes_set_ob[OF \<open>ioT @ [(x, y)] \<in> set (prefixes (p_io pT))\<close>] 
           unfolding prefixes_set append.assoc[symmetric] 
           by blast
 
         let ?pt = "take (length (ioT @ [(x,y)])) pT"
         let ?p  = "butlast ?pt"
         let ?t  = "last ?pt"
          
 
         have "length ?pt > 0"
           using \<open>p_io pT = ioT @ [(x,y)] @ ioT'\<close> 
           unfolding length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric] 
           by auto
         then have "?pt = ?p @ [?t]"
           by auto
         moreover have "path M q ?pt"
           using \<open>path M q (pT @ pT')\<close>
           by (meson path_prefix path_prefix_take)
         ultimately have "path M q (?p@[?t])"
           by simp
 
         have "p_io ?p = ioT"
         proof -
           have "p_io ?pt = take (length (ioT @ [(x,y)])) (p_io pT)"
             by (simp add: take_map) 
           then have "p_io ?pt = ioT @ [(x,y)]"
             using \<open>p_io pT = ioT @ [(x,y)] @ ioT'\<close> by auto
           then show ?thesis
             by (simp add: map_butlast) 
         qed
 
         have "path M q ?p"
           using path_append_transition_elim[OF \<open>path M q (?p@[?t])\<close>] by blast
         
         have "is_submachine P M"
           using t2[OF \<open>(q, P) \<in> prs\<close>] unfolding is_preamble_def by blast
         then have "initial P = initial M" by auto
     
         have "path M (initial M) pP"
           using submachine_path[OF \<open>is_submachine P M\<close> \<open>path P (initial P) pP\<close>] 
           unfolding \<open>initial P = initial M\<close> 
           by assumption
         moreover have "target (initial M) pP = q"
           using \<open>target (initial P) pP = q\<close> 
           unfolding \<open>initial P = initial M\<close> 
           by assumption
         ultimately have "path M (initial M) (pP@?p)" 
           using \<open>path M q ?p\<close> 
           by auto
       
 
         have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)) repetition_sets = None"
         proof -
           have *: "(pT @ pT') = ?p @ ([?t] @ (drop (length (ioT @ [(x,y)])) pT) @ pT')" 
             using \<open>?pt = ?p @ [?t]\<close>
             by (metis append_assoc append_take_drop_id) 
           have **: "([?t] @ (drop (length (ioT @ [(x,y)])) pT) @ pT') \<noteq> []"
             by simp
           show ?thesis 
             using \<open>\<And> p' p''. (pT @ pT') = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None\<close>[OF * **] 
             by assumption
         qed
 
 
         (* obtain paths from the transition ending in y' to get a transition from ?p *)
         obtain p' t' where "path M (FSM.initial M) (p' @ [t'])" and "p_io p' = p_io pP @ ioT" and "t_input t' = x" and "t_output t' = y'"
           using language_append_path_ob[OF \<open>(p_io pP @ ioT) @ [(x, y')] \<in> L M\<close>] by blast
         then have "path M (FSM.initial M) p'" and "t_source t' = target (initial M) p'" and "t' \<in> transitions M"
           by auto
         
         have "p' = pP @ ?p"
           using observable_path_unique[OF \<open>observable M\<close> \<open>path M (FSM.initial M) p'\<close> \<open>path M (initial M) (pP@?p)\<close>] 
                 \<open>p_io ?p = ioT\<close> 
           unfolding \<open>p_io p' = p_io pP @ ioT\<close>
           by simp 
         then have "t_source t' = target q ?p"
           unfolding \<open>t_source t' = target (initial M) p'\<close> using \<open>target (initial M) pP = q\<close>
           by auto  
                 
         obtain pTt' dt' where "(?p @ [t'] @ pTt', dt') \<in> m_traversal_paths_with_witness M q repetition_sets m"
           using m_traversal_path_extension_exist_for_transition[OF \<open>completely_specified M\<close> \<open>q \<in> states M\<close> \<open>FSM.inputs M \<noteq> {}\<close> 
                                                                    t5 t8 \<open>path M q ?p\<close> \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)) repetition_sets = None\<close> 
                                                                    \<open>t' \<in> transitions M\<close> \<open>t_source t' = target q ?p\<close>]
           by blast
 
         have "?p @ [t'] @ pTt' \<in> tps q"
           using t6[OF \<open>q \<in> fst ` prs\<close> ] \<open>(?p @ [t'] @ pTt', dt') \<in> m_traversal_paths_with_witness M q repetition_sets m\<close>
           by force
         moreover have "ioT @ [(x, y')] \<in> set (prefixes (p_io (?p @ [t'] @ pTt')))"
         proof -
           have "p_io (?p @ [t'] @ pTt') = ioT @ [(x,y')] @ p_io pTt'"
             using \<open>p_io ?p = ioT\<close> using \<open>t_input t' = x\<close> \<open>t_output t' = y'\<close> 
             by auto  
           then show ?thesis 
             unfolding prefixes_set
             by force
         qed
 
         ultimately show "False"
           using \<open>\<not> (\<exists>pT'. pT' \<in> tps q \<and> ioT @ [(x, y')] \<in> set (prefixes (p_io pT')))\<close> 
           by blast
       next
         case c
 
         then obtain q P pP pT q' A d1 d2 qT  where "(q, P) \<in> prs"
                                              and   "path P (FSM.initial P) pP"
                                              and   "target (FSM.initial P) pP = q"
                                              and   "pT \<in> tps q"
                                              and   "p_io pP @ p_io pT \<in> L M'"
                                              and   "q' \<in> rd_targets (q, pT)"
                                              and   "(A, d1, d2) \<in> atcs (target q pT, q')"
                                              and   "qT \<in> io_targets M' (p_io pP @ p_io pT) (FSM.initial M')"
                                              and   "\<not>pass_separator_ATC M' A qT d2"
           by blast
 
 
         have "is_submachine P M"
           using t2[OF \<open>(q, P) \<in> prs\<close>] 
           unfolding is_preamble_def 
           by blast
         then have "initial P = initial M" by auto
     
         have "path M (initial M) pP"
           using submachine_path[OF \<open>is_submachine P M\<close> \<open>path P (initial P) pP\<close>] 
           unfolding \<open>initial P = initial M\<close> 
           by assumption
         have "target (initial M) pP = q"
           using \<open>target (initial P) pP = q\<close> 
           unfolding \<open>initial P = initial M\<close> 
           by assumption
 
         have "q \<in> states M"
           using is_preamble_is_state[OF t2[OF \<open>(q, P) \<in> prs\<close>]] 
           by assumption
 
         have "q \<in> fst ` prs" 
           using \<open>(q, P) \<in> prs\<close> by force
 
         obtain pT' d' where "(pT @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
           using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pT \<in> tps q\<close> by blast
 
         then have "path M q (pT @ pT')"
              and  "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (pT @ pT'))) repetition_sets = Some d'"
              and  "\<And> p' p''. (pT @ pT') = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
           using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m]
           by blast+
         then have "path M q pT"
           by auto
 
         have "qT \<in> states M'"
           using \<open>qT \<in> io_targets M' (p_io pP @ p_io pT) (FSM.initial M')\<close> io_targets_states subset_iff 
           by fastforce 
 
 
 
         have "is_separator M (target q pT) q' A d1 d2"
           using  t3[OF \<open>(A, d1, d2) \<in> atcs (target q pT, q')\<close>] by blast
 
         have "\<not> pass_io_set (FSM.from_FSM M' qT) (atc_to_io_set (FSM.from_FSM M (target q pT)) A)"
           using \<open>\<not>pass_separator_ATC M' A qT d2\<close>
                 pass_separator_pass_io_set_iff[OF \<open>is_separator M (target q pT) q' A d1 d2\<close> \<open>observable M\<close> 
                                                   \<open>observable M'\<close> path_target_is_state[OF \<open>path M q pT\<close>] 
                                                   \<open>qT \<in> states M'\<close> \<open>inputs M' = inputs M\<close> \<open>completely_specified M\<close>]
           by simp
 
 
         have "pass_io_set (FSM.from_FSM M' qT) (atc_to_io_set (FSM.from_FSM M (target q pT)) A)"
         proof -
           have "\<And> io x y y' . io @ [(x, y)] \<in> atc_to_io_set (FSM.from_FSM M (target q pT)) A \<Longrightarrow>
                                io @ [(x, y')] \<in> L (FSM.from_FSM M' qT) \<Longrightarrow> 
                                 io @ [(x, y')] \<in> atc_to_io_set (FSM.from_FSM M (target q pT)) A"
           proof -
             fix io x y y' assume "io @ [(x, y)] \<in> atc_to_io_set (FSM.from_FSM M (target q pT)) A"
                           and    "io @ [(x, y')] \<in> L (FSM.from_FSM M' qT)"
 
 
             (* subsets of test_suite_to_io *)
             define tmp where tmp_def : "tmp = (\<Union> {(\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A |p pt q A. \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')})"
             define tmp2 where tmp2_def : "tmp2 = \<Union> {(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q}"
             have "\<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) pP \<and> target (FSM.initial P) pP = q \<and> pT \<in> tps q \<and> q' \<in> rd_targets (q, pT) \<and> (A, t1, t2) \<in> atcs (target q pT, q')"
               using \<open>(q, P) \<in> prs\<close> \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>pT \<in> tps q\<close> \<open>q' \<in> rd_targets (q, pT)\<close> \<open>(A, d1, d2) \<in> atcs (target q pT, q')\<close> by blast
             then have "(\<lambda>io_atc. p_io pP @ p_io pT @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pT)) A \<subseteq> tmp"
               unfolding tmp_def by blast
             then have "(\<lambda>io_atc. p_io pP @ p_io pT @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pT)) A \<subseteq> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
               unfolding test_suite_to_io.simps tmp_def[symmetric] tmp2_def[symmetric] by blast
             moreover have "(p_io pP @ p_io pT @ (io @ [(x, y)])) \<in> (\<lambda>io_atc. p_io pP @ p_io pT @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pT)) A"
               using \<open>io @ [(x, y)] \<in> atc_to_io_set (FSM.from_FSM M (target q pT)) A\<close> by auto
             ultimately have "(p_io pP @ p_io pT @ (io @ [(x, y)])) \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
               by blast
             then have *: "(p_io pP @ p_io pT @ io) @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
               by simp
 
             have "io @ [(x, y')] \<in> LS M' qT"
               using \<open>io @ [(x, y')] \<in> L (FSM.from_FSM M' qT)\<close> \<open>qT \<in> states M'\<close>
               by (metis from_FSM_language) 
             have **: "(p_io pP @ p_io pT @ io) @ [(x, y')] \<in> L M'" 
               using io_targets_language_append[OF \<open>qT \<in> io_targets M' (p_io pP @ p_io pT) (FSM.initial M')\<close> \<open>io @ [(x, y')] \<in> LS M' qT\<close>] 
               by simp            
             
             have "(p_io pP @ p_io pT) @ (io @ [(x, y')]) \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
               using pass_io_prop[OF * ** ] by simp
             then have "(p_io pP @ p_io pT) @ (io @ [(x, y')]) \<in> L M"
               using test_suite_language_prop by blast
 
             moreover have "target q pT \<in> io_targets M (p_io pP @ p_io pT) (initial M)"
             proof -
               have "target (initial M) (pP@pT) = target q pT"
                 unfolding \<open>target (initial M) pP = q\<close>[symmetric] by auto
               moreover have "path M (initial M) (pP@pT)"
                 using \<open>path M (initial M) pP\<close> \<open>path M q pT\<close> unfolding \<open>target (initial M) pP = q\<close>[symmetric] 
                 by auto
               moreover have "p_io (pP@pT) = (p_io pP @ p_io pT)" 
                 by auto
               ultimately show ?thesis
                 unfolding io_targets.simps
                 by (metis (mono_tags, lifting) mem_Collect_eq) 
             qed
 
             ultimately have "io @ [(x, y')] \<in> LS M (target q pT)"
               using observable_io_targets_language[OF _ \<open>observable M\<close>, of "(p_io pP @ p_io pT)" "(io @ [(x, y')])" "initial M" "target q pT"] 
               by blast            
             then have "io @ [(x, y')] \<in> L (FSM.from_FSM M (target q pT))"
               unfolding from_FSM_language[OF path_target_is_state[OF \<open>path M q pT\<close>]] 
               by assumption
 
             moreover have "io @ [(x, y')] \<in> L A"
               by (metis Int_iff \<open>io @ [(x, y')] \<in> LS M (target q pT)\<close> \<open>io @ [(x, y)] \<in> atc_to_io_set (FSM.from_FSM M (target q pT)) A\<close> 
                       \<open>is_separator M (target q pT) q' A d1 d2\<close> atc_to_io_set.simps is_separator_simps(9))
               
             ultimately show "io @ [(x, y')] \<in> atc_to_io_set (FSM.from_FSM M (target q pT)) A"
               unfolding atc_to_io_set.simps by blast
           qed
               
           then show ?thesis unfolding pass_io_set_def by blast
         qed
 
         then show "False"
           using pass_separator_from_pass_io_set[OF \<open>is_separator M (target q pT) q' A d1 d2\<close> _ \<open>observable M\<close> 
                                                    \<open>observable M'\<close> path_target_is_state[OF \<open>path M q pT\<close>] 
                                                    \<open>qT \<in> states M'\<close> \<open>inputs M' = inputs M\<close> \<open>completely_specified M\<close>]
                 \<open>\<not>pass_separator_ATC M' A qT d2\<close>
           by simp
       qed
     qed
   qed
 
   moreover have "passes_test_suite M (Test_Suite prs tps rd_targets atcs) M' \<Longrightarrow> pass_io_set M' (test_suite_to_io M (Test_Suite prs tps rd_targets atcs))"
   proof -
     assume "passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'"
 
     (* pass properties *)
   
     have pass1: "\<And> q P io x y y' . (q,P) \<in> prs \<Longrightarrow> io@[(x,y)] \<in> L P \<Longrightarrow> io@[(x,y')] \<in> L M' \<Longrightarrow> io@[(x,y')] \<in> L P" 
       using \<open>passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'\<close>
       unfolding passes_test_suite.simps
       by meson 
   
     have pass2: "\<And> q P pP ioT pT x y y' . (q,P) \<in> prs \<Longrightarrow> path P (initial P) pP \<Longrightarrow> target (initial P) pP = q \<Longrightarrow> pT \<in> tps q \<Longrightarrow> ioT@[(x,y)] \<in> set (prefixes (p_io pT)) \<Longrightarrow> (p_io pP)@ioT@[(x,y')] \<in> L M' \<Longrightarrow> (\<exists> pT' . pT' \<in> tps q \<and> ioT@[(x,y')] \<in> set (prefixes (p_io pT')))"
       using \<open>passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'\<close>
       unfolding passes_test_suite.simps by blast
   
     have pass3: "\<And> q P pP pT q' A d1 d2 qT . (q,P) \<in> prs \<Longrightarrow> path P (initial P) pP \<Longrightarrow> target (initial P) pP = q \<Longrightarrow> pT \<in> tps q \<Longrightarrow> (p_io pP)@(p_io pT) \<in> L M' \<Longrightarrow> q' \<in> rd_targets (q,pT) \<Longrightarrow> (A,d1,d2) \<in> atcs (target q pT, q') \<Longrightarrow> qT \<in> io_targets M' ((p_io pP)@(p_io pT)) (initial M') \<Longrightarrow> pass_separator_ATC M' A qT d2"  
       using \<open>passes_test_suite M (Test_Suite prs tps rd_targets atcs) M'\<close>
       unfolding passes_test_suite.simps by blast
 
 
 
     show "pass_io_set M' (test_suite_to_io M (Test_Suite prs tps rd_targets atcs))"
     proof (rule ccontr)
       assume "\<not> pass_io_set M' (test_suite_to_io M (Test_Suite prs tps rd_targets atcs))"
       then obtain io x y y' where "io @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
                             and   "io @ [(x, y')] \<in> L M'" 
                             and   "io @ [(x, y')] \<notin> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
         unfolding pass_io_set_def by blast
           
        
 
       have preamble_prop: "\<And> q P . (q, P) \<in> prs \<Longrightarrow> io @ [(x, y)] \<in> L P \<Longrightarrow> False"
       proof - 
         fix q P assume "(q, P)\<in>prs" and "io @ [(x, y)] \<in> L P" 
         have "io @ [(x, y')] \<in> L P" using pass1[OF \<open>(q, P)\<in>prs\<close> \<open>io @ [(x, y)] \<in> L P\<close> \<open>io @ [(x, y')] \<in> L M'\<close> ] 
           by assumption
         then have "io @ [(x, y')] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
           unfolding test_suite_to_io.simps using \<open>(q, P)\<in>prs\<close> by blast
         then show "False" using \<open>io @ [(x, y')] \<notin> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)\<close> 
           by simp
       qed
 
       have traversal_path_prop : "\<And> pP pt q P .  io @ [(x, y)] \<in> (@) (p_io pP) ` set (prefixes (p_io pt)) \<Longrightarrow> (q, P) \<in> prs \<Longrightarrow> path P (FSM.initial P) pP \<Longrightarrow> target (FSM.initial P) pP = q \<Longrightarrow> pt \<in> tps q \<Longrightarrow> False"
       proof -
         fix pP pt q P assume "io @ [(x, y)] \<in> (@) (p_io pP) ` set (prefixes (p_io pt))"
                        and   "(q, P) \<in> prs" 
                        and   "path P (FSM.initial P) pP"
                        and   "target (FSM.initial P) pP = q"
                        and   "pt \<in> tps q"
 
         obtain io' io'' where "io @ [(x, y)] = (p_io pP) @ io'" and "io'@io'' = p_io pt"
           using \<open>io @ [(x, y)] \<in> (@) (p_io pP) ` set (prefixes (p_io pt))\<close> 
           unfolding prefixes_set
           by blast 
 
 
         have "is_submachine P M"
           using t2[OF \<open>(q, P) \<in> prs\<close>] 
           unfolding is_preamble_def 
           by blast
         then have "initial P = initial M" 
           by auto
     
         have "path M (initial M) pP"
           using submachine_path[OF \<open>is_submachine P M\<close> \<open>path P (initial P) pP\<close>] 
           unfolding \<open>initial P = initial M\<close> 
           by assumption
         have "target (initial M) pP = q"
           using \<open>target (initial P) pP = q\<close> 
           unfolding \<open>initial P = initial M\<close> 
           by assumption
 
         have "q \<in> states M"
           using is_preamble_is_state[OF t2[OF \<open>(q, P) \<in> prs\<close>]] 
           by assumption
 
         have "q \<in> fst ` prs" 
           using \<open>(q, P) \<in> prs\<close> by force
 
 
         show "False" proof (cases io' rule: rev_cases)
           case Nil
           then have "p_io pP = io @ [(x, y)]" 
             using \<open>io @ [(x, y)] = (p_io pP) @ io'\<close>
             by auto
           show ?thesis
             using preamble_prop[OF \<open>(q,P) \<in> prs\<close> language_state_containment[OF \<open>path P (FSM.initial P) pP\<close> \<open>p_io pP = io @ [(x, y)]\<close>]]
             by assumption
         next
           case (snoc ioI xy)
           then have "xy = (x,y)" and "io = (p_io pP) @ ioI"
             using \<open>io @ [(x, y)] = (p_io pP) @ io'\<close> by auto 
           then have "p_io pP @ ioI @ [(x, y')] \<in> L M'"
             using \<open>io @ [(x, y')] \<in> L M'\<close> by simp
 
           have "ioI @ [(x, y)] \<in> set (prefixes (p_io pt))"
             unfolding prefixes_set
             using \<open>io' @ io'' = p_io pt\<close> \<open>xy = (x, y)\<close> snoc 
             by auto 
 
           obtain pT' where "pT' \<in> tps q" and "ioI @ [(x, y')] \<in> set (prefixes (p_io pT'))"
             using pass2[OF \<open>(q, P) \<in> prs\<close> \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>pt \<in> tps q\<close>
                            \<open>ioI @ [(x, y)] \<in> set (prefixes (p_io pt))\<close> \<open>p_io pP @ ioI @ [(x, y')] \<in> L M'\<close>] by blast
 
           have "io @ [(x, y')] \<in> (@) (p_io pP) ` set (prefixes (p_io pT'))"
             using \<open>ioI @ [(x, y')] \<in> set (prefixes (p_io pT'))\<close> 
             unfolding \<open>io = (p_io pP) @ ioI\<close>
             by simp
 
           
           have "io @ [(x, y')] \<in> (\<Union> {(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q})"
             using \<open>(q, P) \<in> prs\<close> \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> 
                   \<open>pT' \<in> tps q\<close> \<open>io @ [(x, y')] \<in> (@) (p_io pP) ` set (prefixes (p_io pT'))\<close> 
             by blast
           then have "io @ [(x, y')] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
             unfolding test_suite_to_io.simps 
             by blast
 
           then show "False"
             using \<open>io @ [(x, y')] \<notin> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)\<close> 
             by blast
         qed
       qed
 
       consider (a) "io @ [(x, y)] \<in> (\<Union>(q, P)\<in>prs. L P)" |
                (b) "io @ [(x, y)] \<in> (\<Union> {(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q})" |
                (c) "io @ [(x, y)] \<in> (\<Union> {(\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A |p pt q A.
                                            \<exists>P q' t1 t2.
                                               (q, P) \<in> prs \<and>
                                               path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')})"
         using \<open>io @ [(x, y)] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)\<close>
         unfolding test_suite_to_io.simps by blast
 
       then show "False" proof cases
         case a 
         then show ?thesis using preamble_prop by blast
       next
         case b
         then show ?thesis using traversal_path_prop by blast
       next
         case c
 
         then obtain pP pt q A P q' t1 t2 where "io @ [(x, y)] \<in> (\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A"
                                           and "(q, P) \<in> prs"
                                           and "path P (FSM.initial P) pP"
                                           and "target (FSM.initial P) pP = q" 
                                           and "pt \<in> tps q" 
                                           and "q' \<in> rd_targets (q, pt)" 
                                           and "(A, t1, t2) \<in> atcs (target q pt, q')"
           by blast
 
         obtain ioA where "io @ [(x, y)] = p_io pP @ p_io pt @ ioA"
           using \<open>io @ [(x, y)] \<in> (\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A\<close> 
           unfolding prefixes_set
           by blast 
 
         show "False" proof (cases ioA rule: rev_cases)
           case Nil
           then have "io @ [(x, y)] = p_io pP @ p_io pt"
             using \<open>io @ [(x, y)] = p_io pP @ p_io pt @ ioA\<close> by simp
           then have "io @ [(x, y)] \<in> (@) (p_io pP) ` set (prefixes (p_io pt))"
             unfolding prefixes_set by blast
           show ?thesis 
             using traversal_path_prop[OF \<open>io @ [(x, y)] \<in> (@) (p_io pP) ` set (prefixes (p_io pt))\<close> \<open>(q, P) \<in> prs\<close> 
                                          \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>pt \<in> tps q\<close>]
             by assumption
         next
           case (snoc ioAI xy)
           then have "xy = (x,y)" and "io = p_io pP @ p_io pt @ ioAI"
             using \<open>io @ [(x, y)] = p_io pP @ p_io pt @ ioA\<close> by simp+
           then have "p_io pP @ p_io pt @ ioAI @ [(x,y)] \<in> (\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A"
             using \<open>io @ [(x, y)] \<in> (\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A\<close> 
             by auto
           then have "ioAI @ [(x,y)] \<in> atc_to_io_set (FSM.from_FSM M (target q pt)) A" 
             by auto
 
 
           have "p_io pP @ p_io pt \<in> L M'"
             using \<open>io @ [(x,y')] \<in> L M'\<close> language_prefix[of "p_io pP @ p_io pt" "ioAI @ [(x, y')]" M' "initial M'"] 
             unfolding \<open>io = p_io pP @ p_io pt @ ioAI\<close>
             by simp
           then obtain pt' where "path M' (initial M') pt'" and "p_io pt' = p_io pP @ p_io pt"
             by auto
           then have  "target (initial M') pt' \<in> io_targets M' (p_io pP @ p_io pt) (FSM.initial M')"
             by fastforce
               
             
           have "pass_separator_ATC M' A (target (FSM.initial M') pt') t2"
             using pass3[OF \<open>(q, P) \<in> prs\<close> \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>pt \<in> tps q\<close> 
                            \<open>p_io pP @ p_io pt \<in> L M'\<close> \<open>q' \<in> rd_targets (q, pt)\<close> \<open>(A, t1, t2) \<in> atcs (target q pt, q')\<close> 
                            \<open>target (initial M') pt' \<in> io_targets M' (p_io pP @ p_io pt) (FSM.initial M')\<close>]
             by assumption
 
           have "is_separator M (target q pt) q' A t1 t2"
             using  t3[OF \<open>(A, t1, t2) \<in> atcs (target q pt, q')\<close>] by blast
 
           have "is_submachine P M"
             using t2[OF \<open>(q, P) \<in> prs\<close>] unfolding is_preamble_def by blast
           then have "initial P = initial M" by auto
       
           have "path M (initial M) pP"
             using submachine_path[OF \<open>is_submachine P M\<close> \<open>path P (initial P) pP\<close>] 
             unfolding \<open>initial P = initial M\<close> 
             by assumption
           have "target (initial M) pP = q"
             using \<open>target (initial P) pP = q\<close> 
             unfolding \<open>initial P = initial M\<close> 
             by assumption
   
           have "q \<in> states M"
             using is_preamble_is_state[OF t2[OF \<open>(q, P) \<in> prs\<close>]] 
             by assumption
   
           have "q \<in> fst ` prs" 
             using \<open>(q, P) \<in> prs\<close> by force
   
           obtain pT' d' where "(pt @ pT', d') \<in> m_traversal_paths_with_witness M q repetition_sets m"
             using t6[OF \<open>q \<in> fst ` prs\<close>] \<open>pt \<in> tps q\<close> 
             by blast
   
           then have "path M q (pt @ pT')"
                and  "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (pt @ pT'))) repetition_sets = Some d'"
                and  "\<And> p' p''. (pt @ pT') = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repetition_sets = None"
             using m_traversal_paths_with_witness_set[OF t5 t8 \<open>q \<in> states M\<close>, of m]
             by blast+
           then have "path M q pt"
             by auto
   
           have "target (initial M') pt' \<in> states M'"
             using \<open>target (initial M') pt' \<in> io_targets M' (p_io pP @ p_io pt) (FSM.initial M')\<close> io_targets_states
             using subset_iff 
             by fastforce 
 
 
           have "pass_io_set (FSM.from_FSM M' (target (FSM.initial M') pt')) (atc_to_io_set (FSM.from_FSM M (target q pt)) A)"
             using  pass_io_set_from_pass_separator[OF \<open>is_separator M (target q pt) q' A t1 t2\<close> 
                                                       \<open>pass_separator_ATC M' A (target (FSM.initial M') pt') t2\<close> 
                                                       \<open>observable M\<close> \<open>observable M'\<close> path_target_is_state[OF \<open>path M q pt\<close>] 
                                                       \<open>target (FSM.initial M') pt' \<in> FSM.states M'\<close> \<open>inputs M' = inputs M\<close>]
             by assumption
           moreover note \<open>ioAI @ [(x,y)] \<in> atc_to_io_set (FSM.from_FSM M (target q pt)) A\<close>
           moreover have "ioAI @ [(x, y')] \<in> L (FSM.from_FSM M' (target (FSM.initial M') pt'))" 
             using \<open>io @ [(x,y')] \<in> L M'\<close>   unfolding \<open>io = p_io pP @ p_io pt @ ioAI\<close>
             by (metis (no_types, lifting) \<open>target (FSM.initial M') pt' \<in> FSM.states M'\<close> 
                   \<open>target (FSM.initial M') pt' \<in> io_targets M' (p_io pP @ p_io pt) (FSM.initial M')\<close> 
                   append_assoc assms(3) from_FSM_language observable_io_targets_language)
 
           ultimately have "ioAI @ [(x,y')] \<in> atc_to_io_set (FSM.from_FSM M (target q pt)) A"
             unfolding pass_io_set_def by blast
 
 
           (* subsets of test_suite_to_io *)
           define tmp where tmp_def : "tmp = (\<Union> {(\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A |p pt q A. \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')})"
           define tmp2 where tmp2_def : "tmp2 = \<Union> {(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q}"
           have "\<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) pP \<and> target (FSM.initial P) pP = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')"
             using \<open>(q, P) \<in> prs\<close> \<open>path P (FSM.initial P) pP\<close> \<open>target (FSM.initial P) pP = q\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q, pt)\<close> \<open>(A, t1, t2) \<in> atcs (target q pt, q')\<close> by blast
           then have "(\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A \<subseteq> tmp"
             unfolding tmp_def by blast
           then have "(\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A \<subseteq> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
             unfolding test_suite_to_io.simps tmp_def[symmetric] tmp2_def[symmetric] by blast
           moreover have "(p_io pP @ p_io pt @ (ioAI @ [(x, y')])) \<in> (\<lambda>io_atc. p_io pP @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A"
             using \<open>ioAI @ [(x, y')] \<in> atc_to_io_set (FSM.from_FSM M (target q pt)) A\<close> by auto
           ultimately have "(p_io pP @ p_io pt @ (ioAI @ [(x, y')])) \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
             by blast
           then have "io @ [(x, y')] \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
             unfolding \<open>io = p_io pP @ p_io pt @ ioAI\<close> by auto
           then show "False"
             using \<open>io @ [(x, y')] \<notin> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)\<close> 
             by blast
         qed
       qed
     qed
   qed
 
   ultimately show ?thesis 
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> 
     by blast
 qed
 
 
 
 lemma test_suite_to_io_finite :
   assumes "implies_completeness T M m"
   and     "is_finite_test_suite T"
 shows "finite (test_suite_to_io M T)"
 proof -
   obtain prs tps rd_targets atcs where "T = Test_Suite prs tps rd_targets atcs"
     by (meson test_suite.exhaust)
   then obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets atcs) M m repetition_sets"
     using assms(1) 
     unfolding implies_completeness_def 
     by blast
   then have "implies_completeness (Test_Suite prs tps rd_targets atcs) M m"
     unfolding implies_completeness_def 
     by blast
   then have test_suite_language_prop: "test_suite_to_io M (Test_Suite prs tps rd_targets atcs) \<subseteq> L M"
     using test_suite_to_io_language 
     by blast
 
   have f1: "(finite prs)" 
   and  f2: "\<And> q p . q \<in> fst ` prs \<Longrightarrow> finite (rd_targets (q,p))" 
   and  f3: "\<And> q q' . finite (atcs (q,q'))"
     using assms(2) 
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> is_finite_test_suite.simps 
     by blast+
 
   have t1: "(initial M, initial_preamble M) \<in> prs" 
     using implies_completeness_for_repetition_sets_simps(1)[OF repetition_sets_def] 
     by assumption
   have t2: "\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q"
     using implies_completeness_for_repetition_sets_simps(2)[OF repetition_sets_def] 
     by blast
   have t3: "\<And> q1 q2 A d1 d2. (A, d1, d2) \<in> atcs (q1, q2) \<Longrightarrow> (A, d2, d1) \<in> atcs (q2, q1) \<and> is_separator M q1 q2 A d1 d2"
     using implies_completeness_for_repetition_sets_simps(3)[OF repetition_sets_def] 
     by assumption
   
   have t5: "\<And>q. q \<in> FSM.states M \<Longrightarrow> (\<exists>d\<in>set repetition_sets. q \<in> fst d)"
     using implies_completeness_for_repetition_sets_simps(4)[OF repetition_sets_def] 
     by assumption
 
   have t6: "\<And> q. q \<in> fst ` prs \<Longrightarrow> tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<and> fst ` (m_traversal_paths_with_witness M q repetition_sets m) \<subseteq> tps q"
     using implies_completeness_for_repetition_sets_simps(7)[OF repetition_sets_def] 
     by assumption
 
   have t7: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> fst d \<subseteq> FSM.states M"
   and  t8: "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d \<subseteq> fst d"
   and  t8':  "\<And> d. d \<in> set repetition_sets \<Longrightarrow> snd d = fst d \<inter> fst ` prs"
   and  t9: "\<And> d q1 q2. d \<in> set repetition_sets \<Longrightarrow> q1 \<in> fst d \<Longrightarrow> q2 \<in> fst d \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> atcs (q1, q2) \<noteq> {}"
     using implies_completeness_for_repetition_sets_simps(5,6)[OF repetition_sets_def] 
     by blast+
 
 
   have f4: "\<And> q . q \<in> fst ` prs \<Longrightarrow> finite (tps q)"
   proof -
     fix q assume "q \<in> fst ` prs"
     then have "tps q \<subseteq> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m}"
       using t6 by blast
     moreover have "{p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m} \<subseteq> (\<Union> p2 \<in> fst ` m_traversal_paths_with_witness M q repetition_sets m . set (prefixes p2))"
     proof 
       fix p1 assume "p1 \<in> {p1 . \<exists> p2 d . (p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m}"
       then obtain p2 d where "(p1@p2,d) \<in> m_traversal_paths_with_witness M q repetition_sets m" by blast
       then have "p1@p2 \<in> fst ` m_traversal_paths_with_witness M q repetition_sets m" by force
       moreover have "p1 \<in> set (prefixes (p1@p2))" unfolding prefixes_set by blast
       ultimately show "p1 \<in> (\<Union> p2 \<in> fst ` m_traversal_paths_with_witness M q repetition_sets m . set (prefixes p2))" by blast
     qed
     ultimately have "tps q \<subseteq> (\<Union> p2 \<in> fst ` m_traversal_paths_with_witness M q repetition_sets m . set (prefixes p2))"
       by simp
     moreover have "finite (\<Union> p2 \<in> fst ` m_traversal_paths_with_witness M q repetition_sets m . set (prefixes p2))"
     proof -
       have "finite (fst ` m_traversal_paths_with_witness M q repetition_sets m)"
         using m_traversal_paths_with_witness_finite[of M q repetition_sets m] by auto
       moreover have "\<And> p2 . finite (set (prefixes p2))" by auto
       ultimately show ?thesis by blast
     qed
     ultimately show "finite (tps q)"
       using finite_subset by blast 
   qed
   then have f4' : "\<And> q P . (q,P) \<in> prs \<Longrightarrow> finite (tps q)"
     by force
 
   define T1 where T1_def : "T1 = (\<Union>(q, P)\<in>prs. L P)"
   define T2 where T2_def : "T2 = \<Union>{(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q}"
   define T3 where T3_def : "T3 = \<Union> {(\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A |p pt q A.
         \<exists>P q' t1 t2.
            (q, P) \<in> prs \<and>
            path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')}"
   
   have "test_suite_to_io M T = T1 \<union> T2 \<union> T3"
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> test_suite_to_io.simps T1_def T2_def T3_def by simp
 
   moreover have "finite T1" 
   proof -
     have "\<And> q P . (q, P)\<in>prs \<Longrightarrow> finite (L P)"
     proof -
       fix q P assume "(q, P)\<in>prs"
       have "acyclic P" 
         using t2[OF \<open>(q, P)\<in>prs\<close>] 
         unfolding is_preamble_def 
         by blast 
       then show "finite (L P)" 
         using acyclic_alt_def 
         by blast
     qed
     then show ?thesis using f1 unfolding T1_def
       by auto 
   qed
 
   moreover have "finite T2"
   proof -
     have *: "T2 = (\<Union> (p,pt) \<in> {(p,pt) | p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q} . ((@) (p_io p) ` set (prefixes (p_io pt))))"
       unfolding T2_def 
       by auto
 
     have "\<And> p pt . finite ((@) (p_io p) ` set (prefixes (p_io pt)))"
       by auto
     moreover have "finite {(p,pt) | p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q}"
     proof -
       have "{(p,pt) | p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q} \<subseteq> (\<Union> (q,P) \<in> prs . {p . path P (initial P) p} \<times> (tps q))"
         by auto
       moreover have "finite (\<Union> (q,P) \<in> prs . {p . path P (initial P) p} \<times> (tps q))"
       proof -
         note \<open>finite prs\<close>
         moreover have "\<And> q P . (q,P) \<in> prs \<Longrightarrow> finite ({p . path P (initial P) p} \<times> (tps q))"
         proof -
           fix q P assume "(q,P) \<in> prs"
 
           have "acyclic P" using t2[OF \<open>(q, P)\<in>prs\<close>]
             unfolding is_preamble_def 
             by blast
           then have "finite {p . path P (initial P) p}" 
             using acyclic_paths_finite[of P "initial P"] 
             unfolding acyclic.simps
             by (metis (no_types, lifting) Collect_cong) 
           then show "finite ({p . path P (initial P) p} \<times> (tps q))"
             using f4'[OF \<open>(q,P) \<in> prs\<close>] 
             by simp
         qed
         ultimately show ?thesis 
           by force
       qed
       ultimately show ?thesis
         by (meson rev_finite_subset) 
     qed
     ultimately show ?thesis 
       unfolding * by auto 
   qed
 
 
   moreover have "finite T3"
   proof -
     have scheme: "\<And> f P . (\<Union> {f a b c d | a b c d . P a b c d}) = (\<Union> (a,b,c,d) \<in> {(a,b,c,d) | a b c d . P a b c d} . f a b c d)" 
       by blast
 
     have *: "T3 = (\<Union> (p,pt,q,A) \<in> {(p, pt, q, A) | p pt q A . \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')}
                        . (\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A)"
       unfolding T3_def scheme by blast
 
     have "{(p, pt, q, A) | p pt q A . \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')}
             \<subseteq> (\<Union> (q,P) \<in> prs . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q, pt) . (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A}))"
       by blast
     moreover have "finite (\<Union> (q,P) \<in> prs . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q, pt) . (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A}))"
     proof -
       note \<open>finite prs\<close>
       moreover have "\<And> q P . (q,P) \<in> prs \<Longrightarrow> finite (\<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q, pt) . (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A}))"
       proof -
         fix q P assume "(q,P) \<in> prs"
         then have "q \<in> fst ` prs" by force
 
         have "finite (tps q)" using f4'[OF \<open>(q,P) \<in> prs\<close>] by assumption
         moreover have "\<And> pt . pt \<in> tps q \<Longrightarrow> finite (\<Union> q' \<in> rd_targets (q, pt) . (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A}))"
         proof -
           fix pt assume "pt \<in> tps q"
           
           have "finite (rd_targets (q,pt))" using f2[OF \<open>q \<in> fst ` prs\<close>] by blast
           moreover have "\<And> q' . q' \<in> rd_targets (q, pt) \<Longrightarrow> finite (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A})"
           proof -
             fix q' assume "q' \<in> rd_targets (q, pt)"
             have "finite (atcs (target q pt, q'))" using f3 by blast
             moreover have "finite {p . path P (initial P) p}"
             proof -
               have "acyclic P" using t2[OF \<open>(q, P)\<in>prs\<close>] unfolding is_preamble_def by blast
               then show ?thesis using acyclic_paths_finite[of P "initial P"] unfolding acyclic.simps by (metis (no_types, lifting) Collect_cong) 
             qed
             ultimately show "finite (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A})"
               by force
           qed
           ultimately show "finite (\<Union> q' \<in> rd_targets (q, pt) . (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A}))"
             by force
         qed
         ultimately show "finite (\<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q, pt) . (\<Union> (A, t1, t2) \<in> atcs (target q pt, q') . {p . path P (initial P) p} \<times> {pt} \<times> {q} \<times> {A}))"
           by force
       qed
       ultimately show ?thesis by force
     qed
     ultimately have "finite {(p, pt, q, A) | p pt q A . \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')}"
       by (meson rev_finite_subset) 
 
 
     moreover have "\<And> p pt q A . (p,pt,q,A) \<in> {(p, pt, q, A) | p pt q A . \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')}
                        \<Longrightarrow> finite ((\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A)"
     proof -
       fix p pt q A assume "(p,pt,q,A) \<in> {(p, pt, q, A) | p pt q A . \<exists>P q' t1 t2. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q, pt) \<and> (A, t1, t2) \<in> atcs (target q pt, q')}"
       then obtain P q' t1 t2 where "(q, P) \<in> prs" and "path P (FSM.initial P) p" and "target (FSM.initial P) p = q" and "pt \<in> tps q" and "q' \<in> rd_targets (q, pt)" and "(A, t1, t2) \<in> atcs (target q pt, q')" by blast
 
       have "is_separator M (target q pt) q' A t1 t2"
         using t3[OF \<open>(A, t1, t2) \<in> atcs (target q pt, q')\<close>] by blast
       then have "acyclic A"
         using is_separator_simps(2) by simp
       then have "finite (L A)"
         unfolding acyclic_alt_def by assumption
       then have "finite (atc_to_io_set (FSM.from_FSM M (target q pt)) A)"
         unfolding atc_to_io_set.simps by blast
       then show "finite ((\<lambda>io_atc. p_io p @ p_io pt @ io_atc) ` atc_to_io_set (FSM.from_FSM M (target q pt)) A)"
         by blast
     qed
 
     ultimately show ?thesis unfolding * by force
   qed
 
   ultimately show ?thesis
     by simp 
 qed
 
 
 
 subsection \<open>Calculating the Sets of Sequences\<close>
 
 
 abbreviation "L_acyclic M \<equiv> LS_acyclic M (initial M)"
 
 (* collect the prefix-closed IO-sequence representation of a test suite for some reference FSM *)
 fun test_suite_to_io' :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c,'d) test_suite \<Rightarrow> ('b \<times> 'c) list set" where
   "test_suite_to_io' M (Test_Suite prs tps rd_targets atcs) 
       = (\<Union> (q,P) \<in> prs . 
           L_acyclic P 
           \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . 
               \<Union> pt \<in> tps q . 
                 ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) 
                 \<union> (\<Union> q' \<in> rd_targets (q,pt) . 
                     \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . 
                       (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
 
 
 lemma test_suite_to_io_code :
   assumes "implies_completeness T M m"
   and     "is_finite_test_suite T"  
   and     "observable M"
 shows "test_suite_to_io M T = test_suite_to_io' M T"
 proof -
 
   obtain prs tps rd_targets atcs where "T = Test_Suite prs tps rd_targets atcs"
     by (meson test_suite.exhaust)
 
   then obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets atcs) M m repetition_sets"
     using assms(1) 
     unfolding implies_completeness_def 
     by blast
 
   have t2: "\<And> q P. (q, P) \<in> prs \<Longrightarrow> is_preamble P M q"
     using implies_completeness_for_repetition_sets_simps(2)[OF repetition_sets_def] 
     by blast
   have t3: "\<And> q1 q2 A d1 d2. (A, d1, d2) \<in> atcs (q1, q2) \<Longrightarrow> (A, d2, d1) \<in> atcs (q2, q1) \<and> is_separator M q1 q2 A d1 d2"
     using implies_completeness_for_repetition_sets_simps(3)[OF repetition_sets_def] 
     by assumption
 
 
   have test_suite_to_io'_alt_def: "test_suite_to_io' M T  
     = (\<Union> (q,P) \<in> prs . L_acyclic P)
       \<union> (\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt))))) 
       \<union> (\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))"
     unfolding test_suite_to_io'.simps \<open>T = Test_Suite prs tps rd_targets atcs\<close> 
     by fast
 
   have test_suite_to_io_alt_def: "test_suite_to_io M T =
     (\<Union> (q,P) \<in> prs . L P)
     \<union> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})
     \<union> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> test_suite_to_io.simps
     by force
 
 
   have preamble_language_prop: "\<And> q P . (q,P) \<in> prs \<Longrightarrow> L_acyclic P = L P"
   proof -
     fix q P assume "(q,P) \<in> prs"
     have "acyclic P" using t2[OF \<open>(q, P)\<in>prs\<close>] unfolding is_preamble_def by blast 
     then show "L_acyclic P = L P" using LS_from_LS_acyclic by blast
   qed
 
   have preamble_path_prop: "\<And> q P ioP . (q,P) \<in> prs \<Longrightarrow> ioP \<in> remove_proper_prefixes (L_acyclic P) \<longleftrightarrow> (\<exists> p . path P (initial P) p \<and> target (initial P) p = q \<and> p_io p = ioP)"
   proof -
     fix q P ioP assume "(q,P) \<in> prs"
     have "is_preamble P M q" using t2[OF \<open>(q, P)\<in>prs\<close>] by assumption
 
     have "ioP \<in> remove_proper_prefixes (L_acyclic P) \<Longrightarrow> (\<exists> p . path P (initial P) p \<and> target (initial P) p = q \<and> p_io p = ioP)"
     proof -
       assume "ioP \<in> remove_proper_prefixes (L_acyclic P)"
       then have "ioP \<in> L P"  and "\<nexists>x'. x' \<noteq> [] \<and> ioP @ x' \<in> L P"
         unfolding preamble_language_prop[OF \<open>(q,P) \<in> prs\<close>] remove_proper_prefixes_def by blast+
       show "(\<exists> p . path P (initial P) p \<and> target (initial P) p = q \<and> p_io p = ioP)"
         using preamble_maximal_io_paths_rev[OF \<open>is_preamble P M q\<close> \<open>observable M\<close> \<open>ioP \<in> L P\<close> \<open>\<nexists>x'. x' \<noteq> [] \<and> ioP @ x' \<in> L P\<close>] by blast
     qed
     moreover have "(\<exists> p . path P (initial P) p \<and> target (initial P) p = q \<and> p_io p = ioP) \<Longrightarrow> ioP \<in> remove_proper_prefixes (L_acyclic P)"
     proof -
       assume "(\<exists> p . path P (initial P) p \<and> target (initial P) p = q \<and> p_io p = ioP)"
       then obtain p where "path P (initial P) p" and "target (initial P) p = q" and "p_io p = ioP"
         by blast
       then have "\<nexists>io'. io' \<noteq> [] \<and> p_io p @ io' \<in> L P"
         using preamble_maximal_io_paths[OF \<open>is_preamble P M q\<close> \<open>observable M\<close>] by blast
       then show "ioP \<in> remove_proper_prefixes (L_acyclic P)"
         using language_state_containment[OF \<open>path P (initial P) p\<close> \<open>p_io p = ioP\<close>] unfolding preamble_language_prop[OF \<open>(q,P) \<in> prs\<close>] remove_proper_prefixes_def \<open>p_io p = ioP\<close> by blast
     qed
     ultimately show "ioP \<in> remove_proper_prefixes (L_acyclic P) \<longleftrightarrow> (\<exists> p . path P (initial P) p \<and> target (initial P) p = q \<and> p_io p = ioP)"
       by blast
   qed
     
 
   have eq1: "(\<Union> (q,P) \<in> prs . L_acyclic P) = (\<Union> (q,P) \<in> prs . L P)"
     using preamble_language_prop by blast
 
   have eq2: "(\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt))))) = (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})"
   proof 
     show "(\<Union>(q, P)\<in>prs. \<Union>ioP\<in>remove_proper_prefixes (L_acyclic P). \<Union>pt\<in>tps q. (@) ioP ` set (prefixes (p_io pt))) \<subseteq> \<Union> {(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q}"
     proof 
       fix io assume "io \<in> (\<Union> (q,P) \<in> prs . (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt))))))"
       then obtain q P where "(q,P) \<in> prs"
                       and   "io \<in> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))))"
         by blast
       then obtain ioP where "ioP \<in> remove_proper_prefixes (L_acyclic P)"
                       and   "io \<in> (\<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))))"
         by blast
 
       obtain p where "path P (initial P) p" and "target (initial P) p = q" and "ioP = p_io p"
         using preamble_path_prop[OF \<open>(q,P) \<in> prs\<close>, of ioP] \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> by auto 
 
       obtain pt where "pt \<in> tps q" and "io \<in> ((\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))))"
         using \<open>io \<in> (\<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))))\<close> unfolding \<open>ioP = p_io p\<close> by blast
       
       show "io \<in> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})"
         using \<open>io \<in> ((\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))))\<close> \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) p\<close> \<open>target (initial P) p = q\<close> \<open>pt \<in> tps q\<close> by blast
     qed
 
     show "\<Union> {(@) (p_io p) ` set (prefixes (p_io pt)) |p pt. \<exists>q P. (q, P) \<in> prs \<and> path P (FSM.initial P) p \<and> target (FSM.initial P) p = q \<and> pt \<in> tps q} \<subseteq> (\<Union>(q, P)\<in>prs. \<Union>ioP\<in>remove_proper_prefixes (L_acyclic P). \<Union>pt\<in>tps q. (@) ioP ` set (prefixes (p_io pt)))"
     proof 
       fix io assume "io \<in> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})"
       then obtain p pt q P where "io \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))"
                            and   "(q,P) \<in> prs" and "path P (initial P) p" and "target (initial P) p = q" and "pt \<in> tps q" 
         by blast
 
       then obtain ioP where "ioP \<in> remove_proper_prefixes (L_acyclic P)"
                       and   "p_io p = ioP"
         using preamble_path_prop[OF \<open>(q,P) \<in> prs\<close>, of "p_io p"] by blast
       
       
       show "io \<in> (\<Union> (q,P) \<in> prs . (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt))))))"
         using \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> \<open>io \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))\<close>  unfolding \<open>p_io p = ioP\<close> by blast
     qed
   qed
 
   have eq3: "(\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)) = (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
   proof
     show "(\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)) \<subseteq> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"    
     proof 
       fix io assume "io \<in> (\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))"
       then obtain q P ioP pt q' A t1 t2 where "(q,P) \<in> prs" 
                                         and   "ioP \<in> remove_proper_prefixes (L_acyclic P)"
                                         and   "pt \<in> tps q"
                                         and   "q' \<in> rd_targets (q,pt)"
                                         and   "(A,t1,t2) \<in> atcs (target q pt,q')"
                                         and   "io \<in> (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)"
         by blast
 
       obtain p where "path P (initial P) p" and "target (initial P) p = q" and "ioP = p_io p"
         using preamble_path_prop[OF \<open>(q,P) \<in> prs\<close>, of ioP] \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> by auto 
 
       have "acyclic A"
         using t3[OF \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close>] is_separator_simps(2) by metis
       have "(acyclic_language_intersection (from_FSM M (target q pt)) A) = (atc_to_io_set (from_FSM M (target q pt)) A)"
         unfolding acyclic_language_intersection_completeness[OF \<open>acyclic A\<close>] atc_to_io_set.simps by simp
       have "io \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)"
         using \<open>io \<in> (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)\<close> unfolding \<open>(acyclic_language_intersection (from_FSM M (target q pt)) A) = (atc_to_io_set (from_FSM M (target q pt)) A)\<close> \<open>ioP = p_io p\<close> by simp
 
       then show "io \<in> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
         using \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) p\<close> \<open>target (initial P) p = q\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q,pt)\<close> \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close> by blast
     qed
 
     show "(\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') }) \<subseteq> (\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))"
     proof 
       fix io assume "io \<in> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
       then obtain p pt q A P q' t1 t2 where "io \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)"
                                       and   "(q,P) \<in> prs" 
                                       and   "path P (initial P) p" 
                                       and   "target (initial P) p = q" 
                                       and   "pt \<in> tps q" 
                                       and   "q' \<in> rd_targets (q,pt)" 
                                       and   "(A,t1,t2) \<in> atcs (target q pt,q')"
         by blast
 
       then obtain ioP where "ioP \<in> remove_proper_prefixes (L_acyclic P)"
                       and   "p_io p = ioP"
         using preamble_path_prop[OF \<open>(q,P) \<in> prs\<close>, of "p_io p"] by blast
 
 
       have "acyclic A"
         using t3[OF \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close>] is_separator_simps(2) by metis
       have *: "(atc_to_io_set (from_FSM M (target q pt)) A) = (acyclic_language_intersection (from_FSM M (target q pt)) A)"
         unfolding acyclic_language_intersection_completeness[OF \<open>acyclic A\<close>] atc_to_io_set.simps by simp
       have "io \<in> (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)"
         using \<open>io \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)\<close> unfolding * \<open>p_io p = ioP\<close> by simp
 
       then show "io \<in> (\<Union> (q,P) \<in> prs . \<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . \<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))"
         using \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q,pt)\<close> \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close> by force
     qed
   qed
 
   show ?thesis
     unfolding test_suite_to_io'_alt_def test_suite_to_io_alt_def eq1 eq2 eq3 by simp
 qed
   
 
 
 
 
 
 
 
 
 subsection \<open>Using Maximal Sequences Only\<close>
 
 
 
 fun test_suite_to_io_maximal :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a,'b,'c,'d::linorder) test_suite \<Rightarrow> ('b \<times> 'c) list set" where
   "test_suite_to_io_maximal M (Test_Suite prs tps rd_targets atcs) = 
       remove_proper_prefixes (\<Union> (q,P) \<in> prs . L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . Set.insert (ioP @ p_io pt) (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A)))))"
 
 
 lemma test_suite_to_io_maximal_code : 
   assumes "implies_completeness T M m"
   and     "is_finite_test_suite T"  
   and     "observable M"
 shows  "{io' \<in> (test_suite_to_io M T) . \<not> (\<exists> io'' . io'' \<noteq> [] \<and> io'@io'' \<in> (test_suite_to_io M T))} = test_suite_to_io_maximal M T"
 proof -
 
   obtain prs tps rd_targets atcs where "T = Test_Suite prs tps rd_targets atcs"
     by (meson test_suite.exhaust)
 
   have t_def: "test_suite_to_io M T = test_suite_to_io' M T"
     using test_suite_to_io_code[OF assms] by assumption
 
   have t1_def : "test_suite_to_io' M T = (\<Union> (q,P) \<in> prs . L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) \<union> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> by simp
 
   define tmax where tmax_def: "tmax = (\<Union> (q,P) \<in> prs . L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . Set.insert (ioP @ p_io pt) (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A)))))"
   have t2_def : "test_suite_to_io_maximal M T = remove_proper_prefixes tmax"
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close> tmax_def by simp
 
   have tmax_sub: "tmax \<subseteq> (test_suite_to_io M T)"
     unfolding tmax_def t_def t1_def
   proof 
     fix io assume "io \<in> (\<Union> (q,P) \<in> prs . L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . Set.insert (ioP @ p_io pt) (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A)))))"
     then obtain q P where "(q,P) \<in> prs"
                     and   "io \<in> L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . Set.insert (ioP @ p_io pt) (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
       by force
     then consider (a) "io \<in> L_acyclic P" |
                   (b) "io \<in> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . Set.insert (ioP @ p_io pt) (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
       by blast
     then show "io \<in> (\<Union> (q,P) \<in> prs . L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) \<union> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
     proof cases
       case a
       then show ?thesis using \<open>(q,P) \<in> prs\<close> by blast
     next
       case b
       then obtain ioP pt where "ioP \<in> remove_proper_prefixes (L_acyclic P)" 
                          and   "pt \<in> tps q"
                          and   "io \<in> Set.insert (ioP @ p_io pt) (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A)))"
         by blast
       then consider (b1) "io = (ioP @ p_io pt)" |
                     (b2) "io \<in> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A)))"
         by blast
       then show ?thesis proof cases
         case b1
         then have "io \<in> ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt))))" unfolding prefixes_set by blast
         then show ?thesis using \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> by blast
       next
         case b2
         then obtain q' A t1 t2 where "q' \<in> rd_targets (q,pt)"
                                and   "(A,t1,t2) \<in> atcs (target q pt,q')"
                                and   "io \<in> (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A))"
           by blast
         then have "io \<in> (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)"
           unfolding remove_proper_prefixes_def by blast
         then show ?thesis using \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q,pt)\<close> \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close> by force
       qed 
     qed
   qed
 
 
   have tmax_max: "\<And> io . io \<in> test_suite_to_io M T \<Longrightarrow> io \<notin> tmax \<Longrightarrow> \<exists> io'' . io'' \<noteq> [] \<and> io@io'' \<in> (test_suite_to_io M T)"
   proof -
     fix io assume "io \<in> test_suite_to_io M T" and "io \<notin> tmax"
 
     then have "io \<in> (\<Union> (q,P) \<in> prs . L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) \<union> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
       unfolding t_def t1_def by blast
     then obtain q P where "(q,P) \<in> prs"
                     and   "io \<in> (L_acyclic P \<union> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) \<union> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))))"
       by force
     then consider (a) "io \<in> L_acyclic P" |
                   (b) "io \<in> (\<Union> ioP \<in> remove_proper_prefixes (L_acyclic P) . \<Union> pt \<in> tps q . ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) \<union> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)))"
       by blast
     then show "\<exists> io'' . io'' \<noteq> [] \<and> io@io'' \<in> (test_suite_to_io M T)" proof cases
       case a
       then have "io \<in> tmax"
         using \<open>(q,P) \<in> prs\<close> unfolding tmax_def by blast
       then show ?thesis 
         using \<open>io \<notin> tmax\<close> by simp
     next
       case b
       then obtain ioP pt where "ioP \<in> remove_proper_prefixes (L_acyclic P)"
                          and   "pt \<in> tps q"
                          and   "io \<in> ((\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))) \<union> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))"
         by blast
       then consider (b1) "io \<in> (\<lambda> io' . ioP @ io') ` (set (prefixes (p_io pt)))" |
                     (b2) "io \<in> (\<Union> q' \<in> rd_targets (q,pt) . \<Union> (A,t1,t2) \<in> atcs (target q pt,q') . (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A))"
         by blast
       then show ?thesis proof cases
         case b1
         then obtain pt1 pt2 where "io = ioP @ pt1" and "p_io pt = pt1@pt2"
           by (metis (no_types, lifting) b1 image_iff prefixes_set_ob) 
 
         have "ioP @ (p_io pt) \<in> tmax"
           using \<open>io \<notin> tmax\<close> \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> unfolding tmax_def by force
         then have "io \<noteq> ioP @ (p_io pt)"
           using \<open>io \<notin> tmax\<close> by blast
         then have "pt2 \<noteq> []" 
           using \<open>io = ioP @ pt1\<close> unfolding \<open>p_io pt = pt1@pt2\<close> by auto
 
         have "ioP @ (p_io pt) \<in> test_suite_to_io M T"
           using \<open>ioP @ (p_io pt) \<in> tmax\<close> tmax_sub by blast
         then show ?thesis 
           unfolding \<open>io = ioP @ pt1\<close> append.assoc \<open>p_io pt = pt1@pt2\<close>
           using \<open>pt2 \<noteq> []\<close> by blast
       next
         case b2
         then obtain q' A t1 t2 where "q' \<in> rd_targets (q,pt)"
                                and   "(A,t1,t2) \<in> atcs (target q pt,q')"
                                and   "io \<in> (\<lambda> io_atc . ioP @ p_io pt @ io_atc) ` (acyclic_language_intersection (from_FSM M (target q pt)) A)"
           by blast
 
         then obtain ioA where "io = ioP @ p_io pt @ ioA" 
                         and   "ioA \<in> acyclic_language_intersection (from_FSM M (target q pt)) A"
           by blast
 
         moreover have "ioA \<notin> (remove_proper_prefixes (acyclic_language_intersection (from_FSM M (target q pt)) A))"
         proof 
           assume "ioA \<in> remove_proper_prefixes (acyclic_language_intersection (FSM.from_FSM M (target q pt)) A)"
           then have "io \<in> tmax"
             using \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q,pt)\<close> \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close> unfolding tmax_def \<open>io = ioP @ p_io pt @ ioA\<close> by force
           then show False
             using \<open>io \<notin> tmax\<close> by simp
         qed
         ultimately obtain ioA2 where "ioA @ ioA2 \<in> acyclic_language_intersection (from_FSM M (target q pt)) A" 
                                and   "ioA2 \<noteq> []"
           unfolding remove_proper_prefixes_def by blast
         then have "io@ioA2 \<in> test_suite_to_io M T"
           using \<open>(q,P) \<in> prs\<close> \<open>ioP \<in> remove_proper_prefixes (L_acyclic P)\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q,pt)\<close> \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close> \<open>ioA @ ioA2 \<in> acyclic_language_intersection (from_FSM M (target q pt)) A\<close> unfolding t_def t1_def \<open>io = ioP @ p_io pt @ ioA\<close> by force
         
         then show ?thesis 
           using \<open>ioA2 \<noteq> []\<close> by blast
       qed
     qed 
   qed
 
 
   show ?thesis unfolding t2_def
   proof 
     show "{io' \<in> test_suite_to_io M T. \<nexists>io''. io'' \<noteq> [] \<and> io' @ io'' \<in> test_suite_to_io M T} \<subseteq> remove_proper_prefixes tmax"
     proof 
       fix io assume "io \<in> {io' \<in> test_suite_to_io M T. \<nexists>io''. io'' \<noteq> [] \<and> io' @ io'' \<in> test_suite_to_io M T}"
       then have "io \<in> test_suite_to_io M T" and "\<nexists>io''. io'' \<noteq> [] \<and> io @ io'' \<in> test_suite_to_io M T" 
         by blast+
       show "io \<in> remove_proper_prefixes tmax"
         using \<open>\<nexists>io''. io'' \<noteq> [] \<and> io @ io'' \<in> test_suite_to_io M T\<close>
         using tmax_sub tmax_max[OF \<open>io \<in> test_suite_to_io M T\<close>] unfolding remove_proper_prefixes_def
         by auto 
     qed
     show "remove_proper_prefixes tmax \<subseteq> {io' \<in> test_suite_to_io M T. \<nexists>io''. io'' \<noteq> [] \<and> io' @ io'' \<in> test_suite_to_io M T}"
     proof 
       fix io assume "io \<in> remove_proper_prefixes tmax"
       then have "io \<in> tmax" and "\<nexists>io''. io'' \<noteq> [] \<and> io @ io'' \<in> remove_proper_prefixes tmax"
         unfolding remove_proper_prefixes_def by blast+
       then have "io \<in> test_suite_to_io M T"
         using tmax_sub by blast
       moreover have "\<nexists>io''. io'' \<noteq> [] \<and> io @ io'' \<in> test_suite_to_io M T"
       proof 
         assume "\<exists>io''. io'' \<noteq> [] \<and> io @ io'' \<in> test_suite_to_io M T"
         then obtain io'' where "io'' \<noteq> []" and "io @ io'' \<in> test_suite_to_io M T"
           by blast
         then obtain io''' where "(io @ io'') @ io''' \<in> test_suite_to_io M T" 
                           and   "(\<nexists>zs. zs \<noteq> [] \<and> (io @ io'') @ io''' @ zs \<in> test_suite_to_io M T)"
           using finite_set_elem_maximal_extension_ex[OF \<open>io @ io'' \<in> test_suite_to_io M T\<close> test_suite_to_io_finite[OF assms(1,2)]] by blast
 
         have "io @ (io'' @ io''') \<in> tmax"
           using tmax_max[OF \<open>(io @ io'') @ io''' \<in> test_suite_to_io M T\<close>] \<open>(\<nexists>zs. zs \<noteq> [] \<and> (io @ io'') @ io''' @ zs \<in> test_suite_to_io M T)\<close> by force
         moreover have "io''@io''' \<noteq> []"
           using \<open>io'' \<noteq> []\<close> by auto
 
         ultimately show "False" 
           using \<open>\<nexists>io''. io'' \<noteq> [] \<and> io @ io'' \<in> remove_proper_prefixes tmax\<close> 
           by (metis (mono_tags, lifting) \<open>io \<in> remove_proper_prefixes tmax\<close> mem_Collect_eq remove_proper_prefixes_def) 
       qed
           
 
       ultimately show "io \<in> {io' \<in> test_suite_to_io M T. \<nexists>io''. io'' \<noteq> [] \<and> io' @ io'' \<in> test_suite_to_io M T}"
         by blast
     qed
   qed
 qed
 
 
 lemma test_suite_to_io_pass_maximal :
   assumes "implies_completeness T M m"
   and     "is_finite_test_suite T"  
 shows "pass_io_set M' (test_suite_to_io M T) = pass_io_set_maximal M' {io' \<in> (test_suite_to_io M T) . \<not> (\<exists> io'' . io'' \<noteq> [] \<and> io'@io'' \<in> (test_suite_to_io M T))}"
 proof -
 
   (* finiteness *)
   have p1: "finite (test_suite_to_io M T)"
     using test_suite_to_io_finite[OF assms] by assumption
 
   (* prefix closure *)
   obtain prs tps rd_targets atcs where "T = Test_Suite prs tps rd_targets atcs"
     by (meson test_suite.exhaust)
   then obtain repetition_sets where repetition_sets_def: "implies_completeness_for_repetition_sets (Test_Suite prs tps rd_targets atcs) M m repetition_sets"
     using assms(1) unfolding implies_completeness_def by blast
   then have "implies_completeness (Test_Suite prs tps rd_targets atcs) M m"
     unfolding implies_completeness_def by blast
   then have test_suite_language_prop: "test_suite_to_io M (Test_Suite prs tps rd_targets atcs) \<subseteq> L M"
     using test_suite_to_io_language by blast
 
   have p2: "\<And>io' io''. io' @ io'' \<in> test_suite_to_io M T \<Longrightarrow> io' \<in> test_suite_to_io M T"
     unfolding \<open>T = Test_Suite prs tps rd_targets atcs\<close>
   proof -
     fix io' io'' assume "io' @ io'' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
 
     have preamble_prop : "\<And> io''' q P . (q,P) \<in> prs \<Longrightarrow> io'@io''' \<in> L P \<Longrightarrow> io' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
     proof -
       fix io''' q P assume "(q,P) \<in> prs" and "io'@io''' \<in> L P" 
       have "io' \<in> (\<Union> (q,P) \<in> prs . L P)" 
         using \<open>(q,P) \<in> prs\<close> language_prefix[OF \<open>io'@io''' \<in> L P\<close>] by auto
       then show "io' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)" 
         unfolding test_suite_to_io.simps by blast
     qed
 
     have traversal_path_prop : "\<And> io''' p pt q P . io'@io''' \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) \<Longrightarrow> (q,P) \<in> prs \<Longrightarrow> path P (initial P) p \<Longrightarrow> target (initial P) p = q \<Longrightarrow> pt \<in> tps q \<Longrightarrow> io' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
     proof - 
       fix io''' p pt q P assume "io'@io''' \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))"  
                             and "(q,P) \<in> prs" 
                             and "path P (initial P) p" 
                             and "target (initial P) p = q" 
                             and "pt \<in> tps q"
 
       obtain ioP1 where "io'@io''' = p_io p @ ioP1" and "ioP1 \<in> (set (prefixes (p_io pt)))"
         using \<open>io'@io''' \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))\<close> by auto
       then obtain ioP2 where "ioP1 @ ioP2 = p_io pt"
          unfolding prefixes_set by blast
 
 
       show "io' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)"
       proof (cases "length io' \<le> length (p_io p)")
         case True
         then have "io' = (take (length io') (p_io p))"
           using \<open>io'@io''' = p_io p @ ioP1\<close>
           by (metis (no_types, lifting) order_refl take_all take_le) 
         then have "p_io p = io'@(drop (length io') (p_io p))"
           by (metis (no_types, lifting) append_take_drop_id)
         then have "io'@(drop (length io') (p_io p)) \<in> L P"
           using language_state_containment[OF \<open>path P (initial P) p\<close>] by blast
         then show ?thesis 
           using preamble_prop[OF \<open>(q,P) \<in> prs\<close>] by blast
       next
         case False
         then have "io' = p_io p @ (take (length io' - length (p_io p)) ioP1)"
           using \<open>io'@io''' = p_io p @ ioP1\<close>
           by (metis (no_types, lifting) le_cases take_all take_append take_le) 
         moreover have "(take (length io' - length (p_io p)) ioP1) \<in> (set (prefixes (p_io pt)))"
         proof -
           have "ioP1 = (take (length io' - length (p_io p)) ioP1) @ (drop (length io' - length (p_io p)) ioP1)"
             by auto
           then have "(take (length io' - length (p_io p)) ioP1) @ ((drop (length io' - length (p_io p)) ioP1) @ ioP2) = p_io pt"
             using \<open>ioP1 @ ioP2 = p_io pt\<close> by (metis (mono_tags, lifting) append_assoc) 
           then show ?thesis
             unfolding prefixes_set by blast
         qed
         ultimately have "io' \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))"
           by blast
         then have "io' \<in> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})"
           using \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) p\<close> \<open>target (initial P) p = q\<close> \<open>pt \<in> tps q\<close> by blast
         then show ?thesis 
           unfolding test_suite_to_io.simps by blast          
       qed
     qed
 
 
     from \<open>io' @ io'' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)\<close> consider
       (a) "io' @ io'' \<in> (\<Union> (q,P) \<in> prs . L P)" |
       (b) "io' @ io'' \<in> (\<Union>{(\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt))) | p pt . \<exists> q P . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q})" |
       (c) "io' @ io'' \<in> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
       unfolding test_suite_to_io.simps
       by blast
 
     then show "io' \<in> test_suite_to_io M (Test_Suite prs tps rd_targets atcs)" 
     proof cases
       case a
       then show ?thesis using preamble_prop by blast
     next
       case b
       then show ?thesis using traversal_path_prop by blast
     next
       case c
       then obtain p pt q A  P q' t1 t2  where "io' @ io'' \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)"
                                           and "(q,P) \<in> prs" 
                                           and "path P (initial P) p"
                                           and "target (initial P) p = q"
                                           and "pt \<in> tps q"
                                           and "q' \<in> rd_targets (q,pt)"
                                           and "(A,t1,t2) \<in> atcs (target q pt,q')"
         by blast
 
       obtain ioA where "io' @ io'' = p_io p @ p_io pt @ ioA" 
                    and "ioA \<in> (atc_to_io_set (from_FSM M (target q pt)) A)"
         using \<open>io' @ io'' \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)\<close> 
         by blast
 
 
       show ?thesis proof (cases "length io' \<le> length (p_io p @ p_io pt)")
         case True
         then have "io' @ (drop (length io') (p_io p @ p_io pt)) = p_io p @ p_io pt"
           using \<open>io' @ io'' = p_io p @ p_io pt @ ioA\<close>
           by (simp add: append_eq_conv_conj) 
         moreover have "p_io p @ p_io pt \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))"
           unfolding prefixes_set by blast
         ultimately have "io'@(drop (length io') (p_io p @ p_io pt)) \<in> (\<lambda> io' . p_io p @ io') ` (set (prefixes (p_io pt)))"
           by simp
         then show ?thesis 
           using traversal_path_prop[OF _ \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) p\<close> \<open>target (initial P) p = q\<close> \<open>pt \<in> tps q\<close>] by blast
       next
         case False
         then have "io' = (p_io p @ p_io pt) @ (take (length io' - length (p_io p @ p_io pt)) ioA)"
         proof -
           have "io' = take (length io') (io' @ io'')"
             by auto
           then show ?thesis
             using False \<open>io' @ io'' = p_io p @ p_io pt @ ioA\<close> by fastforce
         qed
         moreover have "(take (length io' - length (p_io p @ p_io pt)) ioA) \<in> (atc_to_io_set (from_FSM M (target q pt)) A)"
         proof -
           have "(take (length io' - length (p_io p @ p_io pt)) ioA)@(drop (length io' - length (p_io p @ p_io pt)) ioA) \<in> L (from_FSM M (target q pt)) \<inter> L A"
             using \<open>ioA \<in> (atc_to_io_set (from_FSM M (target q pt)) A)\<close> by auto
           then have *: "(take (length io' - length (p_io p @ p_io pt)) ioA)@(drop (length io' - length (p_io p @ p_io pt)) ioA) \<in> L (from_FSM M (target q pt))"
                and **: "(take (length io' - length (p_io p @ p_io pt)) ioA)@(drop (length io' - length (p_io p @ p_io pt)) ioA) \<in> L A"
             by blast+
           show ?thesis
             using language_prefix[OF *] language_prefix[OF **]
             unfolding atc_to_io_set.simps by blast
         qed
         ultimately have "io' \<in> (\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A)"
           by force
             
         then have "io' \<in> (\<Union>{(\<lambda> io_atc . p_io p @ p_io pt @ io_atc) ` (atc_to_io_set (from_FSM M (target q pt)) A) | p pt q A . \<exists> P q' t1 t2 . (q,P) \<in> prs \<and> path P (initial P) p \<and> target (initial P) p = q \<and> pt \<in> tps q \<and> q' \<in> rd_targets (q,pt) \<and> (A,t1,t2) \<in> atcs (target q pt,q') })"
           using \<open>(q,P) \<in> prs\<close> \<open>path P (initial P) p\<close> \<open>target (initial P) p = q\<close> \<open>pt \<in> tps q\<close> \<open>q' \<in> rd_targets (q,pt)\<close> \<open>(A,t1,t2) \<in> atcs (target q pt,q')\<close> by blast
         then show ?thesis 
           unfolding test_suite_to_io.simps by blast
       qed
     qed
   qed
 
 
   then show ?thesis
     using pass_io_set_maximal_from_pass_io_set[OF p1] by blast
 qed
 
 
 
 lemma passes_test_suite_as_maximal_sequences_completeness :
   assumes "implies_completeness T M m"
   and     "is_finite_test_suite T"
   and     "observable M" 
   and     "observable M'"
   and     "inputs M' = inputs M"
   and     "inputs M \<noteq> {}"
   and     "completely_specified M"
   and     "completely_specified M'"
   and     "size M' \<le> m"
 shows     "(L M' \<subseteq> L M) \<longleftrightarrow> pass_io_set_maximal M' (test_suite_to_io_maximal M T)"
   unfolding passes_test_suite_completeness[OF assms(1,3-9)]
   unfolding test_suite_to_io_pass[OF assms(1,3-8),symmetric]
   unfolding test_suite_to_io_pass_maximal[OF assms(1,2)]
   unfolding test_suite_to_io_maximal_code[OF assms(1,2,3)]
   by simp
 
 
 lemma test_suite_to_io_maximal_finite :
   assumes "implies_completeness T M m"
   and     "is_finite_test_suite T"
   and     "observable M"
 shows "finite (test_suite_to_io_maximal M T)"
  using test_suite_to_io_finite[OF assms(1,2)]
  unfolding test_suite_to_io_maximal_code[OF assms, symmetric]
  by simp
 
 
 end
\ No newline at end of file
diff --git a/thys/Lambda_Free_RPOs/Extension_Orders.thy b/thys/Lambda_Free_RPOs/Extension_Orders.thy
--- a/thys/Lambda_Free_RPOs/Extension_Orders.thy
+++ b/thys/Lambda_Free_RPOs/Extension_Orders.thy
@@ -1,2055 +1,2054 @@
 (*  Title:       Extension Orders
     Author:      Heiko Becker <heikobecker92@gmail.com>, 2016
     Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
     Author:      Dmitriy Traytel <traytel@inf.ethz.ch>, 2014
     Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
 *)
 
 section \<open>Extension Orders\<close>
 
 theory Extension_Orders
 imports Lambda_Free_Util Infinite_Chain "HOL-Cardinals.Wellorder_Extension"
 begin
 
 text \<open>
 This theory defines locales for categorizing extension orders used for orders on
 \<open>\<lambda>\<close>-free higher-order terms and defines variants of the lexicographic and
 multiset orders.
 \<close>
 
 
 subsection \<open>Locales\<close>
 
 locale ext =
   fixes ext :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes
     mono_strong: "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x) \<Longrightarrow> ext gt ys xs \<Longrightarrow> ext gt' ys xs" and
     map: "finite A \<Longrightarrow> ys \<in> lists A \<Longrightarrow> xs \<in> lists A \<Longrightarrow> (\<forall>x \<in> A. \<not> gt (f x) (f x)) \<Longrightarrow>
       (\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt (f z) (f y) \<longrightarrow> gt (f y) (f x) \<longrightarrow> gt (f z) (f x)) \<Longrightarrow>
       (\<forall>y \<in> A. \<forall>x \<in> A. gt y x \<longrightarrow> gt (f y) (f x)) \<Longrightarrow> ext gt ys xs \<Longrightarrow> ext gt (map f ys) (map f xs)"
 begin
 
 lemma mono[mono]: "gt \<le> gt' \<Longrightarrow> ext gt \<le> ext gt'"
   using mono_strong by blast
 
 end
 
 locale ext_irrefl = ext +
   assumes irrefl: "(\<forall>x \<in> set xs. \<not> gt x x) \<Longrightarrow> \<not> ext gt xs xs"
 
 locale ext_trans = ext +
   assumes trans: "zs \<in> lists A \<Longrightarrow> ys \<in> lists A \<Longrightarrow> xs \<in> lists A \<Longrightarrow>
     (\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow> ext gt zs ys \<Longrightarrow> ext gt ys xs \<Longrightarrow>
     ext gt zs xs"
 
 locale ext_irrefl_before_trans = ext_irrefl +
   assumes trans_from_irrefl: "finite A \<Longrightarrow> zs \<in> lists A \<Longrightarrow> ys \<in> lists A \<Longrightarrow> xs \<in> lists A \<Longrightarrow>
     (\<forall>x \<in> A. \<not> gt x x) \<Longrightarrow> (\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow> ext gt zs ys \<Longrightarrow>
     ext gt ys xs \<Longrightarrow> ext gt zs xs"
 
 locale ext_trans_before_irrefl = ext_trans +
   assumes irrefl_from_trans: "(\<forall>z \<in> set xs. \<forall>y \<in> set xs. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow>
     (\<forall>x \<in> set xs. \<not> gt x x) \<Longrightarrow> \<not> ext gt xs xs"
 
 locale ext_irrefl_trans_strong = ext_irrefl +
   assumes trans_strong: "(\<forall>z \<in> set zs. \<forall>y \<in> set ys. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow>
     ext gt zs ys \<Longrightarrow> ext gt ys xs \<Longrightarrow> ext gt zs xs"
 
 sublocale ext_irrefl_trans_strong < ext_irrefl_before_trans
   by standard (erule irrefl, metis in_listsD trans_strong)
 
 sublocale ext_irrefl_trans_strong < ext_trans
   by standard (metis in_listsD trans_strong)
 
 sublocale ext_irrefl_trans_strong < ext_trans_before_irrefl
   by standard (rule irrefl)
 
 locale ext_snoc = ext +
   assumes snoc: "ext gt (xs @ [x]) xs"
 
 locale ext_compat_cons = ext +
   assumes compat_cons: "ext gt ys xs \<Longrightarrow> ext gt (x # ys) (x # xs)"
 begin
 
 lemma compat_append_left: "ext gt ys xs \<Longrightarrow> ext gt (zs @ ys) (zs @ xs)"
   by (induct zs) (auto intro: compat_cons)
 
 end
 
 locale ext_compat_snoc = ext +
   assumes compat_snoc: "ext gt ys xs \<Longrightarrow> ext gt (ys @ [x]) (xs @ [x])"
 begin
 
 lemma compat_append_right: "ext gt ys xs \<Longrightarrow> ext gt (ys @ zs) (xs @ zs)"
   by (induct zs arbitrary: xs ys rule: rev_induct)
     (auto intro: compat_snoc simp del: append_assoc simp: append_assoc[symmetric])
 
 end
 
 locale ext_compat_list = ext +
   assumes compat_list: "y \<noteq> x \<Longrightarrow> gt y x \<Longrightarrow> ext gt (xs @ y # xs') (xs @ x # xs')"
 
 locale ext_singleton = ext +
   assumes singleton: "y \<noteq> x \<Longrightarrow> ext gt [y] [x] \<longleftrightarrow> gt y x"
 
 locale ext_compat_list_strong = ext_compat_cons + ext_compat_snoc + ext_singleton
 begin
 
 lemma compat_list: "y \<noteq> x \<Longrightarrow> gt y x \<Longrightarrow> ext gt (xs @ y # xs') (xs @ x # xs')"
   using compat_append_left[of gt "y # xs'" "x # xs'" xs]
     compat_append_right[of gt, of "[y]" "[x]" xs'] singleton[of y x gt]
   by fastforce
 
 end
 
 sublocale ext_compat_list_strong < ext_compat_list
   by standard (fact compat_list)
 
 locale ext_total = ext +
   assumes total: "(\<forall>y \<in> A. \<forall>x \<in> A. gt y x \<or> gt x y \<or> y = x) \<Longrightarrow> ys \<in> lists A \<Longrightarrow> xs \<in> lists A \<Longrightarrow>
     ext gt ys xs \<or> ext gt xs ys \<or> ys = xs"
 
 locale ext_wf = ext +
   assumes wf: "wfP (\<lambda>x y. gt y x) \<Longrightarrow> wfP (\<lambda>xs ys. ext gt ys xs)"
 
 locale ext_hd_or_tl = ext +
   assumes hd_or_tl: "(\<forall>z y x. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow> (\<forall>y x. gt y x \<or> gt x y \<or> y = x) \<Longrightarrow>
     length ys = length xs \<Longrightarrow> ext gt (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> ext gt ys xs"
 
 locale ext_wf_bounded = ext_irrefl_before_trans + ext_hd_or_tl
 begin
 
 context
   fixes gt :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   assumes
     gt_irrefl: "\<And>z. \<not> gt z z" and
     gt_trans: "\<And>z y x. gt z y \<Longrightarrow> gt y x \<Longrightarrow> gt z x" and
     gt_total: "\<And>y x. gt y x \<or> gt x y \<or> y = x" and
     gt_wf: "wfP (\<lambda>x y. gt y x)"
 begin
 
 lemma irrefl_gt: "\<not> ext gt xs xs"
   using irrefl gt_irrefl by simp
 
 lemma trans_gt: "ext gt zs ys \<Longrightarrow> ext gt ys xs \<Longrightarrow> ext gt zs xs"
   by (rule trans_from_irrefl[of "set zs \<union> set ys \<union> set xs" zs ys xs gt])
     (auto intro: gt_trans simp: gt_irrefl)
 
 lemma hd_or_tl_gt: "length ys = length xs \<Longrightarrow> ext gt (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> ext gt ys xs"
   by (rule hd_or_tl) (auto intro: gt_trans simp: gt_total)
 
 lemma wf_same_length_if_total: "wfP (\<lambda>xs ys. length ys = n \<and> length xs = n \<and> ext gt ys xs)"
 proof (induct n)
   case 0
   thus ?case
     unfolding wfP_def wf_def using irrefl by auto
 next
   case (Suc n)
   note ih = this(1)
 
   define gt_hd where "\<And>ys xs. gt_hd ys xs \<longleftrightarrow> gt (hd ys) (hd xs)"
   define gt_tl where "\<And>ys xs. gt_tl ys xs \<longleftrightarrow> ext gt (tl ys) (tl xs)"
 
   have hd_tl: "gt_hd ys xs \<or> gt_tl ys xs"
     if len_ys: "length ys = Suc n" and len_xs: "length xs = Suc n" and ys_gt_xs: "ext gt ys xs"
     for n ys xs
     using len_ys len_xs ys_gt_xs unfolding gt_hd_def gt_tl_def
     by (cases xs; cases ys) (auto simp: hd_or_tl_gt)
 
   show ?case
     unfolding wfP_iff_no_inf_chain
   proof (intro notI)
     let ?gtsn = "\<lambda>ys xs. length ys = n \<and> length xs = n \<and> ext gt ys xs"
     let ?gtsSn = "\<lambda>ys xs. length ys = Suc n \<and> length xs = Suc n \<and> ext gt ys xs"
     let ?gttlSn = "\<lambda>ys xs. length ys = Suc n \<and> length xs = Suc n \<and> gt_tl ys xs"
 
     assume "\<exists>f. inf_chain ?gtsSn f"
     then obtain xs where xs_bad: "bad ?gtsSn xs"
       unfolding inf_chain_def bad_def by blast
 
     let ?ff = "worst_chain ?gtsSn gt_hd"
 
     have wf_hd: "wf {(xs, ys). gt_hd ys xs}"
       unfolding gt_hd_def by (rule wfP_app[OF gt_wf, of hd, unfolded wfP_def])
 
     have "inf_chain ?gtsSn ?ff"
       by (rule worst_chain_bad[OF wf_hd xs_bad])
     moreover have "\<not> gt_hd (?ff i) (?ff (Suc i))" for i
       by (rule worst_chain_not_gt[OF wf_hd xs_bad]) (blast intro: trans_gt)
     ultimately have tl_bad: "inf_chain ?gttlSn ?ff"
       unfolding inf_chain_def using hd_tl by blast
 
     have "\<not> inf_chain ?gtsn (tl \<circ> ?ff)"
       using wfP_iff_no_inf_chain[THEN iffD1, OF ih] by blast
     hence tl_good: "\<not> inf_chain ?gttlSn ?ff"
       unfolding inf_chain_def gt_tl_def by force
 
     show False
       using tl_bad tl_good by sat
   qed
 qed
 
 lemma wf_bounded_if_total: "wfP (\<lambda>xs ys. length ys \<le> n \<and> length xs \<le> n \<and> ext gt ys xs)"
   unfolding wfP_iff_no_inf_chain
 proof (intro notI, induct n rule: less_induct)
   case (less n)
   note ih = this(1) and ex_bad = this(2)
 
   let ?gtsle = "\<lambda>ys xs. length ys \<le> n \<and> length xs \<le> n \<and> ext gt ys xs"
 
   obtain xs where xs_bad: "bad ?gtsle xs"
     using ex_bad unfolding inf_chain_def bad_def by blast
 
   let ?ff = "worst_chain ?gtsle (\<lambda>ys xs. length ys > length xs)"
 
   note wf_len = wf_app[OF wellorder_class.wf, of length, simplified]
 
   have ff_bad: "inf_chain ?gtsle ?ff"
     by (rule worst_chain_bad[OF wf_len xs_bad])
   have ffi_bad: "\<And>i. bad ?gtsle (?ff i)"
     by (rule inf_chain_bad[OF ff_bad])
 
   have len_le_n: "\<And>i. length (?ff i) \<le> n"
     using worst_chain_pred[OF wf_len xs_bad] by simp
   have len_le_Suc: "\<And>i. length (?ff i) \<le> length (?ff (Suc i))"
     using worst_chain_not_gt[OF wf_len xs_bad] not_le_imp_less by (blast intro: trans_gt)
 
   show False
   proof (cases "\<exists>k. length (?ff k) = n")
     case False
     hence len_lt_n: "\<And>i. length (?ff i) < n"
       using len_le_n by (blast intro: le_neq_implies_less)
     hence nm1_le: "n - 1 < n"
       by fastforce
 
     let ?gtslt = "\<lambda>ys xs. length ys \<le> n - 1 \<and> length xs \<le> n - 1 \<and> ext gt ys xs"
 
     have "inf_chain ?gtslt ?ff"
       using ff_bad len_lt_n unfolding inf_chain_def
       by (metis (no_types, lifting) Suc_diff_1 le_antisym nat_neq_iff not_less0 not_less_eq_eq)
     thus False
       using ih[OF nm1_le] by blast
   next
     case True
     then obtain k where len_eq_n: "length (?ff k) = n"
       by blast
 
     let ?gtssl = "\<lambda>ys xs. length ys = n \<and> length xs = n \<and> ext gt ys xs"
 
     have len_eq_n: "length (?ff (i + k)) = n" for i
       by (induct i) (simp add: len_eq_n,
         metis (lifting) len_le_n len_le_Suc add_Suc dual_order.antisym)
 
     have "inf_chain ?gtsle (\<lambda>i. ?ff (i + k))"
       by (rule inf_chain_offset[OF ff_bad])
     hence "inf_chain ?gtssl (\<lambda>i. ?ff (i + k))"
       unfolding inf_chain_def using len_eq_n by presburger
     hence "\<not> wfP (\<lambda>xs ys. ?gtssl ys xs)"
       using wfP_iff_no_inf_chain by blast
     thus False
       using wf_same_length_if_total[of n] by sat
   qed
 qed
 
 end
 
 context
   fixes gt :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   assumes
     gt_irrefl: "\<And>z. \<not> gt z z" and
     gt_wf: "wfP (\<lambda>x y. gt y x)"
 begin
 
 lemma wf_bounded: "wfP (\<lambda>xs ys. length ys \<le> n \<and> length xs \<le> n \<and> ext gt ys xs)"
 proof -
   obtain Ge' where
     gt_sub_Ge': "{(x, y). gt y x} \<subseteq> Ge'" and
     Ge'_wo: "Well_order Ge'" and
     Ge'_fld: "Field Ge' = UNIV"
     using total_well_order_extension[OF gt_wf[unfolded wfP_def]] by blast
 
   define gt' where "\<And>y x. gt' y x \<longleftrightarrow> y \<noteq> x \<and> (x, y) \<in> Ge'"
 
   have gt_imp_gt': "gt \<le> gt'"
     by (auto simp: gt'_def gt_irrefl intro: gt_sub_Ge'[THEN subsetD])
 
   have gt'_irrefl: "\<And>z. \<not> gt' z z"
     unfolding gt'_def by simp
 
   have gt'_trans: "\<And>z y x. gt' z y \<Longrightarrow> gt' y x \<Longrightarrow> gt' z x"
     using Ge'_wo
     unfolding gt'_def well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def
       trans_def antisym_def
     by blast
 
   have "wf {(x, y). (x, y) \<in> Ge' \<and> x \<noteq> y}"
     by (rule Ge'_wo[unfolded well_order_on_def set_diff_eq
       case_prod_eta[symmetric, of "\<lambda>xy. xy \<in> Ge' \<and> xy \<notin> Id"] pair_in_Id_conv, THEN conjunct2])
   moreover have "\<And>y x. (x, y) \<in> Ge' \<and> x \<noteq> y \<longleftrightarrow> y \<noteq> x \<and> (x, y) \<in> Ge'"
     by auto
   ultimately have gt'_wf: "wfP (\<lambda>x y. gt' y x)"
     unfolding wfP_def gt'_def by simp
 
   have gt'_total: "\<And>x y. gt' y x \<or> gt' x y \<or> y = x"
     using Ge'_wo unfolding gt'_def well_order_on_def linear_order_on_def total_on_def Ge'_fld
     by blast
 
   have "wfP (\<lambda>xs ys. length ys \<le> n \<and> length xs \<le> n \<and> ext gt' ys xs)"
     using wf_bounded_if_total gt'_total gt'_irrefl gt'_trans gt'_wf by blast
   thus ?thesis
     by (rule wfP_subset) (auto intro: mono[OF gt_imp_gt', THEN predicate2D])
 qed
 
 end
 
 end
 
 
 subsection \<open>Lexicographic Extension\<close>
 
 inductive lexext :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" for gt where
   lexext_Nil: "lexext gt (y # ys) []"
 | lexext_Cons: "gt y x \<Longrightarrow> lexext gt (y # ys) (x # xs)"
 | lexext_Cons_eq: "lexext gt ys xs \<Longrightarrow> lexext gt (x # ys) (x # xs)"
 
 lemma lexext_simps[simp]:
   "lexext gt ys [] \<longleftrightarrow> ys \<noteq> []"
   "\<not> lexext gt [] xs"
   "lexext gt (y # ys) (x # xs) \<longleftrightarrow> gt y x \<or> x = y \<and> lexext gt ys xs"
 proof
   show "lexext gt ys [] \<Longrightarrow> (ys \<noteq> [])"
     by (metis lexext.cases list.distinct(1))
 next
   show "ys \<noteq> [] \<Longrightarrow> lexext gt ys []"
     by (metis lexext_Nil list.exhaust)
 next
   show "\<not> lexext gt [] xs"
     using lexext.cases by auto
 next
   show "lexext gt (y # ys) (x # xs) = (gt y x \<or> x = y \<and> lexext gt ys xs)"
   proof -
     have fwdd: "lexext gt (y # ys) (x # xs) \<longrightarrow> gt y x \<or> x = y \<and> lexext gt ys xs"
     proof
       assume "lexext gt (y # ys) (x # xs)"
       thus "gt y x \<or> x = y \<and> lexext gt ys xs"
         using lexext.cases by blast
     qed
     have backd: "gt y x \<or> x = y \<and> lexext gt ys xs \<longrightarrow> lexext gt (y # ys) (x # xs)"
       by (simp add: lexext_Cons lexext_Cons_eq)
     show "lexext gt (y # ys) (x # xs) = (gt y x \<or> x = y \<and> lexext gt ys xs)"
       using fwdd backd by blast
   qed
 qed
 
 lemma lexext_mono_strong:
   assumes
     "\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x" and
     "lexext gt ys xs"
   shows "lexext gt' ys xs"
   using assms by (induct ys xs rule: list_induct2') auto
 
 lemma lexext_map_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt (f y) (f x)) \<Longrightarrow> lexext gt ys xs \<Longrightarrow>
    lexext gt (map f ys) (map f xs)"
   by (induct ys xs rule: list_induct2') auto
 
 lemma lexext_irrefl:
   assumes "\<forall>x \<in> set xs. \<not> gt x x"
   shows "\<not> lexext gt xs xs"
   using assms by (induct xs) auto
 
 lemma lexext_trans_strong:
   assumes
     "\<forall>z \<in> set zs. \<forall>y \<in> set ys. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     "lexext gt zs ys" and "lexext gt ys xs"
   shows "lexext gt zs xs"
   using assms
 proof (induct zs arbitrary: ys xs)
   case (Cons z zs)
   note zs_trans = this(1)
   show ?case
     using Cons(2-4)
   proof (induct ys arbitrary: xs rule: list.induct)
     case (Cons y ys)
     note ys_trans = this(1) and gt_trans = this(2) and zzs_gt_yys = this(3) and yys_gt_xs = this(4)
     show ?case
     proof (cases xs)
       case xs: (Cons x xs)
       thus ?thesis
       proof (unfold xs)
         note yys_gt_xxs = yys_gt_xs[unfolded xs]
         note gt_trans = gt_trans[unfolded xs]
 
         let ?case = "lexext gt (z # zs) (x # xs)"
 
         {
           assume "gt z y" and "gt y x"
           hence ?case
             using gt_trans by simp
         }
         moreover
         {
           assume "gt z y" and "x = y"
           hence ?case
             by simp
         }
         moreover
         {
           assume "y = z" and "gt y x"
           hence ?case
             by simp
         }
         moreover
         {
           assume
             y_eq_z: "y = z" and
             zs_gt_ys: "lexext gt zs ys" and
             x_eq_y: "x = y" and
             ys_gt_xs: "lexext gt ys xs"
 
           have "lexext gt zs xs"
             by (rule zs_trans[OF _ zs_gt_ys ys_gt_xs]) (meson gt_trans[simplified])
           hence ?case
             by (simp add: x_eq_y y_eq_z)
         }
         ultimately show ?case
           using zzs_gt_yys yys_gt_xxs by force
       qed
     qed auto
   qed auto
 qed auto
 
 lemma lexext_snoc: "lexext gt (xs @ [x]) xs"
   by (induct xs) auto
 
 lemmas lexext_compat_cons = lexext_Cons_eq
 
 lemma lexext_compat_snoc_if_same_length:
   assumes "length ys = length xs" and "lexext gt ys xs"
   shows "lexext gt (ys @ [x]) (xs @ [x])"
   using assms(2,1) by (induct rule: lexext.induct) auto
 
 lemma lexext_compat_list: "gt y x \<Longrightarrow> lexext gt (xs @ y # xs') (xs @ x # xs')"
   by (induct xs) auto
 
 lemma lexext_singleton: "lexext gt [y] [x] \<longleftrightarrow> gt y x"
   by simp
 
 lemma lexext_total: "(\<forall>y \<in> B. \<forall>x \<in> A. gt y x \<or> gt x y \<or> y = x) \<Longrightarrow> ys \<in> lists B \<Longrightarrow> xs \<in> lists A \<Longrightarrow>
   lexext gt ys xs \<or> lexext gt xs ys \<or> ys = xs"
   by (induct ys xs rule: list_induct2') auto
 
 lemma lexext_hd_or_tl: "lexext gt (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> lexext gt ys xs"
   by auto
 
 interpretation lexext: ext lexext
   by standard (fact lexext_mono_strong, rule lexext_map_strong, metis in_listsD)
 
 interpretation lexext: ext_irrefl_trans_strong lexext
   by standard (fact lexext_irrefl, fact lexext_trans_strong)
 
 interpretation lexext: ext_snoc lexext
   by standard (fact lexext_snoc)
 
 interpretation lexext: ext_compat_cons lexext
   by standard (fact lexext_compat_cons)
 
 interpretation lexext: ext_compat_list lexext
   by standard (rule lexext_compat_list)
 
 interpretation lexext: ext_singleton lexext
   by standard (rule lexext_singleton)
 
 interpretation lexext: ext_total lexext
   by standard (fact lexext_total)
 
 interpretation lexext: ext_hd_or_tl lexext
   by standard (rule lexext_hd_or_tl)
 
 interpretation lexext: ext_wf_bounded lexext
   by standard
 
 
 subsection \<open>Reverse (Right-to-Left) Lexicographic Extension\<close>
 
 abbreviation lexext_rev :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "lexext_rev gt ys xs \<equiv> lexext gt (rev ys) (rev xs)"
 
 lemma lexext_rev_simps[simp]:
   "lexext_rev gt ys [] \<longleftrightarrow> ys \<noteq> []"
   "\<not> lexext_rev gt [] xs"
   "lexext_rev gt (ys @ [y]) (xs @ [x]) \<longleftrightarrow> gt y x \<or> x = y \<and> lexext_rev gt ys xs"
   by simp+
 
 lemma lexext_rev_cons_cons:
   assumes "length ys = length xs"
   shows "lexext_rev gt (y # ys) (x # xs) \<longleftrightarrow> lexext_rev gt ys xs \<or> ys = xs \<and> gt y x"
   using assms
 proof (induct arbitrary: y x rule: rev_induct2)
   case Nil
   thus ?case
     by simp
 next
   case (snoc y' ys x' xs)
   show ?case
     using snoc(2) by auto
 qed
 
 lemma lexext_rev_mono_strong:
   assumes
     "\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x" and
     "lexext_rev gt ys xs"
   shows "lexext_rev gt' ys xs"
   using assms by (simp add: lexext_mono_strong)
 
 lemma lexext_rev_map_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt (f y) (f x)) \<Longrightarrow> lexext_rev gt ys xs \<Longrightarrow>
    lexext_rev gt (map f ys) (map f xs)"
   by (simp add: lexext_map_strong rev_map)
 
 lemma lexext_rev_irrefl:
   assumes "\<forall>x \<in> set xs. \<not> gt x x"
   shows "\<not> lexext_rev gt xs xs"
   using assms by (simp add: lexext_irrefl)
 
 lemma lexext_rev_trans_strong:
   assumes
     "\<forall>z \<in> set zs. \<forall>y \<in> set ys. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     "lexext_rev gt zs ys" and "lexext_rev gt ys xs"
   shows "lexext_rev gt zs xs"
   using assms(1) lexext_trans_strong[OF _ assms(2,3), unfolded set_rev] by sat
 
 lemma lexext_rev_compat_cons_if_same_length:
   assumes "length ys = length xs" and "lexext_rev gt ys xs"
   shows "lexext_rev gt (x # ys) (x # xs)"
   using assms by (simp add: lexext_compat_snoc_if_same_length)
 
 lemma lexext_rev_compat_snoc: "lexext_rev gt ys xs \<Longrightarrow> lexext_rev gt (ys @ [x]) (xs @ [x])"
   by (simp add: lexext_compat_cons)
 
 lemma lexext_rev_compat_list: "gt y x \<Longrightarrow> lexext_rev gt (xs @ y # xs') (xs @ x # xs')"
   by (induct xs' rule: rev_induct) auto
 
 lemma lexext_rev_singleton: "lexext_rev gt [y] [x] \<longleftrightarrow> gt y x"
   by simp
 
 lemma lexext_rev_total:
   "(\<forall>y \<in> B. \<forall>x \<in> A. gt y x \<or> gt x y \<or> y = x) \<Longrightarrow> ys \<in> lists B \<Longrightarrow> xs \<in> lists A \<Longrightarrow>
    lexext_rev gt ys xs \<or> lexext_rev gt xs ys \<or> ys = xs"
   by (rule lexext_total[of _ _ _ "rev ys" "rev xs", simplified])
 
 lemma lexext_rev_hd_or_tl:
   assumes
     "length ys = length xs" and
     "lexext_rev gt (y # ys) (x # xs)"
   shows "gt y x \<or> lexext_rev gt ys xs"
   using assms lexext_rev_cons_cons by fastforce
 
 interpretation lexext_rev: ext lexext_rev
   by standard (fact lexext_rev_mono_strong, rule lexext_rev_map_strong, metis in_listsD)
 
 interpretation lexext_rev: ext_irrefl_trans_strong lexext_rev
   by standard (fact lexext_rev_irrefl, fact lexext_rev_trans_strong)
 
 interpretation lexext_rev: ext_compat_snoc lexext_rev
   by standard (fact lexext_rev_compat_snoc)
 
 interpretation lexext_rev: ext_compat_list lexext_rev
   by standard (rule lexext_rev_compat_list)
 
 interpretation lexext_rev: ext_singleton lexext_rev
   by standard (rule lexext_rev_singleton)
 
 interpretation lexext_rev: ext_total lexext_rev
   by standard (fact lexext_rev_total)
 
 interpretation lexext_rev: ext_hd_or_tl lexext_rev
   by standard (rule lexext_rev_hd_or_tl)
 
 interpretation lexext_rev: ext_wf_bounded lexext_rev
   by standard
 
 
 subsection \<open>Generic Length Extension\<close>
 
 definition lenext :: "('a list \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "lenext gts ys xs \<longleftrightarrow> length ys > length xs \<or> length ys = length xs \<and> gts ys xs"
 
 lemma
   lenext_mono_strong: "(gts ys xs \<Longrightarrow> gts' ys xs) \<Longrightarrow> lenext gts ys xs \<Longrightarrow> lenext gts' ys xs" and
   lenext_map_strong: "(length ys = length xs \<Longrightarrow> gts ys xs \<Longrightarrow> gts (map f ys) (map f xs)) \<Longrightarrow>
     lenext gts ys xs \<Longrightarrow> lenext gts (map f ys) (map f xs)" and
   lenext_irrefl: "\<not> gts xs xs \<Longrightarrow> \<not> lenext gts xs xs" and
   lenext_trans: "(gts zs ys \<Longrightarrow> gts ys xs \<Longrightarrow> gts zs xs) \<Longrightarrow> lenext gts zs ys \<Longrightarrow> lenext gts ys xs \<Longrightarrow>
     lenext gts zs xs" and
   lenext_snoc: "lenext gts (xs @ [x]) xs" and
   lenext_compat_cons: "(length ys = length xs \<Longrightarrow> gts ys xs \<Longrightarrow> gts (x # ys) (x # xs)) \<Longrightarrow>
     lenext gts ys xs \<Longrightarrow> lenext gts (x # ys) (x # xs)" and
   lenext_compat_snoc: "(length ys = length xs \<Longrightarrow> gts ys xs \<Longrightarrow> gts (ys @ [x]) (xs @ [x])) \<Longrightarrow>
     lenext gts ys xs \<Longrightarrow> lenext gts (ys @ [x]) (xs @ [x])" and
   lenext_compat_list: "gts (xs @ y # xs') (xs @ x # xs') \<Longrightarrow>
     lenext gts (xs @ y # xs') (xs @ x # xs')" and
   lenext_singleton: "lenext gts [y] [x] \<longleftrightarrow> gts [y] [x]" and
   lenext_total: "(gts ys xs \<or> gts xs ys \<or> ys = xs) \<Longrightarrow>
     lenext gts ys xs \<or> lenext gts xs ys \<or> ys = xs" and
   lenext_hd_or_tl: "(length ys = length xs \<Longrightarrow> gts (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> gts ys xs) \<Longrightarrow>
     lenext gts (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> lenext gts ys xs"
   unfolding lenext_def by auto
 
 
 subsection \<open>Length-Lexicographic Extension\<close>
 
 abbreviation len_lexext :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "len_lexext gt \<equiv> lenext (lexext gt)"
 
 lemma len_lexext_mono_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x) \<Longrightarrow> len_lexext gt ys xs \<Longrightarrow> len_lexext gt' ys xs"
   by (rule lenext_mono_strong[OF lexext_mono_strong])
 
 lemma len_lexext_map_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt (f y) (f x)) \<Longrightarrow> len_lexext gt ys xs \<Longrightarrow>
    len_lexext gt (map f ys) (map f xs)"
   by (rule lenext_map_strong) (metis lexext_map_strong)
 
 lemma len_lexext_irrefl: "(\<forall>x \<in> set xs. \<not> gt x x) \<Longrightarrow> \<not> len_lexext gt xs xs"
   by (rule lenext_irrefl[OF lexext_irrefl])
 
 lemma len_lexext_trans_strong:
   "(\<forall>z \<in> set zs. \<forall>y \<in> set ys. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow> len_lexext gt zs ys \<Longrightarrow>
    len_lexext gt ys xs \<Longrightarrow> len_lexext gt zs xs"
   by (rule lenext_trans[OF lexext_trans_strong])
 
 lemma len_lexext_snoc: "len_lexext gt (xs @ [x]) xs"
   by (rule lenext_snoc)
 
 lemma len_lexext_compat_cons: "len_lexext gt ys xs \<Longrightarrow> len_lexext gt (x # ys) (x # xs)"
   by (intro lenext_compat_cons lexext_compat_cons)
 
 lemma len_lexext_compat_snoc: "len_lexext gt ys xs \<Longrightarrow> len_lexext gt (ys @ [x]) (xs @ [x])"
   by (intro lenext_compat_snoc lexext_compat_snoc_if_same_length)
 
 lemma len_lexext_compat_list: "gt y x \<Longrightarrow> len_lexext gt (xs @ y # xs') (xs @ x # xs')"
   by (intro lenext_compat_list lexext_compat_list)
 
 lemma len_lexext_singleton[simp]: "len_lexext gt [y] [x] \<longleftrightarrow> gt y x"
   by (simp only: lenext_singleton lexext_singleton)
 
 lemma len_lexext_total: "(\<forall>y \<in> B. \<forall>x \<in> A. gt y x \<or> gt x y \<or> y = x) \<Longrightarrow> ys \<in> lists B \<Longrightarrow> xs \<in> lists A \<Longrightarrow>
   len_lexext gt ys xs \<or> len_lexext gt xs ys \<or> ys = xs"
   by (rule lenext_total[OF lexext_total])
 
 lemma len_lexext_iff_lenlex: "len_lexext gt ys xs \<longleftrightarrow> (xs, ys) \<in> lenlex {(x, y). gt y x}"
 proof -
   {
     assume "length xs = length ys"
     hence "lexext gt ys xs \<longleftrightarrow> (xs, ys) \<in> lex {(x, y). gt y x}"
       by (induct xs ys rule: list_induct2) auto
   }
   thus ?thesis
     unfolding lenext_def lenlex_conv by auto
 qed
 
 lemma len_lexext_wf: "wfP (\<lambda>x y. gt y x) \<Longrightarrow> wfP (\<lambda>xs ys. len_lexext gt ys xs)"
   unfolding wfP_def len_lexext_iff_lenlex by (simp add: wf_lenlex)
 
 lemma len_lexext_hd_or_tl: "len_lexext gt (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> len_lexext gt ys xs"
   using lenext_hd_or_tl lexext_hd_or_tl by metis
 
 interpretation len_lexext: ext len_lexext
   by standard (fact len_lexext_mono_strong, rule len_lexext_map_strong, metis in_listsD)
 
 interpretation len_lexext: ext_irrefl_trans_strong len_lexext
   by standard (fact len_lexext_irrefl, fact len_lexext_trans_strong)
 
 interpretation len_lexext: ext_snoc len_lexext
   by standard (fact len_lexext_snoc)
 
 interpretation len_lexext: ext_compat_cons len_lexext
   by standard (fact len_lexext_compat_cons)
 
 interpretation len_lexext: ext_compat_snoc len_lexext
   by standard (fact len_lexext_compat_snoc)
 
 interpretation len_lexext: ext_compat_list len_lexext
   by standard (rule len_lexext_compat_list)
 
 interpretation len_lexext: ext_singleton len_lexext
   by standard (rule len_lexext_singleton)
 
 interpretation len_lexext: ext_total len_lexext
   by standard (fact len_lexext_total)
 
 interpretation len_lexext: ext_wf len_lexext
   by standard (fact len_lexext_wf)
 
 interpretation len_lexext: ext_hd_or_tl len_lexext
   by standard (rule len_lexext_hd_or_tl)
 
 interpretation len_lexext: ext_wf_bounded len_lexext
   by standard
 
 
 subsection \<open>Reverse (Right-to-Left) Length-Lexicographic Extension\<close>
 
 abbreviation len_lexext_rev :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "len_lexext_rev gt \<equiv> lenext (lexext_rev gt)"
 
 lemma len_lexext_rev_mono_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x) \<Longrightarrow> len_lexext_rev gt ys xs \<Longrightarrow> len_lexext_rev gt' ys xs"
   by (rule lenext_mono_strong) (rule lexext_rev_mono_strong)
 
 lemma len_lexext_rev_map_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt (f y) (f x)) \<Longrightarrow> len_lexext_rev gt ys xs \<Longrightarrow>
    len_lexext_rev gt (map f ys) (map f xs)"
   by (rule lenext_map_strong) (rule lexext_rev_map_strong)
 
 lemma len_lexext_rev_irrefl: "(\<forall>x \<in> set xs. \<not> gt x x) \<Longrightarrow> \<not> len_lexext_rev gt xs xs"
   by (rule lenext_irrefl) (rule lexext_rev_irrefl)
 
 lemma len_lexext_rev_trans_strong:
   "(\<forall>z \<in> set zs. \<forall>y \<in> set ys. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x) \<Longrightarrow> len_lexext_rev gt zs ys \<Longrightarrow>
    len_lexext_rev gt ys xs \<Longrightarrow> len_lexext_rev gt zs xs"
   by (rule lenext_trans) (rule lexext_rev_trans_strong)
 
 lemma len_lexext_rev_snoc: "len_lexext_rev gt (xs @ [x]) xs"
   by (rule lenext_snoc)
 
 lemma len_lexext_rev_compat_cons: "len_lexext_rev gt ys xs \<Longrightarrow> len_lexext_rev gt (x # ys) (x # xs)"
   by (intro lenext_compat_cons lexext_rev_compat_cons_if_same_length)
 
 lemma len_lexext_rev_compat_snoc: "len_lexext_rev gt ys xs \<Longrightarrow> len_lexext_rev gt (ys @ [x]) (xs @ [x])"
   by (intro lenext_compat_snoc lexext_rev_compat_snoc)
 
 lemma len_lexext_rev_compat_list: "gt y x \<Longrightarrow> len_lexext_rev gt (xs @ y # xs') (xs @ x # xs')"
   by (intro lenext_compat_list lexext_rev_compat_list)
 
 lemma len_lexext_rev_singleton[simp]: "len_lexext_rev gt [y] [x] \<longleftrightarrow> gt y x"
   by (simp only: lenext_singleton lexext_rev_singleton)
 
 lemma len_lexext_rev_total: "(\<forall>y \<in> B. \<forall>x \<in> A. gt y x \<or> gt x y \<or> y = x) \<Longrightarrow> ys \<in> lists B \<Longrightarrow>
   xs \<in> lists A \<Longrightarrow> len_lexext_rev gt ys xs \<or> len_lexext_rev gt xs ys \<or> ys = xs"
   by (rule lenext_total[OF lexext_rev_total])
 
 lemma len_lexext_rev_iff_len_lexext: "len_lexext_rev gt ys xs \<longleftrightarrow> len_lexext gt (rev ys) (rev xs)"
   unfolding lenext_def by simp
 
 lemma len_lexext_rev_wf: "wfP (\<lambda>x y. gt y x) \<Longrightarrow> wfP (\<lambda>xs ys. len_lexext_rev gt ys xs)"
   unfolding len_lexext_rev_iff_len_lexext
   by (rule wfP_app[of "\<lambda>xs ys. len_lexext gt ys xs" rev, simplified]) (rule len_lexext_wf)
 
 lemma len_lexext_rev_hd_or_tl:
   "len_lexext_rev gt (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> len_lexext_rev gt ys xs"
   using lenext_hd_or_tl lexext_rev_hd_or_tl by metis
 
 interpretation len_lexext_rev: ext len_lexext_rev
   by standard (fact len_lexext_rev_mono_strong, rule len_lexext_rev_map_strong, metis in_listsD)
 
 interpretation len_lexext_rev: ext_irrefl_trans_strong len_lexext_rev
   by standard (fact len_lexext_rev_irrefl, fact len_lexext_rev_trans_strong)
 
 interpretation len_lexext_rev: ext_snoc len_lexext_rev
   by standard (fact len_lexext_rev_snoc)
 
 interpretation len_lexext_rev: ext_compat_cons len_lexext_rev
   by standard (fact len_lexext_rev_compat_cons)
 
 interpretation len_lexext_rev: ext_compat_snoc len_lexext_rev
   by standard (fact len_lexext_rev_compat_snoc)
 
 interpretation len_lexext_rev: ext_compat_list len_lexext_rev
   by standard (rule len_lexext_rev_compat_list)
 
 interpretation len_lexext_rev: ext_singleton len_lexext_rev
   by standard (rule len_lexext_rev_singleton)
 
 interpretation len_lexext_rev: ext_total len_lexext_rev
   by standard (fact len_lexext_rev_total)
 
 interpretation len_lexext_rev: ext_wf len_lexext_rev
   by standard (fact len_lexext_rev_wf)
 
 interpretation len_lexext_rev: ext_hd_or_tl len_lexext_rev
   by standard (rule len_lexext_rev_hd_or_tl)
 
 interpretation len_lexext_rev: ext_wf_bounded len_lexext_rev
   by standard
 
 
 subsection \<open>Dershowitz--Manna Multiset Extension\<close>
 
 definition msetext_dersh where
   "msetext_dersh gt ys xs = (let N = mset ys; M = mset xs in
      (\<exists>Y X. Y \<noteq> {#} \<and> Y \<subseteq># N \<and> M = (N - Y) + X \<and> (\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> gt y x))))"
 
 text \<open>
 The following proof is based on that of @{thm[source] less_multiset\<^sub>D\<^sub>M_imp_mult}.
 \<close>
 
 lemma msetext_dersh_imp_mult_rel:
   assumes
     ys_a: "ys \<in> lists A" and xs_a: "xs \<in> lists A" and
     ys_gt_xs: "msetext_dersh gt ys xs"
   shows "(mset xs, mset ys) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> gt y x}"
 proof -
   obtain Y X where y_nemp: "Y \<noteq> {#}" and y_sub_ys: "Y \<subseteq># mset ys" and
     xs_eq: "mset xs = mset ys - Y + X" and ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> gt y x)"
     using ys_gt_xs[unfolded msetext_dersh_def Let_def] by blast
   have ex_y': "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> x \<in> A \<and> y \<in> A \<and> gt y x)"
     using ex_y y_sub_ys xs_eq ys_a xs_a by (metis in_listsD mset_subset_eqD set_mset_mset union_iff)
   hence "(mset ys - Y + X, mset ys - Y + Y) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> gt y x}"
     using y_nemp y_sub_ys by (intro one_step_implies_mult) (auto simp: Bex_def trans_def)
   thus ?thesis
     using xs_eq y_sub_ys by (simp add: subset_mset.diff_add)
 qed
 
 lemma msetext_dersh_imp_mult: "msetext_dersh gt ys xs \<Longrightarrow> (mset xs, mset ys) \<in> mult {(x, y). gt y x}"
   using msetext_dersh_imp_mult_rel[of _ UNIV] by auto
 
 lemma mult_imp_msetext_dersh_rel:
   assumes
     ys_a: "set_mset (mset ys) \<subseteq> A" and xs_a: "set_mset (mset xs) \<subseteq> A" and
     in_mult: "(mset xs, mset ys) \<in> mult {(x, y). x \<in> A \<and> y \<in> A \<and> gt y x}" and
     trans: "\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x"
   shows "msetext_dersh gt ys xs"
   using in_mult ys_a xs_a unfolding mult_def msetext_dersh_def Let_def
 proof induct
   case (base Ys)
   then obtain y M0 X where "Ys = M0 + {#y#}" and "mset xs = M0 + X" and "\<forall>a. a \<in># X \<longrightarrow> gt y a"
     unfolding mult1_def by auto
   thus ?case
     by (auto intro: exI[of _ "{#y#}"] exI[of _ X])
 next
   case (step Ys Zs)
   note ys_zs_in_mult1 = this(2) and ih = this(3) and zs_a = this(4) and xs_a = this(5)
 
   have Ys_a: "set_mset Ys \<subseteq> A"
     using ys_zs_in_mult1 zs_a unfolding mult1_def by auto
 
   obtain Y X where y_nemp: "Y \<noteq> {#}" and y_sub_ys: "Y \<subseteq># Ys" and xs_eq: "mset xs = Ys - Y + X" and
     ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> gt y x)"
     using ih[OF Ys_a xs_a] by blast
 
   obtain z M0 Ya where zs_eq: "Zs = M0 + {#z#}" and ys_eq: "Ys = M0 + Ya" and
     z_gt: "\<forall>y. y \<in># Ya \<longrightarrow> y \<in> A \<and> z \<in> A \<and> gt z y"
     using ys_zs_in_mult1[unfolded mult1_def] by auto
 
   let ?Za = "Y - Ya + {#z#}"
   let ?Xa = "X + Ya + (Y - Ya) - Y"
 
   have xa_sub_x_ya: "set_mset ?Xa \<subseteq> set_mset (X + Ya)"
     by (metis diff_subset_eq_self in_diffD subsetI subset_mset.diff_diff_right)
 
   have x_a: "set_mset X \<subseteq> A"
     using xs_a xs_eq by auto
   have ya_a: "set_mset Ya \<subseteq> A"
     by (simp add: subsetI z_gt)
 
   have ex_y': "\<exists>y. y \<in># Y - Ya + {#z#} \<and> gt y x" if x_in: "x \<in># X + Ya" for x
   proof (cases "x \<in># X")
     case True
     then obtain y where y_in: "y \<in># Y" and y_gt_x: "gt y x"
       using ex_y by blast
     show ?thesis
     proof (cases "y \<in># Ya")
       case False
       hence "y \<in># Y - Ya + {#z#}"
         using y_in by fastforce
       thus ?thesis
         using y_gt_x by blast
     next
       case True
       hence "y \<in> A" and "z \<in> A" and "gt z y"
         using z_gt by blast+
       hence "gt z x"
         using trans y_gt_x x_a ya_a x_in by (meson subsetCE union_iff)
       thus ?thesis
         by auto
     qed
   next
     case False
     hence "x \<in># Ya"
       using x_in by auto
     hence "x \<in> A" and "z \<in> A" and "gt z x"
       using z_gt by blast+
     thus ?thesis
       by auto
   qed
 
   show ?case
   proof (rule exI[of _ ?Za], rule exI[of _ ?Xa], intro conjI)
     show "Y - Ya + {#z#} \<subseteq># Zs"
       using mset_subset_eq_mono_add subset_eq_diff_conv y_sub_ys ys_eq zs_eq by fastforce
   next
     show "mset xs = Zs - (Y - Ya + {#z#}) + (X + Ya + (Y - Ya) - Y)"
       unfolding xs_eq ys_eq zs_eq by (auto simp: multiset_eq_iff)
   next
     show "\<forall>x. x \<in># X + Ya + (Y - Ya) - Y \<longrightarrow> (\<exists>y. y \<in># Y - Ya + {#z#} \<and> gt y x)"
       using ex_y' xa_sub_x_ya by blast
   qed auto
 qed
 
 lemma msetext_dersh_mono_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x) \<Longrightarrow> msetext_dersh gt ys xs \<Longrightarrow>
   msetext_dersh gt' ys xs"
   unfolding msetext_dersh_def Let_def
   by (metis mset_subset_eqD mset_subset_eq_add_right set_mset_mset)
 
 lemma msetext_dersh_map_strong:
   assumes
     compat_f: "\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt (f y) (f x)" and
     ys_gt_xs: "msetext_dersh gt ys xs"
   shows "msetext_dersh gt (map f ys) (map f xs)"
 proof -
   obtain Y X where
     y_nemp: "Y \<noteq> {#}" and y_sub_ys: "Y \<subseteq># mset ys" and xs_eq: "mset xs = mset ys - Y + X" and
     ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> gt y x)"
     using ys_gt_xs[unfolded msetext_dersh_def Let_def mset_map] by blast
 
   have x_sub_xs: "X \<subseteq># mset xs"
     using xs_eq by simp
 
   let ?fY = "image_mset f Y"
   let ?fX = "image_mset f X"
 
   show ?thesis
     unfolding msetext_dersh_def Let_def mset_map
   proof (intro exI conjI)
     show "image_mset f (mset xs) = image_mset f (mset ys) - ?fY + ?fX"
       using xs_eq[THEN arg_cong, of "image_mset f"] y_sub_ys by (metis image_mset_Diff image_mset_union)
   next
     obtain y where y: "\<forall>x. x \<in># X \<longrightarrow> y x \<in># Y \<and> gt (y x) x"
       using ex_y by moura
 
     show "\<forall>fx. fx \<in># ?fX \<longrightarrow> (\<exists>fy. fy \<in># ?fY \<and> gt fy fx)"
     proof (intro allI impI)
       fix fx
       assume "fx \<in># ?fX"
       then obtain x where fx: "fx = f x" and x_in: "x \<in># X"
         by auto
       hence y_in: "y x \<in># Y" and y_gt: "gt (y x) x"
         using y[rule_format, OF x_in] by blast+
       hence "f (y x) \<in># ?fY \<and> gt (f (y x)) (f x)"
         using compat_f y_sub_ys x_sub_xs x_in
         by (metis image_eqI in_image_mset mset_subset_eqD set_mset_mset)
       thus "\<exists>fy. fy \<in># ?fY \<and> gt fy fx"
         unfolding fx by auto
     qed
   qed (auto simp: y_nemp y_sub_ys image_mset_subseteq_mono)
 qed
 
 lemma msetext_dersh_trans:
   assumes
     zs_a: "zs \<in> lists A" and
     ys_a: "ys \<in> lists A" and
     xs_a: "xs \<in> lists A" and
     trans: "\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     zs_gt_ys: "msetext_dersh gt zs ys" and
     ys_gt_xs: "msetext_dersh gt ys xs"
   shows "msetext_dersh gt zs xs"
 proof (rule mult_imp_msetext_dersh_rel[OF _ _ _ trans])
   show "set_mset (mset zs) \<subseteq> A"
     using zs_a by auto
 next
   show "set_mset (mset xs) \<subseteq> A"
     using xs_a by auto
 next
   let ?Gt = "{(x, y). x \<in> A \<and> y \<in> A \<and> gt y x}"
 
   have "(mset xs, mset ys) \<in> mult ?Gt"
     by (rule msetext_dersh_imp_mult_rel[OF ys_a xs_a ys_gt_xs])
   moreover have "(mset ys, mset zs) \<in> mult ?Gt"
     by (rule msetext_dersh_imp_mult_rel[OF zs_a ys_a zs_gt_ys])
   ultimately show "(mset xs, mset zs) \<in> mult ?Gt"
     unfolding mult_def by simp
 qed
 
 lemma msetext_dersh_irrefl_from_trans:
   assumes
     trans: "\<forall>z \<in> set xs. \<forall>y \<in> set xs. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     irrefl: "\<forall>x \<in> set xs. \<not> gt x x"
   shows "\<not> msetext_dersh gt xs xs"
   unfolding msetext_dersh_def Let_def
 proof clarify
   fix Y X
   assume y_nemp: "Y \<noteq> {#}" and y_sub_xs: "Y \<subseteq># mset xs" and xs_eq: "mset xs = mset xs - Y + X" and
     ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> gt y x)"
 
   have x_eq_y: "X = Y"
     using y_sub_xs xs_eq by (metis diff_union_cancelL subset_mset.diff_add)
 
   let ?Gt = "{(y, x). y \<in># Y \<and> x \<in># Y \<and> gt y x}"
 
   have "?Gt \<subseteq> set_mset Y \<times> set_mset Y"
     by auto
   hence fin: "finite ?Gt"
     by (auto dest!: infinite_super)
   moreover have "irrefl ?Gt"
     unfolding irrefl_def using irrefl y_sub_xs by (fastforce dest!: set_mset_mono)
   moreover have "trans ?Gt"
     unfolding trans_def using trans y_sub_xs by (fastforce dest!: set_mset_mono)
   ultimately have acyc: "acyclic ?Gt"
     by (rule finite_irrefl_trans_imp_wf[THEN wf_acyclic])
 
   have fin_y: "finite (set_mset Y)"
     using y_sub_xs by simp
   hence cyc: "\<not> acyclic ?Gt"
     proof (rule finite_nonempty_ex_succ_imp_cyclic)
       show "\<forall>x \<in># Y. \<exists>y \<in># Y. (y, x) \<in> ?Gt"
         using ex_y[unfolded x_eq_y] by auto
     qed (auto simp: y_nemp)
 
   show False
     using acyc cyc by sat
 qed
 
 lemma msetext_dersh_snoc: "msetext_dersh gt (xs @ [x]) xs"
   unfolding msetext_dersh_def Let_def
 proof (intro exI conjI)
   show "mset xs = mset (xs @ [x]) - {#x#} + {#}"
     by simp
 qed auto
 
 lemma msetext_dersh_compat_cons:
   assumes ys_gt_xs: "msetext_dersh gt ys xs"
   shows "msetext_dersh gt (x # ys) (x # xs)"
 proof -
   obtain Y X where
     y_nemp: "Y \<noteq> {#}" and y_sub_ys: "Y \<subseteq># mset ys" and xs_eq: "mset xs = mset ys - Y + X" and
     ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> gt y x)"
     using ys_gt_xs[unfolded msetext_dersh_def Let_def mset_map] by blast
 
   show ?thesis
     unfolding msetext_dersh_def Let_def
   proof (intro exI conjI)
     show "Y \<subseteq># mset (x # ys)"
       using y_sub_ys
       by (metis add_mset_add_single mset.simps(2) mset_subset_eq_add_left
         subset_mset.add_increasing2)
   next
     show "mset (x # xs) = mset (x # ys) - Y + X"
     proof -
       have "X + (mset ys - Y) = mset xs"
         by (simp add: union_commute xs_eq)
       hence "mset (x # xs) = X + (mset (x # ys) - Y)"
         by (metis add_mset_add_single mset.simps(2) mset_subset_eq_multiset_union_diff_commute
           union_mset_add_mset_right y_sub_ys)
       thus ?thesis
         by (simp add: union_commute)
     qed
   qed (auto simp: y_nemp ex_y)
 qed
 
 lemma msetext_dersh_compat_snoc: "msetext_dersh gt ys xs \<Longrightarrow> msetext_dersh gt (ys @ [x]) (xs @ [x])"
   using msetext_dersh_compat_cons[of gt ys xs x] unfolding msetext_dersh_def by simp
 
 lemma msetext_dersh_compat_list:
   assumes y_gt_x: "gt y x"
   shows "msetext_dersh gt (xs @ y # xs') (xs @ x # xs')"
   unfolding msetext_dersh_def Let_def
 proof (intro exI conjI)
   show "mset (xs @ x # xs') = mset (xs @ y # xs') - {#y#} + {#x#}"
     by auto
 qed (auto intro: y_gt_x)
 
 lemma msetext_dersh_singleton: "msetext_dersh gt [y] [x] \<longleftrightarrow> gt y x"
   unfolding msetext_dersh_def Let_def
   by (auto dest: nonempty_subseteq_mset_eq_singleton simp: nonempty_subseteq_mset_iff_singleton)
 
 lemma msetext_dersh_wf:
   assumes wf_gt: "wfP (\<lambda>x y. gt y x)"
   shows "wfP (\<lambda>xs ys. msetext_dersh gt ys xs)"
 proof (rule wfP_subset, rule wfP_app[of "\<lambda>xs ys. (xs, ys) \<in> mult {(x, y). gt y x}" mset])
   show "wfP (\<lambda>xs ys. (xs, ys) \<in> mult {(x, y). gt y x})"
     using wf_gt unfolding wfP_def by (auto intro: wf_mult)
 next
   show "(\<lambda>xs ys. msetext_dersh gt ys xs) \<le> (\<lambda>x y. (mset x, mset y) \<in> mult {(x, y). gt y x})"
     using msetext_dersh_imp_mult by blast
 qed
 
 interpretation msetext_dersh: ext msetext_dersh
   by standard (fact msetext_dersh_mono_strong, rule msetext_dersh_map_strong, metis in_listsD)
 
 interpretation msetext_dersh: ext_trans_before_irrefl msetext_dersh
   by standard (fact msetext_dersh_trans, fact msetext_dersh_irrefl_from_trans)
 
 interpretation msetext_dersh: ext_snoc msetext_dersh
   by standard (fact msetext_dersh_snoc)
 
 interpretation msetext_dersh: ext_compat_cons msetext_dersh
   by standard (fact msetext_dersh_compat_cons)
 
 interpretation msetext_dersh: ext_compat_snoc msetext_dersh
   by standard (fact msetext_dersh_compat_snoc)
 
 interpretation msetext_dersh: ext_compat_list msetext_dersh
   by standard (rule msetext_dersh_compat_list)
 
 interpretation msetext_dersh: ext_singleton msetext_dersh
   by standard (rule msetext_dersh_singleton)
 
 interpretation msetext_dersh: ext_wf msetext_dersh
   by standard (fact msetext_dersh_wf)
 
 
 subsection \<open>Huet--Oppen Multiset Extension\<close>
 
 definition msetext_huet where
   "msetext_huet gt ys xs = (let N = mset ys; M = mset xs in
      M \<noteq> N \<and> (\<forall>x. count M x > count N x \<longrightarrow> (\<exists>y. gt y x \<and> count N y > count M y)))"
 
 lemma msetext_huet_imp_count_gt:
   assumes ys_gt_xs: "msetext_huet gt ys xs"
   shows "\<exists>x. count (mset ys) x > count (mset xs) x"
 proof -
   obtain x where "count (mset ys) x \<noteq> count (mset xs) x"
     using ys_gt_xs[unfolded msetext_huet_def Let_def] by (fastforce intro: multiset_eqI)
   moreover
   {
     assume "count (mset ys) x < count (mset xs) x"
     hence ?thesis
       using ys_gt_xs[unfolded msetext_huet_def Let_def] by blast
   }
   moreover
   {
     assume "count (mset ys) x > count (mset xs) x"
     hence ?thesis
       by fast
   }
   ultimately show ?thesis
     by fastforce
 qed
 
 lemma msetext_huet_imp_dersh:
   assumes huet: "msetext_huet gt ys xs"
   shows "msetext_dersh gt ys xs"
 proof (unfold msetext_dersh_def Let_def, intro exI conjI)
   let ?X = "mset xs - mset ys"
   let ?Y = "mset ys - mset xs"
 
   show "?Y \<noteq> {#}"
     by (metis msetext_huet_imp_count_gt[OF huet] empty_iff in_diff_count set_mset_empty)
   show "?Y \<subseteq># mset ys"
     by auto
   show "mset xs = mset ys - ?Y + ?X"
     by (rule multiset_eqI) simp
   show "\<forall>x. x \<in># ?X \<longrightarrow> (\<exists>y. y \<in># ?Y \<and> gt y x)"
     using huet[unfolded msetext_huet_def Let_def, THEN conjunct2] by (meson in_diff_count)
 qed
 
 text \<open>
 The following proof is based on that of @{thm[source] mult_imp_less_multiset\<^sub>H\<^sub>O}.
 \<close>
 
 lemma mult_imp_msetext_huet:
   assumes
     irrefl: "irreflp gt" and trans: "transp gt" and
     in_mult: "(mset xs, mset ys) \<in> mult {(x, y). gt y x}"
   shows "msetext_huet gt ys xs"
   using in_mult unfolding mult_def msetext_huet_def Let_def
 proof (induct rule: trancl_induct)
   case (base Ys)
   thus ?case
     using irrefl unfolding irreflp_def msetext_huet_def Let_def mult1_def
     by (auto 0 3 split: if_splits)
 next
   case (step Ys Zs)
 
   have asym[unfolded antisym_def, simplified]: "antisymp gt"
     by (rule irreflp_transp_imp_antisymP[OF irrefl trans])
 
   from step(3) have "mset xs \<noteq> Ys" and
     **: "\<And>x. count Ys x < count (mset xs) x \<Longrightarrow> (\<exists>y. gt y x \<and> count (mset xs) y < count Ys y)"
     by blast+
   from step(2) obtain M0 a K where
     *: "Zs = M0 + {#a#}" "Ys = M0 + K" "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> gt a b"
     using irrefl unfolding mult1_def irreflp_def by force
   have "mset xs \<noteq> Zs"
   proof (cases "K = {#}")
     case True
     thus ?thesis
       using \<open>mset xs \<noteq> Ys\<close> ** *(1,2) irrefl[unfolded irreflp_def]
       by (metis One_nat_def add.comm_neutral count_single diff_union_cancelL lessI
         minus_multiset.rep_eq not_add_less2 plus_multiset.rep_eq union_commute zero_less_diff)
   next
     case False
     thus ?thesis
     proof -
       obtain aa :: "'a \<Rightarrow> 'a" where
         f1: "\<forall>a. \<not> count Ys a < count (mset xs) a \<or> gt (aa a) a \<and>
           count (mset xs) (aa a) < count Ys (aa a)"
-        using "**" by moura
+        using ** by moura
       have f2: "K + M0 = Ys"
-        using "*"(2) union_ac(2) by blast
+        using *(2) union_ac(2) by blast
       have f3: "\<And>aa. count Zs aa = count M0 aa + count {#a#} aa"
-        by (simp add: "*"(1))
+        by (simp add: *(1))
       have f4: "\<And>a. count Ys a = count K a + count M0 a"
         using f2 by auto
       have f5: "count K a = 0"
-        by (meson "*"(3) count_inI)
+        by (meson *(3) count_inI)
       have "Zs - M0 = {#a#}"
-        using "*"(1) add_diff_cancel_left' by blast
+        using *(1) add_diff_cancel_left' by blast
       then have f6: "count M0 a < count Zs a"
         by (metis in_diff_count union_single_eq_member)
       have "\<And>m. count m a = 0 + count m a"
         by simp
       moreover
       { assume "aa a \<noteq> a"
         then have "mset xs = Zs \<and> count Zs (aa a) < count K (aa a) + count M0 (aa a) \<longrightarrow>
           count K (aa a) + count M0 (aa a) < count Zs (aa a)"
-          using f5 f3 f2 f1 "*"(4) asym by (auto dest!: antisympD) }
+          using f5 f3 f2 f1 *(4) asym by (auto dest!: antisympD) }
       ultimately show ?thesis
         using f6 f5 f4 f1 by (metis less_imp_not_less)
     qed
   qed
   moreover
   {
     assume "count Zs a \<le> count (mset xs) a"
     with \<open>a \<notin># K\<close> have "count Ys a < count (mset xs) a" unfolding *(1,2)
       by (auto simp add: not_in_iff)
-      with ** obtain z where z: "gt z a" "count (mset xs) z < count Ys z"
-        by blast
-      with * have "count Ys z \<le> count Zs z"
-        using asym
-        by (auto simp: intro: count_inI dest: antisympD)
-      with z have "\<exists>z. gt z a \<and> count (mset xs) z < count Zs z" by auto
+    with ** obtain z where z: "gt z a" "count (mset xs) z < count Ys z"
+      by blast
+    with * have "count Ys z \<le> count Zs z"
+      using asym by (auto simp: intro: count_inI dest: antisympD)
+    with z have "\<exists>z. gt z a \<and> count (mset xs) z < count Zs z" by auto
   }
   note count_a = this
   {
     fix y
     assume count_y: "count Zs y < count (mset xs) y"
     have "\<exists>x. gt x y \<and> count (mset xs) x < count Zs x"
     proof (cases "y = a")
       case True
       with count_y count_a show ?thesis by auto
     next
       case False
       show ?thesis
       proof (cases "y \<in># K")
         case True
         with *(4) have "gt a y" by simp
         then show ?thesis
           by (cases "count Zs a \<le> count (mset xs) a",
             blast dest: count_a trans[unfolded transp_def, rule_format], auto dest: count_a)
       next
         case False
         with \<open>y \<noteq> a\<close> have "count Zs y = count Ys y" unfolding *(1,2)
           by (simp add: not_in_iff)
         with count_y ** obtain z where z: "gt z y" "count (mset xs) z < count Ys z" by auto
         show ?thesis
         proof (cases "z \<in># K")
           case True
           with *(4) have "gt a z" by simp
           with z(1) show ?thesis
             by (cases "count Zs a \<le> count (mset xs) a")
               (blast dest: count_a not_le_imp_less trans[unfolded transp_def, rule_format])+
         next
           case False
           with \<open>a \<notin># K\<close> have "count Ys z \<le> count Zs z" unfolding *
             by (auto simp add: not_in_iff)
           with z show ?thesis by auto
         qed
       qed
     qed
   }
   ultimately show ?case
     unfolding msetext_huet_def Let_def by blast
 qed
 
 theorem msetext_huet_eq_dersh: "irreflp gt \<Longrightarrow> transp gt \<Longrightarrow> msetext_dersh gt = msetext_huet gt"
   using msetext_huet_imp_dersh msetext_dersh_imp_mult mult_imp_msetext_huet by fast
 
 lemma msetext_huet_mono_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x) \<Longrightarrow> msetext_huet gt ys xs \<Longrightarrow> msetext_huet gt' ys xs"
   unfolding msetext_huet_def
   by (metis less_le_trans mem_Collect_eq not_le not_less0 set_mset_mset[unfolded set_mset_def])
 
 lemma msetext_huet_map:
   assumes
     fin: "finite A" and
     ys_a: "ys \<in> lists A" and xs_a: "xs \<in> lists A" and
     irrefl_f: "\<forall>x \<in> A. \<not> gt (f x) (f x)" and
     trans_f: "\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt (f z) (f y) \<longrightarrow> gt (f y) (f x) \<longrightarrow> gt (f z) (f x)" and
     compat_f: "\<forall>y \<in> A. \<forall>x \<in> A. gt y x \<longrightarrow> gt (f y) (f x)" and
     ys_gt_xs: "msetext_huet gt ys xs"
   shows "msetext_huet gt (map f ys) (map f xs)" (is "msetext_huet _ ?fys ?fxs")
 proof -
   have irrefl: "\<forall>x \<in> A. \<not> gt x x"
     using irrefl_f compat_f by blast
 
   have
     ms_xs_ne_ys: "mset xs \<noteq> mset ys" and
     ex_gt: "\<forall>x. count (mset ys) x < count (mset xs) x \<longrightarrow>
       (\<exists>y. gt y x \<and> count (mset xs) y < count (mset ys) y)"
     using ys_gt_xs[unfolded msetext_huet_def Let_def] by blast+
 
   have ex_y: "\<exists>y. gt (f y) (f x) \<and> count (mset ?fxs) (f y) < count (mset (map f ys)) (f y)"
     if cnt_x: "count (mset xs) x > count (mset ys) x" for x
   proof -
     have x_in_a: "x \<in> A"
       using cnt_x xs_a dual_order.strict_trans2 by fastforce
 
     obtain y where y_gt_x: "gt y x" and cnt_y: "count (mset ys) y > count (mset xs) y"
       using cnt_x ex_gt by blast
     have y_in_a: "y \<in> A"
       using cnt_y ys_a dual_order.strict_trans2 by fastforce
 
     have wf_gt_f: "wfP (\<lambda>y x. y \<in> A \<and> x \<in> A \<and> gt (f y) (f x))"
       by (rule finite_irreflp_transp_imp_wfp)
         (auto elim: trans_f[rule_format] simp: fin irrefl_f Collect_case_prod_Sigma irreflp_def
            transp_def)
 
     obtain yy where
       fyy_gt_fx: "gt (f yy) (f x)" and
       cnt_yy: "count (mset ys) yy > count (mset xs) yy" and
       max_yy: "\<forall>y \<in> A. yy \<in> A \<longrightarrow> gt (f y) (f yy) \<longrightarrow> gt (f y) (f x) \<longrightarrow>
         count (mset xs) y \<ge> count (mset ys) y"
       using wfP_eq_minimal[THEN iffD1, OF wf_gt_f, rule_format,
           of y "{y. gt (f y) (f x) \<and> count (mset xs) y < count (mset ys) y}", simplified]
         y_gt_x cnt_y
       by (metis compat_f not_less x_in_a y_in_a)
     have yy_in_a: "yy \<in> A"
       using cnt_yy ys_a dual_order.strict_trans2 by fastforce
 
     {
       assume "count (mset ?fxs) (f yy) \<ge> count (mset ?fys) (f yy)"
       then obtain u where fu_eq_fyy: "f u = f yy" and cnt_u: "count (mset xs) u > count (mset ys) u"
         using count_image_mset_le_imp_lt cnt_yy mset_map by (metis (mono_tags))
       have u_in_a: "u \<in> A"
         using cnt_u xs_a dual_order.strict_trans2 by fastforce
 
       obtain v where v_gt_u: "gt v u" and cnt_v: "count (mset ys) v > count (mset xs) v"
         using cnt_u ex_gt by blast
       have v_in_a: "v \<in> A"
         using cnt_v ys_a dual_order.strict_trans2 by fastforce
 
       have fv_gt_fu: "gt (f v) (f u)"
         using v_gt_u compat_f v_in_a u_in_a by blast
       hence fv_gt_fyy: "gt (f v) (f yy)"
         by (simp only: fu_eq_fyy)
 
       have "gt (f v) (f x)"
         using fv_gt_fyy fyy_gt_fx v_in_a yy_in_a x_in_a trans_f by blast
       hence False
         using max_yy[rule_format, of v] fv_gt_fyy v_in_a yy_in_a cnt_v by linarith
     }
     thus ?thesis
       using fyy_gt_fx leI by blast
   qed
 
   show ?thesis
     unfolding msetext_huet_def Let_def
   proof (intro conjI allI impI)
     {
       assume len_eq: "length xs = length ys"
       obtain x where cnt_x: "count (mset xs) x > count (mset ys) x"
         using len_eq ms_xs_ne_ys by (metis size_eq_ex_count_lt size_mset)
       hence "mset ?fxs \<noteq> mset ?fys"
         using ex_y by fastforce
     }
     thus "mset ?fxs \<noteq> mset (map f ys)"
       by (metis length_map size_mset)
   next
     fix fx
     assume cnt_fx: "count (mset ?fxs) fx > count (mset ?fys) fx"
     then obtain x where fx: "fx = f x" and cnt_x: "count (mset xs) x > count (mset ys) x"
       using count_image_mset_lt_imp_lt mset_map by (metis (mono_tags))
     thus "\<exists>fy. gt fy fx \<and> count (mset ?fxs) fy < count (mset (map f ys)) fy"
       using ex_y[OF cnt_x] by blast
   qed
 qed
 
 lemma msetext_huet_irrefl: "(\<forall>x \<in> set xs. \<not> gt x x) \<Longrightarrow> \<not> msetext_huet gt xs xs"
   unfolding msetext_huet_def by simp
 
 lemma msetext_huet_trans_from_irrefl:
   assumes
     fin: "finite A" and
     zs_a: "zs \<in> lists A" and ys_a: "ys \<in> lists A" and xs_a: "xs \<in> lists A" and
     irrefl: "\<forall>x \<in> A. \<not> gt x x" and
     trans: "\<forall>z \<in> A. \<forall>y \<in> A. \<forall>x \<in> A. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     zs_gt_ys: "msetext_huet gt zs ys" and
     ys_gt_xs: "msetext_huet gt ys xs"
   shows "msetext_huet gt zs xs"
 proof -
   have wf_gt: "wfP (\<lambda>y x. y \<in> A \<and> x \<in> A \<and> gt y x)"
     by (rule finite_irreflp_transp_imp_wfp)
       (auto elim: trans[rule_format] simp: fin irrefl Collect_case_prod_Sigma irreflp_def
          transp_def)
 
   show ?thesis
     unfolding msetext_huet_def Let_def
   proof (intro conjI allI impI)
     obtain x where cnt_x: "count (mset zs) x > count (mset ys) x"
       using msetext_huet_imp_count_gt[OF zs_gt_ys] by blast
     have x_in_a: "x \<in> A"
       using cnt_x zs_a dual_order.strict_trans2 by fastforce
 
     obtain xx where
       cnt_xx: "count (mset zs) xx > count (mset ys) xx" and
       max_xx: "\<forall>y \<in> A. xx \<in> A \<longrightarrow> gt y xx \<longrightarrow> count (mset ys) y \<ge> count (mset zs) y"
       using wfP_eq_minimal[THEN iffD1, OF wf_gt, rule_format,
           of x "{y. count (mset ys) y < count (mset zs) y}", simplified]
         cnt_x
       by force
     have xx_in_a: "xx \<in> A"
       using cnt_xx zs_a dual_order.strict_trans2 by fastforce
 
     show "mset xs \<noteq> mset zs"
     proof (cases "count (mset ys) xx \<ge> count (mset xs) xx")
       case True
       thus ?thesis
         using cnt_xx by fastforce
     next
       case False
       hence "count (mset ys) xx < count (mset xs) xx"
         by fastforce
       then obtain z where z_gt_xx: "gt z xx" and cnt_z: "count (mset ys) z > count (mset xs) z"
         using ys_gt_xs[unfolded msetext_huet_def Let_def] by blast
       have z_in_a: "z \<in> A"
         using cnt_z ys_a dual_order.strict_trans2 by fastforce
 
       have "count (mset zs) z \<le> count (mset ys) z"
         using max_xx[rule_format, of z] z_in_a xx_in_a z_gt_xx by blast
       moreover
       {
         assume "count (mset zs) z < count (mset ys) z"
         then obtain u where u_gt_z: "gt u z" and cnt_u: "count (mset ys) u < count (mset zs) u"
           using zs_gt_ys[unfolded msetext_huet_def Let_def] by blast
         have u_in_a: "u \<in> A"
           using cnt_u zs_a dual_order.strict_trans2 by fastforce
         have u_gt_xx: "gt u xx"
           using trans u_in_a z_in_a xx_in_a u_gt_z z_gt_xx by blast
         have False
           using max_xx[rule_format, of u] u_in_a xx_in_a u_gt_xx cnt_u by fastforce
       }
       ultimately have "count (mset zs) z = count (mset ys) z"
         by fastforce
       thus ?thesis
         using cnt_z by fastforce
     qed
   next
     fix x
     assume cnt_x_xz: "count (mset zs) x < count (mset xs) x"
     have x_in_a: "x \<in> A"
       using cnt_x_xz xs_a dual_order.strict_trans2 by fastforce
 
     let ?case = "\<exists>y. gt y x \<and> count (mset zs) y > count (mset xs) y"
 
     {
       assume cnt_x: "count (mset zs) x < count (mset ys) x"
       then obtain y where y_gt_x: "gt y x" and cnt_y: "count (mset zs) y > count (mset ys) y"
         using zs_gt_ys[unfolded msetext_huet_def Let_def] by blast
       have y_in_a: "y \<in> A"
         using cnt_y zs_a dual_order.strict_trans2 by fastforce
 
       obtain yy where
         yy_gt_x: "gt yy x" and
         cnt_yy: "count (mset zs) yy > count (mset ys) yy" and
         max_yy: "\<forall>y \<in> A. yy \<in> A \<longrightarrow> gt y yy \<longrightarrow> gt y x \<longrightarrow> count (mset ys) y \<ge> count (mset zs) y"
         using wfP_eq_minimal[THEN iffD1, OF wf_gt, rule_format,
             of y "{y. gt y x \<and> count (mset ys) y < count (mset zs) y}", simplified]
           y_gt_x cnt_y
         by force
       have yy_in_a: "yy \<in> A"
         using cnt_yy zs_a dual_order.strict_trans2 by fastforce
 
       have ?case
       proof (cases "count (mset ys) yy \<ge> count (mset xs) yy")
         case True
         thus ?thesis
           using yy_gt_x cnt_yy by fastforce
       next
         case False
         hence "count (mset ys) yy < count (mset xs) yy"
           by fastforce
         then obtain z where z_gt_yy: "gt z yy" and cnt_z: "count (mset ys) z > count (mset xs) z"
           using ys_gt_xs[unfolded msetext_huet_def Let_def] by blast
         have z_in_a: "z \<in> A"
           using cnt_z ys_a dual_order.strict_trans2 by fastforce
         have z_gt_x: "gt z x"
           using trans z_in_a yy_in_a x_in_a z_gt_yy yy_gt_x by blast
 
         have "count (mset zs) z \<le> count (mset ys) z"
           using max_yy[rule_format, of z] z_in_a yy_in_a z_gt_yy z_gt_x by blast
         moreover
         {
           assume "count (mset zs) z < count (mset ys) z"
           then obtain u where u_gt_z: "gt u z" and cnt_u: "count (mset ys) u < count (mset zs) u"
             using zs_gt_ys[unfolded msetext_huet_def Let_def] by blast
           have u_in_a: "u \<in> A"
             using cnt_u zs_a dual_order.strict_trans2 by fastforce
           have u_gt_yy: "gt u yy"
             using trans u_in_a z_in_a yy_in_a u_gt_z z_gt_yy by blast
           have u_gt_x: "gt u x"
             using trans u_in_a z_in_a x_in_a u_gt_z z_gt_x by blast
           have False
             using max_yy[rule_format, of u] u_in_a yy_in_a u_gt_yy u_gt_x cnt_u by fastforce
         }
         ultimately have "count (mset zs) z = count (mset ys) z"
           by fastforce
         thus ?thesis
           using z_gt_x cnt_z by fastforce
       qed
     }
     moreover
     {
       assume "count (mset zs) x \<ge> count (mset ys) x"
       hence "count (mset ys) x < count (mset xs) x"
         using cnt_x_xz by fastforce
       then obtain y where y_gt_x: "gt y x" and cnt_y: "count (mset ys) y > count (mset xs) y"
         using ys_gt_xs[unfolded msetext_huet_def Let_def] by blast
       have y_in_a: "y \<in> A"
         using cnt_y ys_a dual_order.strict_trans2 by fastforce
 
       obtain yy where
         yy_gt_x: "gt yy x" and
         cnt_yy: "count (mset ys) yy > count (mset xs) yy" and
         max_yy: "\<forall>y \<in> A. yy \<in> A \<longrightarrow> gt y yy \<longrightarrow> gt y x \<longrightarrow> count (mset xs) y \<ge> count (mset ys) y"
         using wfP_eq_minimal[THEN iffD1, OF wf_gt, rule_format,
             of y "{y. gt y x \<and> count (mset xs) y < count (mset ys) y}", simplified]
           y_gt_x cnt_y
         by force
       have yy_in_a: "yy \<in> A"
         using cnt_yy ys_a dual_order.strict_trans2 by fastforce
 
       have ?case
       proof (cases "count (mset zs) yy \<ge> count (mset ys) yy")
         case True
         thus ?thesis
           using yy_gt_x cnt_yy by fastforce
       next
         case False
         hence "count (mset zs) yy < count (mset ys) yy"
           by fastforce
         then obtain z where z_gt_yy: "gt z yy" and cnt_z: "count (mset zs) z > count (mset ys) z"
           using zs_gt_ys[unfolded msetext_huet_def Let_def] by blast
         have z_in_a: "z \<in> A"
           using cnt_z zs_a dual_order.strict_trans2 by fastforce
         have z_gt_x: "gt z x"
           using trans z_in_a yy_in_a x_in_a z_gt_yy yy_gt_x by blast
 
         have "count (mset ys) z \<le> count (mset xs) z"
           using max_yy[rule_format, of z] z_in_a yy_in_a z_gt_yy z_gt_x by blast
         moreover
         {
           assume "count (mset ys) z < count (mset xs) z"
           then obtain u where u_gt_z: "gt u z" and cnt_u: "count (mset xs) u < count (mset ys) u"
             using ys_gt_xs[unfolded msetext_huet_def Let_def] by blast
           have u_in_a: "u \<in> A"
             using cnt_u ys_a dual_order.strict_trans2 by fastforce
           have u_gt_yy: "gt u yy"
             using trans u_in_a z_in_a yy_in_a u_gt_z z_gt_yy by blast
           have u_gt_x: "gt u x"
             using trans u_in_a z_in_a x_in_a u_gt_z z_gt_x by blast
           have False
             using max_yy[rule_format, of u] u_in_a yy_in_a u_gt_yy u_gt_x cnt_u by fastforce
         }
         ultimately have "count (mset ys) z = count (mset xs) z"
           by fastforce
         thus ?thesis
           using z_gt_x cnt_z by fastforce
       qed
     }
     ultimately show "\<exists>y. gt y x \<and> count (mset xs) y < count (mset zs) y"
       by fastforce
   qed
 qed
 
 lemma msetext_huet_snoc: "msetext_huet gt (xs @ [x]) xs"
   unfolding msetext_huet_def Let_def by simp
 
 lemma msetext_huet_compat_cons: "msetext_huet gt ys xs \<Longrightarrow> msetext_huet gt (x # ys) (x # xs)"
   unfolding msetext_huet_def Let_def by auto
 
 lemma msetext_huet_compat_snoc: "msetext_huet gt ys xs \<Longrightarrow> msetext_huet gt (ys @ [x]) (xs @ [x])"
   unfolding msetext_huet_def Let_def by auto
 
 lemma msetext_huet_compat_list: "y \<noteq> x \<Longrightarrow> gt y x \<Longrightarrow> msetext_huet gt (xs @ y # xs') (xs @ x # xs')"
   unfolding msetext_huet_def Let_def by auto
 
 lemma msetext_huet_singleton: "y \<noteq> x \<Longrightarrow> msetext_huet gt [y] [x] \<longleftrightarrow> gt y x"
   unfolding msetext_huet_def by simp
 
 lemma msetext_huet_wf: "wfP (\<lambda>x y. gt y x) \<Longrightarrow> wfP (\<lambda>xs ys. msetext_huet gt ys xs)"
   by (erule wfP_subset[OF msetext_dersh_wf]) (auto intro: msetext_huet_imp_dersh)
 
 lemma msetext_huet_hd_or_tl:
   assumes
     trans: "\<forall>z y x. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     total: "\<forall>y x. gt y x \<or> gt x y \<or> y = x" and
     len_eq: "length ys = length xs" and
     yys_gt_xxs: "msetext_huet gt (y # ys) (x # xs)"
   shows "gt y x \<or> msetext_huet gt ys xs"
 proof -
   let ?Y = "mset (y # ys)"
   let ?X = "mset (x # xs)"
 
   let ?Ya = "mset ys"
   let ?Xa = "mset xs"
 
   have Y_ne_X: "?Y \<noteq> ?X" and
     ex_gt_Y: "\<And>xa. count ?X xa > count ?Y xa \<Longrightarrow> \<exists>ya. gt ya xa \<and> count ?Y ya > count ?X ya"
     using yys_gt_xxs[unfolded msetext_huet_def Let_def] by auto
   obtain yy where
     yy: "\<And>xa. count ?X xa > count ?Y xa \<Longrightarrow> gt (yy xa) xa \<and> count ?Y (yy xa) > count ?X (yy xa)"
     using ex_gt_Y by metis
 
   have cnt_Y_pres: "count ?Ya xa > count ?Xa xa" if "count ?Y xa > count ?X xa" and "xa \<noteq> y" for xa
     using that by (auto split: if_splits)
   have cnt_X_pres: "count ?Xa xa > count ?Ya xa" if "count ?X xa > count ?Y xa" and "xa \<noteq> x" for xa
     using that by (auto split: if_splits)
 
   {
     assume y_eq_x: "y = x"
     have "?Xa \<noteq> ?Ya"
       using y_eq_x Y_ne_X by simp
     moreover have "\<And>xa. count ?Xa xa > count ?Ya xa \<Longrightarrow> \<exists>ya. gt ya xa \<and> count ?Ya ya > count ?Xa ya"
     proof -
       fix xa :: 'a
       assume a1: "count (mset ys) xa < count (mset xs) xa"
       from ex_gt_Y obtain aa :: "'a \<Rightarrow> 'a" where
         f3: "\<forall>a. \<not> count (mset (y # ys)) a < count (mset (x # xs)) a \<or> gt (aa a) a \<and>
           count (mset (x # xs)) (aa a) < count (mset (y # ys)) (aa a)"
         by (metis (full_types))
       then have f4: "\<And>a. count (mset (x # xs)) (aa a) < count (mset (x # ys)) (aa a) \<or>
           \<not> count (mset (x # ys)) a < count (mset (x # xs)) a"
         using y_eq_x by meson
       have "\<And>a as aa. count (mset ((a::'a) # as)) aa = count (mset as) aa \<or> aa = a"
         by fastforce
       then have "xa = x \<or> count (mset (x # xs)) (aa xa) < count (mset (x # ys)) (aa xa)"
         using f4 a1 by (metis (no_types))
       then show "\<exists>a. gt a xa \<and> count (mset xs) a < count (mset ys) a"
         using f3 y_eq_x a1 by (metis (no_types) Suc_less_eq count_add_mset mset.simps(2))
     qed
     ultimately have "msetext_huet gt ys xs"
       unfolding msetext_huet_def Let_def by simp
   }
   moreover
   {
     assume x_gt_y: "gt x y" and y_ngt_x: "\<not> gt y x"
     hence y_ne_x: "y \<noteq> x"
       by fast
 
     obtain z where z_cnt: "count ?X z > count ?Y z"
       using size_eq_ex_count_lt[of ?Y ?X] size_mset size_mset len_eq Y_ne_X by auto
 
     have Xa_ne_Ya: "?Xa \<noteq> ?Ya"
     proof (cases "z = x")
       case True
       hence "yy z \<noteq> y"
         using y_ngt_x yy z_cnt by blast
       hence "count ?Ya (yy z) > count ?Xa (yy z)"
         using cnt_Y_pres yy z_cnt by blast
       thus ?thesis
         by auto
     next
       case False
       hence "count ?Xa z > count ?Ya z"
         using z_cnt cnt_X_pres by blast
       thus ?thesis
         by auto
     qed
 
     have "\<exists>ya. gt ya xa \<and> count ?Ya ya > count ?Xa ya"
       if xa_cnta: "count ?Xa xa > count ?Ya xa" for xa
     proof (cases "xa = y")
       case xa_eq_y: True
 
       {
         assume "count ?Ya x > count ?Xa x"
         moreover have "gt x xa"
           unfolding xa_eq_y by (rule x_gt_y)
         ultimately have ?thesis
           by fast
       }
       moreover
       {
         assume "count ?Xa x \<ge> count ?Ya x"
         hence x_cnt: "count ?X x > count ?Y x"
           by (simp add: y_ne_x)
         hence yyx_gt_x: "gt (yy x) x" and yyx_cnt: "count ?Y (yy x) > count ?X (yy x)"
           using yy by blast+
 
         have yyx_ne_y: "yy x \<noteq> y"
           using y_ngt_x yyx_gt_x by auto
 
         have "gt (yy x) xa"
           unfolding xa_eq_y using trans yyx_gt_x x_gt_y by blast
         moreover have "count ?Ya (yy x) > count ?Xa (yy x)"
           using cnt_Y_pres yyx_cnt yyx_ne_y by blast
         ultimately have ?thesis
           by blast
       }
       ultimately show ?thesis
         by fastforce
     next
       case False
       hence xa_cnt: "count ?X xa > count ?Y xa"
         using xa_cnta by fastforce
 
       show ?thesis
       proof (cases "yy xa = y \<and> count ?Ya y \<le> count ?Xa y")
         case yyxa_ne_y_or: False
 
         have yyxa_gt_xa: "gt (yy xa) xa" and yyxa_cnt: "count ?Y (yy xa) > count ?X (yy xa)"
           using yy[OF xa_cnt] by blast+
 
         have "count ?Ya (yy xa) > count ?Xa (yy xa)"
           using cnt_Y_pres yyxa_cnt yyxa_ne_y_or by fastforce
         thus ?thesis
           using yyxa_gt_xa by blast
       next
         case True
         note yyxa_eq_y = this[THEN conjunct1] and y_cnt = this[THEN conjunct2]
 
         {
           assume "count ?Ya x > count ?Xa x"
           moreover have "gt x xa"
             using trans x_gt_y xa_cnt yy yyxa_eq_y by blast
           ultimately have ?thesis
             by fast
         }
         moreover
         {
           assume "count ?Xa x \<ge> count ?Ya x"
           hence x_cnt: "count ?X x > count ?Y x"
             by (simp add: y_ne_x)
           hence yyx_gt_x: "gt (yy x) x" and yyx_cnt: "count ?Y (yy x) > count ?X (yy x)"
             using yy by blast+
 
           have yyx_ne_y: "yy x \<noteq> y"
             using y_ngt_x yyx_gt_x by auto
 
           have "gt (yy x) xa"
             using trans x_gt_y xa_cnt yy yyx_gt_x yyxa_eq_y by blast
           moreover have "count ?Ya (yy x) > count ?Xa (yy x)"
             using cnt_Y_pres yyx_cnt yyx_ne_y by blast
           ultimately have ?thesis
             by blast
         }
         ultimately show ?thesis
           by fastforce
       qed
     qed
     hence "msetext_huet gt ys xs"
       unfolding msetext_huet_def Let_def using Xa_ne_Ya by fast
   }
   ultimately show ?thesis
     using total by blast
 qed
 
 interpretation msetext_huet: ext msetext_huet
   by standard (fact msetext_huet_mono_strong, fact msetext_huet_map)
 
 interpretation msetext_huet: ext_irrefl_before_trans msetext_huet
   by standard (fact msetext_huet_irrefl, fact msetext_huet_trans_from_irrefl)
 
 interpretation msetext_huet: ext_snoc msetext_huet
   by standard (fact msetext_huet_snoc)
 
 interpretation msetext_huet: ext_compat_cons msetext_huet
   by standard (fact msetext_huet_compat_cons)
 
 interpretation msetext_huet: ext_compat_snoc msetext_huet
   by standard (fact msetext_huet_compat_snoc)
 
 interpretation msetext_huet: ext_compat_list msetext_huet
   by standard (fact msetext_huet_compat_list)
 
 interpretation msetext_huet: ext_singleton msetext_huet
   by standard (fact msetext_huet_singleton)
 
 interpretation msetext_huet: ext_wf msetext_huet
   by standard (fact msetext_huet_wf)
 
 interpretation msetext_huet: ext_hd_or_tl msetext_huet
   by standard (rule msetext_huet_hd_or_tl)
 
 interpretation msetext_huet: ext_wf_bounded msetext_huet
   by standard
 
 
 subsection \<open>Componentwise Extension\<close>
 
 definition cwiseext :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "cwiseext gt ys xs \<longleftrightarrow> length ys = length xs
      \<and> (\<forall>i < length ys. gt (ys ! i) (xs ! i) \<or> ys ! i = xs ! i)
      \<and> (\<exists>i < length ys. gt (ys ! i) (xs ! i))"
 
 lemma cwiseext_imp_len_lexext:
   assumes cw: "cwiseext gt ys xs"
   shows "len_lexext gt ys xs"
 proof -
   have len_eq: "length ys = length xs"
     using cw[unfolded cwiseext_def] by sat
   moreover have "lexext gt ys xs"
   proof -
     obtain j where
       j_len: "j < length ys" and
       j_gt: "gt (ys ! j) (xs ! j)"
       using cw[unfolded cwiseext_def] by blast
     then obtain j0 where
       j0_len: "j0 < length ys" and
       j0_gt: "gt (ys ! j0) (xs ! j0)" and
       j0_min: "\<And>i. i < j0 \<Longrightarrow> \<not> gt (ys ! i) (xs ! i)"
       using wf_eq_minimal[THEN iffD1, OF wf_less, rule_format, of _ "{i. gt (ys ! i) (xs ! i)}",
         simplified, OF j_gt]
       by (metis less_trans nat_neq_iff)
 
     have j0_eq: "\<And>i. i < j0 \<Longrightarrow> ys ! i = xs ! i"
       using cw[unfolded cwiseext_def] by (metis j0_len j0_min less_trans)
 
     have "lexext gt (drop j0 ys) (drop j0 xs)"
       using lexext_Cons[of gt _ _ "drop (Suc j0) ys" "drop (Suc j0) xs", OF j0_gt]
       by (metis Cons_nth_drop_Suc j0_len len_eq)
     thus ?thesis
       using cw len_eq j0_len j0_min
     proof (induct j0 arbitrary: ys xs)
       case (Suc k)
       note ih0 = this(1) and gts_dropSk = this(2) and cw = this(3) and len_eq = this(4) and
         Sk_len = this(5) and Sk_min = this(6)
 
       have Sk_eq: "\<And>i. i < Suc k \<Longrightarrow> ys ! i = xs ! i"
         using cw[unfolded cwiseext_def] by (metis Sk_len Sk_min less_trans)
 
       have k_len: "k < length ys"
         using Sk_len by simp
       have k_min: "\<And>i. i < k \<Longrightarrow> \<not> gt (ys ! i) (xs ! i)"
         using Sk_min by simp
 
       have k_eq: "\<And>i. i < k \<Longrightarrow> ys ! i = xs ! i"
         using Sk_eq by simp
 
       note ih = ih0[OF _ cw len_eq k_len k_min]
 
       show ?case
       proof (cases "k < length ys")
         case k_lt_ys: True
         note k_lt_xs = k_lt_ys[unfolded len_eq]
 
         obtain x where x: "x = xs ! k"
           by simp
         hence y: "x = ys ! k"
           using Sk_eq[of k] by simp
 
         have dropk_xs: "drop k xs = x # drop (Suc k) xs"
           using k_lt_xs x by (simp add: Cons_nth_drop_Suc)
         have dropk_ys: "drop k ys = x # drop (Suc k) ys"
           using k_lt_ys y by (simp add: Cons_nth_drop_Suc)
 
         show ?thesis
           by (rule ih, unfold dropk_xs dropk_ys, rule lexext_Cons_eq[OF gts_dropSk])
       next
         case False
         hence "drop k xs = []" and "drop k ys = []"
           using len_eq by simp_all
         hence "lexext gt [] []"
           using gts_dropSk by simp
         hence "lexext gt (drop k ys) (drop k xs)"
           by simp
         thus ?thesis
           by (rule ih)
       qed
     qed simp
   qed
   ultimately show ?thesis
     unfolding lenext_def by sat
 qed
 
 lemma cwiseext_mono_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt' y x) \<Longrightarrow> cwiseext gt ys xs \<Longrightarrow> cwiseext gt' ys xs"
   unfolding cwiseext_def by (induct, force, fast)
 
 lemma cwiseext_map_strong:
   "(\<forall>y \<in> set ys. \<forall>x \<in> set xs. gt y x \<longrightarrow> gt (f y) (f x)) \<Longrightarrow> cwiseext gt ys xs \<Longrightarrow>
    cwiseext gt (map f ys) (map f xs)"
   unfolding cwiseext_def by auto
 
 lemma cwiseext_irrefl: "(\<forall>x \<in> set xs. \<not> gt x x) \<Longrightarrow> \<not> cwiseext gt xs xs"
   unfolding cwiseext_def by (blast intro: nth_mem)
 
 lemma cwiseext_trans_strong:
   assumes
     "\<forall>z \<in> set zs. \<forall>y \<in> set ys. \<forall>x \<in> set xs. gt z y \<longrightarrow> gt y x \<longrightarrow> gt z x" and
     "cwiseext gt zs ys" and "cwiseext gt ys xs"
   shows "cwiseext gt zs xs"
   using assms unfolding cwiseext_def by (metis (mono_tags) nth_mem)
 
 lemma cwiseext_compat_cons: "cwiseext gt ys xs \<Longrightarrow> cwiseext gt (x # ys) (x # xs)"
   unfolding cwiseext_def
 proof (elim conjE, intro conjI)
   assume
     "length ys = length xs" and
     "\<forall>i < length ys. gt (ys ! i) (xs ! i) \<or> ys ! i = xs ! i"
   thus "\<forall>i < length (x # ys). gt ((x # ys) ! i) ((x # xs) ! i) \<or> (x # ys) ! i = (x # xs) ! i"
     by (simp add: nth_Cons')
 next
   assume "\<exists>i < length ys. gt (ys ! i) (xs ! i)"
   thus "\<exists>i < length (x # ys). gt ((x # ys) ! i) ((x # xs) ! i)"
     by fastforce
 qed auto
 
 lemma cwiseext_compat_snoc: "cwiseext gt ys xs \<Longrightarrow> cwiseext gt (ys @ [x]) (xs @ [x])"
   unfolding cwiseext_def
 proof (elim conjE, intro conjI)
   assume
     "length ys = length xs" and
     "\<forall>i < length ys. gt (ys ! i) (xs ! i) \<or> ys ! i = xs ! i"
   thus "\<forall>i < length (ys @ [x]).
     gt ((ys @ [x]) ! i) ((xs @ [x]) ! i) \<or> (ys @ [x]) ! i = (xs @ [x]) ! i"
     by (simp add: nth_append)
 next
   assume
     "length ys = length xs" and
     "\<exists>i < length ys. gt (ys ! i) (xs ! i)"
   thus "\<exists>i < length (ys @ [x]). gt ((ys @ [x]) ! i) ((xs @ [x]) ! i)"
     by (metis length_append_singleton less_Suc_eq nth_append)
 qed auto
 
 lemma cwiseext_compat_list:
   assumes y_gt_x: "gt y x"
   shows "cwiseext gt (xs @ y # xs') (xs @ x # xs')"
   unfolding cwiseext_def
 proof (intro conjI)
   show "\<forall>i < length (xs @ y # xs'). gt ((xs @ y # xs') ! i) ((xs @ x # xs') ! i)
     \<or> (xs @ y # xs') ! i = (xs @ x # xs') ! i"
     using y_gt_x by (simp add: nth_Cons' nth_append)
 next
   show "\<exists>i < length (xs @ y # xs'). gt ((xs @ y # xs') ! i) ((xs @ x # xs') ! i)"
     using y_gt_x by (metis add_diff_cancel_right' append_is_Nil_conv diff_less length_append
       length_greater_0_conv list.simps(3) nth_append_length)
 qed auto
 
 lemma cwiseext_singleton: "cwiseext gt [y] [x] \<longleftrightarrow> gt y x"
   unfolding cwiseext_def by auto
 
 lemma cwiseext_wf: "wfP (\<lambda>x y. gt y x) \<Longrightarrow> wfP (\<lambda>xs ys. cwiseext gt ys xs)"
   by (auto intro: cwiseext_imp_len_lexext wfP_subset[OF len_lexext_wf])
 
 lemma cwiseext_hd_or_tl: "cwiseext gt (y # ys) (x # xs) \<Longrightarrow> gt y x \<or> cwiseext gt ys xs"
   unfolding cwiseext_def
 proof (elim conjE, intro disj_imp[THEN iffD2, rule_format] conjI)
   assume
     "\<exists>i < length (y # ys). gt ((y # ys) ! i) ((x # xs) ! i)" and
     "\<not> gt y x"
   thus "\<exists>i < length ys. gt (ys ! i) (xs ! i)"
     by (metis (no_types) One_nat_def diff_le_self diff_less dual_order.strict_trans2
       length_Cons less_Suc_eq linorder_neqE_nat not_less0 nth_Cons')
 qed auto
 
 locale ext_cwiseext = ext_compat_list + ext_compat_cons
 begin
 
 context
   fixes gt :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   assumes
     gt_irrefl: "\<not> gt x x" and
     trans_gt: "ext gt zs ys \<Longrightarrow> ext gt ys xs \<Longrightarrow> ext gt zs xs"
 begin
 
 lemma
   assumes ys_gtcw_xs: "cwiseext gt ys xs"
   shows "ext gt ys xs"
 proof -
   have "length ys = length xs"
     by (rule ys_gtcw_xs[unfolded cwiseext_def, THEN conjunct1])
   thus ?thesis
     using ys_gtcw_xs
   proof (induct rule: list_induct2)
     case Nil
     thus ?case
       unfolding cwiseext_def by simp
   next
     case (Cons y ys x xs)
     note len_ys_eq_xs = this(1) and ih = this(2) and yys_gtcw_xxs = this(3)
 
     have xys_gts_xxs: "ext gt (x # ys) (x # xs)" if ys_ne_xs: "ys \<noteq> xs"
     proof -
       have ys_gtcw_xs: "cwiseext gt ys xs"
         using yys_gtcw_xxs unfolding cwiseext_def
       proof (elim conjE, intro conjI)
         assume
           "\<forall>i < length (y # ys). gt ((y # ys) ! i) ((x # xs) ! i) \<or> (y # ys) ! i = (x # xs) ! i"
         hence ge: "\<forall>i < length ys. gt (ys ! i) (xs ! i) \<or> ys ! i = xs ! i"
           by auto
         thus "\<exists>i < length ys. gt (ys ! i) (xs ! i)"
           using ys_ne_xs len_ys_eq_xs nth_equalityI by blast
       qed auto
       hence "ext gt ys xs"
         by (rule ih)
       thus "ext gt (x # ys) (x # xs)"
         by (rule compat_cons)
     qed
 
     have "gt y x \<or> y = x"
       using yys_gtcw_xxs unfolding cwiseext_def by fastforce
     moreover
     {
       assume y_eq_x: "y = x"
       have ?case
       proof (cases "ys = xs")
         case True
         hence False
           using y_eq_x gt_irrefl yys_gtcw_xxs unfolding cwiseext_def by presburger
         thus ?thesis
           by sat
       next
         case False
         thus ?thesis
           using y_eq_x xys_gts_xxs by simp
       qed
     }
     moreover
     {
       assume "y \<noteq> x" and "gt y x"
       hence yys_gts_xys: "ext gt (y # ys) (x # ys)"
         using compat_list[of _ _ gt "[]"] by simp
 
       have ?case
       proof (cases "ys = xs")
         case ys_eq_xs: True
         thus ?thesis
           using yys_gts_xys by simp
       next
         case False
         thus ?thesis
           using yys_gts_xys xys_gts_xxs trans_gt by blast
       qed
     }
     ultimately show ?case
       by sat
   qed
 qed
 
 end
 
 end
 
 interpretation cwiseext: ext cwiseext
   by standard (fact cwiseext_mono_strong, rule cwiseext_map_strong, metis in_listsD)
 
 interpretation cwiseext: ext_irrefl_trans_strong cwiseext
   by standard (fact cwiseext_irrefl, fact cwiseext_trans_strong)
 
 interpretation cwiseext: ext_compat_cons cwiseext
   by standard (fact cwiseext_compat_cons)
 
 interpretation cwiseext: ext_compat_snoc cwiseext
   by standard (fact cwiseext_compat_snoc)
 
 interpretation cwiseext: ext_compat_list cwiseext
   by standard (rule cwiseext_compat_list)
 
 interpretation cwiseext: ext_singleton cwiseext
   by standard (rule cwiseext_singleton)
 
 interpretation cwiseext: ext_wf cwiseext
   by standard (rule cwiseext_wf)
 
 interpretation cwiseext: ext_hd_or_tl cwiseext
   by standard (rule cwiseext_hd_or_tl)
 
 interpretation cwiseext: ext_wf_bounded cwiseext
   by standard
 
 end
diff --git a/thys/Refine_Monadic/Refine_Leof.thy b/thys/Refine_Monadic/Refine_Leof.thy
--- a/thys/Refine_Monadic/Refine_Leof.thy
+++ b/thys/Refine_Monadic/Refine_Leof.thy
@@ -1,224 +1,224 @@
 section \<open>Less-Equal or Fail\<close>
 (* TODO: Move to Refinement Framework *)
 theory Refine_Leof
 imports Refine_Basic
 begin
   text \<open>A predicate that states refinement or that the LHS fails.\<close>
 
 
   definition le_or_fail :: "'a nres \<Rightarrow> 'a nres \<Rightarrow> bool" (infix "\<le>\<^sub>n" 50) where
     "m \<le>\<^sub>n m' \<equiv> nofail m \<longrightarrow> m \<le> m'"
 
   lemma leofI[intro?]: 
     assumes "nofail m \<Longrightarrow> m \<le> m'" shows "m \<le>\<^sub>n m'" 
     using assms unfolding le_or_fail_def by auto
   
   lemma leofD:  
     assumes "nofail m"
     assumes "m \<le>\<^sub>n m'"
     shows "m \<le> m'"
     using assms unfolding le_or_fail_def by blast
 
   lemma pw_leof_iff:
     "m \<le>\<^sub>n m' \<longleftrightarrow> (nofail m \<longrightarrow> (\<forall>x. inres m x \<longrightarrow> inres m' x))"
     unfolding le_or_fail_def by (auto simp add: pw_le_iff refine_pw_simps)
       
   lemma le_by_leofI: "\<lbrakk> nofail m' \<Longrightarrow> nofail m; m\<le>\<^sub>nm' \<rbrakk> \<Longrightarrow> m \<le> m'"
     by (auto simp: pw_le_iff pw_leof_iff)
       
   lemma inres_leof_mono: "m\<le>\<^sub>nm' \<Longrightarrow> nofail m \<Longrightarrow> inres m x \<Longrightarrow> inres m' x"
     by (auto simp: pw_leof_iff)
 
   lemma leof_trans[trans]: "\<lbrakk>a \<le>\<^sub>n RES X; RES X \<le>\<^sub>n c\<rbrakk> \<Longrightarrow> a \<le>\<^sub>n c"
     by (auto simp: pw_leof_iff)
 
   lemma leof_trans_nofail: "\<lbrakk> a\<le>\<^sub>nb; nofail b; b\<le>\<^sub>nc \<rbrakk> \<Longrightarrow> a \<le>\<^sub>n c"  
     by (auto simp: pw_leof_iff)
 
   lemma leof_refl[simp]: "a \<le>\<^sub>n a" 
     by (auto simp: pw_leof_iff)
 
   lemma leof_RES_UNIV[simp, intro!]: "m \<le>\<^sub>n RES UNIV" 
     by (auto simp: pw_leof_iff)
 
   lemma leof_FAIL[simp, intro!]: "m \<le>\<^sub>n FAIL" by (auto simp: pw_leof_iff)
   lemma FAIL_leof[simp, intro!]: "FAIL \<le>\<^sub>n m"  
     by (auto simp: le_or_fail_def)
       
   lemma leof_lift:
     "m \<le> F \<Longrightarrow> m \<le>\<^sub>n F"
     by (auto simp add: pw_leof_iff pw_le_iff)
 
   lemma leof_RETURN_rule[refine_vcg]: 
     "\<Phi> m \<Longrightarrow> RETURN m \<le>\<^sub>n SPEC \<Phi>" by (simp add: pw_leof_iff)
   
   lemma leof_bind_rule[refine_vcg]: 
     "\<lbrakk> m \<le>\<^sub>n SPEC (\<lambda>x. f x \<le>\<^sub>n SPEC \<Phi>) \<rbrakk> \<Longrightarrow> m\<bind>f \<le>\<^sub>n SPEC \<Phi>" 
     by (auto simp add: pw_leof_iff refine_pw_simps)
   
   lemma RETURN_leof_RES_iff[simp]: "RETURN x \<le>\<^sub>n RES Y \<longleftrightarrow> x\<in>Y"
     by (auto simp add: pw_leof_iff refine_pw_simps)
 
   lemma RES_leof_RES_iff[simp]: "RES X \<le>\<^sub>n RES Y \<longleftrightarrow> X \<subseteq> Y"
     by (auto simp add: pw_leof_iff refine_pw_simps)
    
   lemma leof_Let_rule[refine_vcg]: "f x \<le>\<^sub>n SPEC \<Phi> \<Longrightarrow> Let x f \<le>\<^sub>n SPEC \<Phi>" 
     by simp
 
   lemma leof_If_rule[refine_vcg]: 
     "\<lbrakk>c \<Longrightarrow> t \<le>\<^sub>n SPEC \<Phi>; \<not>c \<Longrightarrow> e \<le>\<^sub>n SPEC \<Phi>\<rbrakk> \<Longrightarrow> If c t e \<le>\<^sub>n SPEC \<Phi>" 
     by simp
 
   lemma leof_RES_rule[refine_vcg]:
     "\<lbrakk>\<And>x. \<Psi> x \<Longrightarrow> \<Phi> x\<rbrakk> \<Longrightarrow> SPEC \<Psi> \<le>\<^sub>n SPEC \<Phi>"
     "\<lbrakk>\<And>x. x\<in>X \<Longrightarrow> \<Phi> x\<rbrakk> \<Longrightarrow> RES X \<le>\<^sub>n SPEC \<Phi>"
     by auto
 
   lemma leof_True_rule: "\<lbrakk>\<And>x. \<Phi> x\<rbrakk> \<Longrightarrow> m \<le>\<^sub>n SPEC \<Phi>"
     by (auto simp add: pw_leof_iff refine_pw_simps)
 
   lemma sup_leof_iff: "(sup a b \<le>\<^sub>n m) \<longleftrightarrow> (nofail a \<and> nofail b \<longrightarrow> a\<le>\<^sub>nm \<and> b\<le>\<^sub>nm)"  
     by (auto simp: pw_leof_iff refine_pw_simps)
 
   lemma sup_leof_rule[refine_vcg]:
     assumes "\<lbrakk>nofail a; nofail b\<rbrakk> \<Longrightarrow> a\<le>\<^sub>nm"
     assumes "\<lbrakk>nofail a; nofail b\<rbrakk> \<Longrightarrow> b\<le>\<^sub>nm"
     shows "sup a b \<le>\<^sub>n m"
     using assms by (auto simp: pw_leof_iff refine_pw_simps)
       
   lemma leof_option_rule[refine_vcg]: 
   "\<lbrakk>v = None \<Longrightarrow> S1 \<le>\<^sub>n SPEC \<Phi>; \<And>x. v = Some x \<Longrightarrow> f2 x \<le>\<^sub>n SPEC \<Phi>\<rbrakk>
     \<Longrightarrow> (case v of None \<Rightarrow> S1 | Some x \<Rightarrow> f2 x) \<le>\<^sub>n SPEC \<Phi>"
     by (cases v) auto
 
   lemma ASSERT_leof_rule[refine_vcg]:
     assumes "\<Phi> \<Longrightarrow> m \<le>\<^sub>n m'"
     shows "do {ASSERT \<Phi>; m} \<le>\<^sub>n m'"
     using assms
     by (cases \<Phi>, auto simp: pw_leof_iff)
 
   lemma leof_ASSERT_rule[refine_vcg]: "\<lbrakk>\<Phi> \<Longrightarrow> m \<le>\<^sub>n m'\<rbrakk> \<Longrightarrow> m \<le>\<^sub>n ASSERT \<Phi> \<then> m'"  
     by (auto simp: pw_leof_iff refine_pw_simps)
 
   lemma leof_ASSERT_refine_rule[refine]: "\<lbrakk>\<Phi> \<Longrightarrow> m \<le>\<^sub>n \<Down>R m'\<rbrakk> \<Longrightarrow> m \<le>\<^sub>n \<Down>R (ASSERT \<Phi> \<then> m')"  
     by (auto simp: pw_leof_iff refine_pw_simps)
 
   lemma ASSUME_leof_iff: "(ASSUME \<Phi> \<le>\<^sub>n SPEC \<Psi>) \<longleftrightarrow> (\<Phi> \<longrightarrow> \<Psi> ())"  
     by (auto simp: pw_leof_iff)
 
   lemma ASSUME_leof_rule[refine_vcg]: 
     assumes "\<Phi> \<Longrightarrow> \<Psi> ()" 
     shows "ASSUME \<Phi> \<le>\<^sub>n SPEC \<Psi>"
     using assms
     by (auto simp: ASSUME_leof_iff)
       
       
   lemma SPEC_rule_conj_leofI1:
     assumes "m \<le> SPEC \<Phi>"
     assumes "m \<le>\<^sub>n SPEC \<Psi>"
     shows "m \<le> SPEC (\<lambda>s. \<Phi> s \<and> \<Psi> s)"
     using assms by (auto simp: pw_le_iff pw_leof_iff)
 
   lemma SPEC_rule_conj_leofI2:
     assumes "m \<le>\<^sub>n SPEC \<Phi>"
     assumes "m \<le> SPEC \<Psi>"
     shows "m \<le> SPEC (\<lambda>s. \<Phi> s \<and> \<Psi> s)"
     using assms by (auto simp: pw_le_iff pw_leof_iff)
 
   lemma SPEC_rule_leof_conjI: 
     assumes "m \<le>\<^sub>n SPEC \<Phi>" "m \<le>\<^sub>n SPEC \<Psi>"
     shows "m \<le>\<^sub>n SPEC (\<lambda>x. \<Phi> x \<and> \<Psi> x)"
     using assms by (auto simp: pw_leof_iff)
 
   lemma leof_use_spec_rule:
     assumes "m \<le>\<^sub>n SPEC \<Psi>"
     assumes "m \<le>\<^sub>n SPEC (\<lambda>s. \<Psi> s \<longrightarrow> \<Phi> s)"
     shows "m \<le>\<^sub>n SPEC \<Phi>"
     using assms by (auto simp: pw_leof_iff refine_pw_simps)
   
   lemma use_spec_leof_rule:
     assumes "m \<le>\<^sub>n SPEC \<Psi>"
     assumes "m \<le> SPEC (\<lambda>s. \<Psi> s \<longrightarrow> \<Phi> s)"
     shows "m \<le> SPEC \<Phi>"
     using assms by (auto simp: pw_leof_iff pw_le_iff refine_pw_simps)
 
   lemma leof_strengthen_SPEC: 
     "m \<le>\<^sub>n SPEC \<Phi> \<Longrightarrow> m \<le>\<^sub>n SPEC (\<lambda>x. inres m x \<and> \<Phi> x)"
     by (auto simp: pw_leof_iff)
 
   lemma build_rel_SPEC_leof: 
     assumes "m \<le>\<^sub>n SPEC (\<lambda>x. I x \<and> \<Phi> (\<alpha> x))"  
     shows "m \<le>\<^sub>n \<Down>(br \<alpha> I) (SPEC \<Phi>)"
     using assms by (auto simp: build_rel_SPEC_conv)
       
   lemma RETURN_as_SPEC_refine_leof[refine2]:
     assumes "M \<le>\<^sub>n SPEC (\<lambda>c. (c,a)\<in>R)"
     shows "M \<le>\<^sub>n \<Down>R (RETURN a)"
     using assms
     by (simp add: pw_leof_iff refine_pw_simps)
 
   lemma ASSERT_leof_defI:
     assumes "c \<equiv> do { ASSERT \<Phi>; m'}"
     assumes "\<Phi> \<Longrightarrow> m' \<le>\<^sub>n m"
     shows "c \<le>\<^sub>n m"
     using assms by (auto simp: pw_leof_iff refine_pw_simps)
   
   lemma leof_fun_conv_le: 
     "(f x \<le>\<^sub>n M x) \<longleftrightarrow> (f x \<le> (if nofail (f x) then M x else FAIL))"
     by (auto simp: pw_le_iff pw_leof_iff)
     
   lemma leof_add_nofailI: "\<lbrakk> nofail m \<Longrightarrow> m\<le>\<^sub>nm' \<rbrakk> \<Longrightarrow> m\<le>\<^sub>nm'"
     by (auto simp: pw_le_iff pw_leof_iff)
 
   lemma leof_cons_rule[refine_vcg_cons]: 
     assumes "m \<le>\<^sub>n SPEC Q"
     assumes "\<And>x. Q x \<Longrightarrow> P x"  
     shows "m \<le>\<^sub>n SPEC P"
     using assms  
     by (auto simp: pw_le_iff pw_leof_iff)
       
       
 lemma RECT_rule_leof:
   assumes WF: "wf (V::('x\<times>'x) set)"
   assumes I0: "pre (x::'x)"
   assumes IS: "\<And>f x. \<lbrakk> \<And>x'. \<lbrakk>pre x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le>\<^sub>n M x'; pre x; 
                         RECT body = f
     \<rbrakk> \<Longrightarrow> body f x \<le>\<^sub>n M x"
   shows "RECT body x \<le>\<^sub>n M x"
     apply (cases "\<not>trimono body")
     apply (simp add: RECT_def)
     using assms
     unfolding leof_fun_conv_le
     apply -
     apply (rule RECT_rule[where pre=pre and V=V])
-    apply clarsimp_all
+       apply clarsimp_all
 proof -
   fix xa :: 'x
   assume a1: "\<And>x'. \<lbrakk>pre x'; (x', xa) \<in> V\<rbrakk> \<Longrightarrow> REC\<^sub>T body x' \<le> (if nofail (REC\<^sub>T body x') then M x' else FAIL)"
   assume a2: "\<And>x f. \<lbrakk>\<And>x'. \<lbrakk>pre x'; (x', x) \<in> V\<rbrakk> \<Longrightarrow> f x' \<le> (if nofail (f x') then M x' else FAIL); pre x; REC\<^sub>T body = f\<rbrakk> \<Longrightarrow> body f x \<le> (if nofail (body f x) then M x else FAIL)"
   assume a3: "pre xa"
   assume a4: "nofail (REC\<^sub>T body xa)"
   assume a5: "trimono body"
   have f6: "\<forall>x. \<not> pre x \<or> (x, xa) \<notin> V \<or> (if nofail (REC\<^sub>T body x) then REC\<^sub>T body x \<le> M x else REC\<^sub>T body x \<le> FAIL)"
     using a1 by presburger
   have f7: "\<forall>x f. ((\<exists>xa. (pre xa \<and> (xa, x) \<in> V) \<and> \<not> f xa \<le> (if nofail (f xa) then M xa else FAIL)) \<or> \<not> pre x \<or> REC\<^sub>T body \<noteq> f) \<or> body f x \<le> (if nofail (body f x) then M x else FAIL)"
     using a2 by blast
   obtain xx :: "('x \<Rightarrow> 'a nres) \<Rightarrow> 'x \<Rightarrow> 'x" where
     f8: "\<forall>x0 x1. (\<exists>v2. (pre v2 \<and> (v2, x1) \<in> V) \<and> \<not> x0 v2 \<le> (if nofail (x0 v2) then M v2 else FAIL)) = ((pre (xx x0 x1) \<and> (xx x0 x1, x1) \<in> V) \<and> \<not> x0 (xx x0 x1) \<le> (if nofail (x0 (xx x0 x1)) then M (xx x0 x1) else FAIL))"
     by moura
   have f9: "\<forall>x0 x1. (x0 (xx x0 x1) \<le> (if nofail (x0 (xx x0 x1)) then M (xx x0 x1) else FAIL)) = (if nofail (x0 (xx x0 x1)) then x0 (xx x0 x1) \<le> M (xx x0 x1) else x0 (xx x0 x1) \<le> FAIL)"
     by presburger
   have "nofail (body (REC\<^sub>T body) xa)"
     using a5 a4 by (metis (no_types) RECT_unfold)
   then show "body (REC\<^sub>T body) xa \<le> M xa"
     using f9 f8 f7 f6 a3 by fastforce
 qed  
 
 (* TODO: REC_rule_leof! (However, this may require some fix 
      to the domain theory model of Refine_Monadic!) *)
       
       
 
 end
 
 
diff --git a/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy b/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
--- a/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
+++ b/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
@@ -1,3608 +1,3608 @@
 (* Title:      Subset Boolean Algebras
    Authors:    Walter Guttmann, Bernhard Möller
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 theory Subset_Boolean_Algebras
 
 imports Stone_Algebras.P_Algebras
 
 begin
 
 section \<open>Boolean Algebras\<close>
 
 text \<open>
 We show that Isabelle/HOL's \<open>boolean_algebra\<close> class is equivalent to Huntington's axioms \<^cite>\<open>"Huntington1933"\<close>.
 See \<^cite>\<open>"WamplerDoty2016"\<close> for related results.
 \<close>
 
 subsection \<open>Huntington's Axioms\<close>
 
 text \<open>Definition 1\<close>
 
 class huntington = sup + uminus +
   assumes associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes commutative: "x \<squnion> y = y \<squnion> x"
   assumes huntington: "x = -(-x \<squnion> y) \<squnion> -(-x \<squnion> -y)"
 begin
 
 lemma top_unique:
   "x \<squnion> -x = y \<squnion> -y"
 proof -
   have "x \<squnion> -x = y \<squnion> -(--y \<squnion> -x) \<squnion> -(--y \<squnion> --x)"
     by (smt associative commutative huntington)
   thus ?thesis
     by (metis associative huntington)
 qed
 
 end
 
 subsection \<open>Equivalence to \<open>boolean_algebra\<close> Class\<close>
 
 text \<open>Definition 2\<close>
 
 class extended = sup + inf + minus + uminus + bot + top + ord +
   assumes top_def: "top = (THE x . \<forall>y . x = y \<squnion> -y)" (* define without imposing uniqueness *)
   assumes bot_def: "bot = -(THE x . \<forall>y . x = y \<squnion> -y)"
   assumes inf_def: "x \<sqinter> y = -(-x \<squnion> -y)"
   assumes minus_def: "x - y = -(-x \<squnion> y)"
   assumes less_eq_def: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
   assumes less_def: "x < y \<longleftrightarrow> x \<squnion> y = y \<and> \<not> (y \<squnion> x = x)"
 
 class huntington_extended = huntington + extended
 begin
 
 lemma top_char:
   "top = x \<squnion> -x"
   using top_def top_unique by auto
 
 lemma bot_char:
   "bot = -top"
   by (simp add: bot_def top_def)
 
 subclass boolean_algebra
 proof
   show 1: "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_def less_eq_def)
   show 2: "\<And>x. x \<le> x"
   proof -
     fix x
     have "x \<squnion> top = top \<squnion> --x"
       by (metis (full_types) associative top_char)
     thus "x \<le> x"
       by (metis (no_types) associative huntington less_eq_def top_char)
   qed
   show 3: "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
     by (metis associative less_eq_def)
   show 4: "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     by (simp add: commutative less_eq_def)
   show 5: "\<And>x y. x \<sqinter> y \<le> x"
     using 2 by (metis associative huntington inf_def less_eq_def)
   show 6: "\<And>x y. x \<sqinter> y \<le> y"
     using 5 commutative inf_def by fastforce
   show 8: "\<And>x y. x \<le> x \<squnion> y"
     using 2 associative less_eq_def by auto
   show 9: "\<And>y x. y \<le> x \<squnion> y"
     using 8 commutative by fastforce
   show 10: "\<And>y x z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
     by (metis associative less_eq_def)
   show 11: "\<And>x. bot \<le> x"
     using 8 by (metis bot_char huntington top_char)
   show 12: "\<And>x. x \<le> top"
     using 6 11 by (metis huntington bot_def inf_def less_eq_def top_def)
   show 13: "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
   proof -
     have 2: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
       by (simp add: associative)
     have 3: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
       using 2 by metis
     have 4: "\<And>x y . x \<squnion> y = y \<squnion> x"
       by (simp add: commutative)
     have 5: "\<And>x y . x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
       by (simp add: huntington)
     have 6: "\<And>x y . - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y) = x"
       using 5 by metis
     have 7: "\<And>x y . x \<sqinter> y = - (- x \<squnion> - y)"
       by (simp add: inf_def)
     have 10: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
       using 3 4 by metis
     have 11: "\<And>x y z . - (- x \<squnion> y) \<squnion> (- (- x \<squnion> - y) \<squnion> z) = x \<squnion> z"
       using 3 6 by metis
     have 12: "\<And>x y . - (x \<squnion> - y) \<squnion> - (- y \<squnion> - x) = y"
       using 4 6 by metis
     have 13: "\<And>x y . - (- x \<squnion> y) \<squnion> - (- y \<squnion> - x) = x"
       using 4 6 by metis
     have 14: "\<And>x y . - x \<squnion> - (- (- x \<squnion> y) \<squnion> - - (- x \<squnion> - y)) = - x \<squnion> y"
       using 6 by metis
     have 18: "\<And>x y z . - (x \<squnion> - y) \<squnion> (- (- y \<squnion> - x) \<squnion> z) = y \<squnion> z"
       using 3 12 by metis
     have 20: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> - x) = x"
       using 4 12 by metis
     have 21: "\<And>x y . - (x \<squnion> - y) \<squnion> - (- x \<squnion> - y) = y"
       using 4 12 by metis
     have 22: "\<And>x y . - x \<squnion> - (- (y \<squnion> - x) \<squnion> - - (- x \<squnion> - y)) = y \<squnion> - x"
       using 6 12 by metis
     have 23: "\<And>x y . - x \<squnion> - (- x \<squnion> (- y \<squnion> - (y \<squnion> - x))) = y \<squnion> - x"
       using 3 4 6 12 by metis
     have 24: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y)) = - x \<squnion> - y"
       using 6 12 by metis
     have 28: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (- y \<squnion> x) = y"
       using 4 13 by metis
     have 30: "\<And>x y . - x \<squnion> - (- y \<squnion> (- x \<squnion> - (- x \<squnion> y))) = - x \<squnion> y"
       using 3 4 6 13 by metis
     have 32: "\<And>x y z . - (- x \<squnion> y) \<squnion> (z \<squnion> - (- y \<squnion> - x)) = z \<squnion> x"
       using 10 13 by metis
     have 37: "\<And>x y z . - (- x \<squnion> - y) \<squnion> (- (y \<squnion> - x) \<squnion> z) = x \<squnion> z"
       using 3 20 by metis
     have 39: "\<And>x y z . - (- x \<squnion> - y) \<squnion> (z \<squnion> - (y \<squnion> - x)) = z \<squnion> x"
       using 10 20 by metis
     have 40: "\<And>x y z . - (x \<squnion> - y) \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> z"
       using 3 21 by metis
     have 43: "\<And>x y . - x \<squnion> - (- y \<squnion> (- x \<squnion> - (y \<squnion> - x))) = y \<squnion> - x"
       using 3 4 6 21 by metis
     have 47: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- (- x \<squnion> z) \<squnion> - (- (- x \<squnion> - z) \<squnion> y)) = - x \<squnion> z"
       using 6 11 by metis
     have 55: "\<And>x y . x \<squnion> - (- y \<squnion> - - x) = y \<squnion> - (- x \<squnion> y)"
       using 4 11 12 by metis
     have 58: "\<And>x y . x \<squnion> - (- - y \<squnion> - x) = x \<squnion> - (- x \<squnion> y)"
       using 4 11 13 by metis
     have 63: "\<And>x y . x \<squnion> - (- - x \<squnion> - y) = y \<squnion> - (- x \<squnion> y)"
       using 4 11 21 by metis
     have 71: "\<And>x y . x \<squnion> - (- y \<squnion> x) = y \<squnion> - (- x \<squnion> y)"
       using 4 11 28 by metis
     have 75: "\<And>x y . x \<squnion> - (- y \<squnion> x) = y \<squnion> - (y \<squnion> - x)"
       using 4 71 by metis
     have 78: "\<And>x y . - x \<squnion> (y \<squnion> - (- x \<squnion> (y \<squnion> - - (- x \<squnion> - y)))) = - x \<squnion> - (- x \<squnion> - y)"
       using 3 4 6 71 by metis
     have 86: "\<And>x y . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> - (y \<squnion> - (- x \<squnion> y)) = - y \<squnion> x"
       using 4 20 71 by metis
     have 172: "\<And>x y . - x \<squnion> - (- x \<squnion> - y) = y \<squnion> - (- - x \<squnion> y)"
       using 14 75 by metis
     have 201: "\<And>x y . x \<squnion> - (- y \<squnion> - - x) = y \<squnion> - (y \<squnion> - x)"
       using 4 55 by metis
     have 236: "\<And>x y . x \<squnion> - (- - y \<squnion> - x) = x \<squnion> - (y \<squnion> - x)"
       using 4 58 by metis
     have 266: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> - - (- - x \<squnion> y))) = - x \<squnion> - (- - x \<squnion> y)"
       using 14 58 236 by metis
     have 678: "\<And>x y z . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> (- (y \<squnion> - (- x \<squnion> y)) \<squnion> z) = - y \<squnion> (x \<squnion> z)"
       using 3 4 37 71 by smt
     have 745: "\<And>x y z . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> (z \<squnion> - (y \<squnion> - (- x \<squnion> y))) = z \<squnion> (- y \<squnion> x)"
       using 4 39 71 by metis
     have 800: "\<And>x y . - - x \<squnion> (- y \<squnion> (- (y \<squnion> - - x) \<squnion> - (- x \<squnion> (- - x \<squnion> (- y \<squnion> - (y \<squnion> - - x)))))) = x \<squnion> - (y \<squnion> - - x)"
       using 3 23 63 by metis
     have 944: "\<And>x y . x \<squnion> - (x \<squnion> - - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y))) = - (- x \<squnion> - y) \<squnion> - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y))"
       using 4 24 71 by metis
     have 948: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- y \<squnion> - x))) = - x \<squnion> - (- y \<squnion> - x)"
       using 24 75 by metis
     have 950: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (- - x \<squnion> y)) \<squnion> - - (- x \<squnion> (- x \<squnion> - y))) = - x \<squnion> - (- x \<squnion> - y)"
       using 24 75 by metis
     have 961: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (- - x \<squnion> y)) \<squnion> - - (- x \<squnion> (- - - x \<squnion> - y))) = y \<squnion> - (- - x \<squnion> y)"
       using 24 63 by metis
     have 966: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- y \<squnion> - - - x))) = y \<squnion> - (y \<squnion> - - x)"
       using 24 201 by metis
     have 969: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- - y \<squnion> - - x))) = - x \<squnion> - (y \<squnion> - - x)"
       using 24 236 by metis
     have 1096: "\<And>x y z . - x \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> (- (- - x \<squnion> y) \<squnion> z)"
       using 3 172 by metis
     have 1098: "\<And>x y z . - x \<squnion> (y \<squnion> - (- x \<squnion> - z)) = y \<squnion> (z \<squnion> - (- - x \<squnion> z))"
       using 10 172 by metis
     have 1105: "\<And>x y . x \<squnion> - x = y \<squnion> - y"
       using 4 10 12 32 172 by metis
     have 1109: "\<And>x y z . x \<squnion> (- x \<squnion> y) = z \<squnion> (- z \<squnion> y)"
       using 3 1105 by metis
     have 1110: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - (y \<squnion> z))"
       using 3 1105 by metis
     have 1114: "\<And>x y . - (- x \<squnion> - - x) = - (y \<squnion> - y)"
       using 7 1105 by metis
     have 1115: "\<And>x y z . x \<squnion> (y \<squnion> - y) = z \<squnion> (x \<squnion> - z)"
       using 10 1105 by metis
     have 1117: "\<And>x y . - (x \<squnion> - - x) \<squnion> - (y \<squnion> - y) = - x"
       using 4 13 1105 by metis
     have 1121: "\<And>x y . - (x \<squnion> - x) \<squnion> - (y \<squnion> - - y) = - y"
       using 4 28 1105 by metis
     have 1122: "\<And>x . - - x = x"
       using 4 28 1105 1117 by metis
     have 1134: "\<And>x y z . - (x \<squnion> - y) \<squnion> (z \<squnion> - z) = y \<squnion> (- y \<squnion> - x)"
       using 18 1105 1122 by metis
     have 1140: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> - x)) = - x \<squnion> - x"
       using 4 22 1105 1122 1134 by metis
     have 1143: "\<And>x y . x \<squnion> (- x \<squnion> y) = y \<squnion> (x \<squnion> - y)"
       using 37 1105 1122 1134 by metis
     have 1155: "\<And>x y . - (x \<squnion> - x) \<squnion> - (y \<squnion> y) = - y"
       using 1121 1122 by metis
     have 1156: "\<And>x y . - (x \<squnion> x) \<squnion> - (y \<squnion> - y) = - x"
       using 1117 1122 by metis
     have 1157: "\<And>x y . - (x \<squnion> - x) = - (y \<squnion> - y)"
       using 4 1114 1122 by metis
     have 1167: "\<And>x y z . - x \<squnion> (y \<squnion> - (- x \<squnion> - z)) = y \<squnion> (z \<squnion> - (x \<squnion> z))"
       using 1098 1122 by metis
     have 1169: "\<And>x y z . - x \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> (- (x \<squnion> y) \<squnion> z)"
       using 1096 1122 by metis
     have 1227: "\<And>x y . - x \<squnion> - (- x \<squnion> (y \<squnion> (x \<squnion> - (- x \<squnion> - (y \<squnion> x))))) = - x \<squnion> - (y \<squnion> x)"
       using 3 4 969 1122 by smt
     have 1230: "\<And>x y . - x \<squnion> - (- x \<squnion> (- y \<squnion> (- x \<squnion> - (y \<squnion> - (y \<squnion> x))))) = y \<squnion> - (y \<squnion> x)"
       using 3 4 966 1122 by smt
     have 1234: "\<And>x y . - x \<squnion> - (- x \<squnion> (- x \<squnion> (- y \<squnion> - (y \<squnion> - (x \<squnion> y))))) = y \<squnion> - (x \<squnion> y)"
       using 3 4 961 1122 by metis
     have 1239: "\<And>x y . - x \<squnion> - (- x \<squnion> - y) = y \<squnion> - (x \<squnion> y)"
       using 3 4 950 1122 1234 by metis
     have 1240: "\<And>x y . - x \<squnion> - (- y \<squnion> - x) = y \<squnion> - (y \<squnion> x)"
       using 3 4 948 1122 1230 by metis
     have 1244: "\<And>x y . x \<squnion> - (x \<squnion> (y \<squnion> (y \<squnion> - (x \<squnion> y)))) = - (- x \<squnion> - y) \<squnion> - (y \<squnion> (y \<squnion> - (x \<squnion> y)))"
       using 3 4 944 1122 1167 by metis
     have 1275: "\<And>x y . x \<squnion> (- y \<squnion> (- (y \<squnion> x) \<squnion> - (x \<squnion> (- x \<squnion> (- y \<squnion> - (y \<squnion> x)))))) = x \<squnion> - (y \<squnion> x)"
       using 10 800 1122 by metis
     have 1346: "\<And>x y . - x \<squnion> - (x \<squnion> (y \<squnion> (y \<squnion> (x \<squnion> - (x \<squnion> (y \<squnion> x)))))) = - x \<squnion> - (x \<squnion> y)"
       using 3 4 10 266 1122 1167 by smt
     have 1377: "\<And>x y . - x \<squnion> (y \<squnion> - (- x \<squnion> (y \<squnion> (- x \<squnion> - y)))) = y \<squnion> - (x \<squnion> y)"
       using 78 1122 1239 by metis
     have 1394: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> (y \<squnion> (- x \<squnion> - (x \<squnion> y)))) = x"
       using 3 4 10 20 30 1122 1239 by smt
     have 1427: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> - (x \<squnion> (x \<squnion> - (x \<squnion> y)))) = x \<squnion> (x \<squnion> - (x \<squnion> y))"
       using 3 4 30 40 1240 by smt
     have 1436: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> (- x \<squnion> - x))) = - x \<squnion> (- x \<squnion> - (x \<squnion> - x))"
       using 3 4 30 1140 1239 by smt
     have 1437: "\<And>x y . - (x \<squnion> y) \<squnion> - (x \<squnion> - y) = - x"
       using 6 1122 by metis
     have 1438: "\<And>x y . - (x \<squnion> y) \<squnion> - (y \<squnion> - x) = - y"
       using 12 1122 by metis
     have 1439: "\<And>x y . - (x \<squnion> y) \<squnion> - (- y \<squnion> x) = - x"
       using 13 1122 by metis
     have 1440: "\<And>x y . - (x \<squnion> - y) \<squnion> - (y \<squnion> x) = - x"
       using 20 1122 by metis
     have 1441: "\<And>x y . - (x \<squnion> y) \<squnion> - (- x \<squnion> y) = - y"
       using 21 1122 by metis
     have 1568: "\<And>x y . x \<squnion> (- y \<squnion> - x) = y \<squnion> (- y \<squnion> x)"
       using 10 1122 1143 by metis
     have 1598: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> (x \<squnion> - x))) = - x \<squnion> (- x \<squnion> - (x \<squnion> - x))"
       using 4 1436 1568 by metis
     have 1599: "\<And>x y . - x \<squnion> (y \<squnion> - (x \<squnion> (- x \<squnion> (- x \<squnion> y)))) = y \<squnion> - (x \<squnion> y)"
       using 10 1377 1568 by smt
     have 1617: "\<And>x . x \<squnion> (- x \<squnion> (- x \<squnion> - (x \<squnion> - x))) = x \<squnion> - x"
       using 3 4 10 71 1122 1155 1568 1598 by metis
     have 1632: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (z \<squnion> - z) \<squnion> - (y \<squnion> - (x \<squnion> - x)))) = y \<squnion> - (x \<squnion> - x)"
       using 43 1157 by metis
     have 1633: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (x \<squnion> - x) \<squnion> - (y \<squnion> - (z \<squnion> - z)))) = y \<squnion> - (x \<squnion> - x)"
       using 43 1157 by metis
     have 1636: "\<And>x y . x \<squnion> - (y \<squnion> (- y \<squnion> - (x \<squnion> x))) = x \<squnion> x"
       using 43 1109 1122 by metis
     have 1645: "\<And>x y . x \<squnion> - x = y \<squnion> (y \<squnion> - y)"
       using 3 1110 1156 by metis
     have 1648: "\<And>x y z . - (x \<squnion> (y \<squnion> (- y \<squnion> - x))) \<squnion> - (z \<squnion> - z) = - (y \<squnion> - y)"
       using 3 1115 1156 by metis
     have 1657: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - z)"
       using 1105 1645 by metis
     have 1664: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - y)"
       using 1115 1645 by metis
     have 1672: "\<And>x y z . x \<squnion> - x = y \<squnion> (- y \<squnion> z)"
       using 3 4 1657 by metis
     have 1697: "\<And>x y z . - x \<squnion> (y \<squnion> x) = z \<squnion> - z"
       using 1122 1664 by metis
     have 1733: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- (z \<squnion> - z) \<squnion> - (- (- x \<squnion> - x) \<squnion> y)) = x \<squnion> - x"
       using 4 47 1105 1122 by metis
     have 1791: "\<And>x y z . x \<squnion> - (y \<squnion> (- y \<squnion> z)) = x \<squnion> - (x \<squnion> - x)"
       using 4 71 1122 1672 by metis
     have 1818: "\<And>x y z . x \<squnion> - (- y \<squnion> (z \<squnion> y)) = x \<squnion> - (x \<squnion> - x)"
       using 4 71 1122 1697 by metis
     have 1861: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (y \<squnion> - (z \<squnion> - z)) = - y"
       using 1437 1657 by metis
     have 1867: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> - (z \<squnion> y)) = y"
       using 1122 1437 1697 by metis
     have 1868: "\<And>x y . x \<squnion> - (y \<squnion> - y) = x"
       using 1122 1155 1633 1861 by metis
     have 1869: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (z \<squnion> - z) \<squnion> - y)) = y"
       using 1632 1868 by metis
     have 1870: "\<And>x y . - (x \<squnion> - x) \<squnion> - y = - y"
       using 1861 1868 by metis
     have 1872: "\<And>x y z . x \<squnion> - (- y \<squnion> (z \<squnion> y)) = x"
       using 1818 1868 by metis
     have 1875: "\<And>x y z . x \<squnion> - (y \<squnion> (- y \<squnion> z)) = x"
       using 1791 1868 by metis
     have 1883: "\<And>x y . - (x \<squnion> (y \<squnion> (- y \<squnion> - x))) = - (y \<squnion> - y)"
       using 1648 1868 by metis
     have 1885: "\<And>x . x \<squnion> (x \<squnion> - x) = x \<squnion> - x"
       using 4 1568 1617 1868 by metis
     have 1886: "\<And>x . - x \<squnion> - x = - x"
       using 1598 1868 1885 by metis
     have 1890: "\<And>x . - (x \<squnion> x) = - x"
       using 1156 1868 by metis
     have 1892: "\<And>x y . - (x \<squnion> - x) \<squnion> y = y"
       using 1122 1869 1870 1886 by metis
     have 1893: "\<And>x y . - (- x \<squnion> - (y \<squnion> x)) = x"
       using 1867 1892 by metis
     have 1902: "\<And>x y . x \<squnion> (y \<squnion> - (x \<squnion> y)) = x \<squnion> - x"
       using 3 4 1122 1733 1886 1892 by metis
     have 1908: "\<And>x . x \<squnion> x = x"
       using 1636 1875 1890 by metis
     have 1910: "\<And>x y . x \<squnion> - (y \<squnion> x) = - y \<squnion> x"
       using 1599 1875 by metis
     have 1921: "\<And>x y . x \<squnion> (- y \<squnion> - (y \<squnion> x)) = - y \<squnion> x"
       using 1275 1875 1910 by metis
     have 1951: "\<And>x y . - x \<squnion> - (y \<squnion> x) = - x"
       using 1227 1872 1893 1908 by metis
     have 1954: "\<And>x y z . x \<squnion> (y \<squnion> - (x \<squnion> z)) = y \<squnion> (- z \<squnion> x)"
       using 745 1122 1910 1951 by metis
     have 1956: "\<And>x y z . x \<squnion> (- (x \<squnion> y) \<squnion> z) = - y \<squnion> (x \<squnion> z)"
       using 678 1122 1910 1951 by metis
     have 1959: "\<And>x y . x \<squnion> - (x \<squnion> y) = - y \<squnion> x"
       using 86 1122 1910 1951 by metis
     have 1972: "\<And>x y . x \<squnion> (- x \<squnion> y) = x \<squnion> - x"
       using 1902 1910 by metis
     have 2000: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> (- x \<squnion> y)) = x \<squnion> - (y \<squnion> (- x \<squnion> y))"
       using 4 1244 1910 1959 by metis
     have 2054: "\<And>x y . x \<squnion> - (y \<squnion> (- x \<squnion> y)) = x"
       using 1394 1921 2000 by metis
     have 2057: "\<And>x y . - (x \<squnion> (y \<squnion> - y)) = - (y \<squnion> - y)"
       using 1883 1972 by metis
     have 2061: "\<And>x y . x \<squnion> (- y \<squnion> x) = x \<squnion> - y"
       using 4 1122 1427 1910 1959 2054 by metis
     have 2090: "\<And>x y z . x \<squnion> (- (y \<squnion> x) \<squnion> z) = x \<squnion> (- y \<squnion> z)"
       using 1122 1169 1956 by metis
     have 2100: "\<And>x y . - x \<squnion> - (x \<squnion> y) = - x"
       using 4 1346 1868 1885 1910 1959 1972 2057 by metis
     have 2144: "\<And>x y . x \<squnion> - (y \<squnion> - x) = x"
       using 1122 1440 2000 2061 by metis
     have 2199: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
       using 3 1908 by metis
     have 2208: "\<And>x y z . x \<squnion> (- (y \<squnion> - x) \<squnion> z) = x \<squnion> z"
       using 3 2144 by metis
     have 2349: "\<And>x y z . - (x \<squnion> y) \<squnion> - (x \<squnion> (y \<squnion> z)) = - (x \<squnion> y)"
       using 3 2100 by metis
     have 2432: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<squnion> - (y \<squnion> (z \<squnion> - x)) = - (y \<squnion> z)"
       using 3 1438 by metis
     have 2530: "\<And>x y z . - (- (x \<squnion> y) \<squnion> z) = - (y \<squnion> (- x \<squnion> z)) \<squnion> - (- y \<squnion> z)"
       using 4 1122 1439 2090 2208 by smt
     have 3364: "\<And>x y z . - (- x \<squnion> y) \<squnion> (z \<squnion> - (x \<squnion> y)) = z \<squnion> - y"
       using 3 4 1122 1441 1910 1954 2199 by metis
     have 5763: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- x \<squnion> (y \<squnion> z)) = - (x \<squnion> y) \<squnion> - (y \<squnion> z)"
       using 4 2349 3364 by metis
     have 6113: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<squnion> - (z \<squnion> - x) = - (y \<squnion> z) \<squnion> - (z \<squnion> - x)"
       using 4 2432 3364 5763 by metis
     show "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
     proof -
       fix x y z
       have "- (y \<sqinter> z \<squnion> x) = - (- (- y \<squnion> z) \<squnion> - (- y \<squnion> - z) \<squnion> x) \<squnion> - (x \<squnion> - - z)"
         using 1437 2530 6113 by (smt commutative inf_def)
       thus "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
         using 12 1122 by (metis commutative inf_def)
     qed
   qed
   show 14: "\<And>x. x \<sqinter> - x = bot"
   proof -
     fix x
     have "(bot \<squnion> x) \<sqinter> (bot \<squnion> -x) = bot"
       using huntington bot_def inf_def by auto
     thus "x \<sqinter> -x = bot"
       using 11 less_eq_def by force
   qed
   show 15: "\<And>x. x \<squnion> - x = top"
     using 5 14 by (metis (no_types, lifting) huntington bot_def less_eq_def top_def)
   show 16: "\<And>x y. x - y = x \<sqinter> - y"
     using 15 by (metis commutative huntington inf_def minus_def)
   show 7: "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
     by (simp add: 13 less_eq_def)
 qed
 
 end
 
 context boolean_algebra
 begin
 
 sublocale ba_he: huntington_extended
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sup_assoc)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     by simp
   show "top = (THE x. \<forall>y. x = y \<squnion> - y)"
     by auto
   show "bot = - (THE x. \<forall>y. x = y \<squnion> - y)"
     by auto
   show "\<And>x y. x \<sqinter> y = - (- x \<squnion> - y)"
     by simp
   show "\<And>x y. x - y = - (- x \<squnion> y)"
     by (simp add: diff_eq)
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   show "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     using sup.strict_order_iff sup_commute by auto
 qed
 
 end
 
 subsection \<open>Stone Algebras\<close>
 
 text \<open>
 We relate Stone algebras to Boolean algebras.
 \<close>
 
 class stone_algebra_extended = stone_algebra + minus +
   assumes stone_minus_def[simp]: "x - y = x \<sqinter> -y"
 
 class regular_stone_algebra = stone_algebra_extended +
   assumes double_complement[simp]: "--x = x"
 begin
 
 subclass boolean_algebra
 proof
   show "\<And>x. x \<sqinter> - x = bot"
     by simp
   show "\<And>x. x \<squnion> - x = top"
     using regular_dense_top by fastforce
   show "\<And>x y. x - y = x \<sqinter> - y"
     by simp
 qed
 
 end
 
 context boolean_algebra
 begin
 
 sublocale ba_rsa: regular_stone_algebra
 proof
   show "\<And>x y. x - y = x \<sqinter> - y"
     by (simp add: diff_eq)
   show "\<And>x. - - x = x"
     by simp
 qed
 
 end
 
 section \<open>Alternative Axiomatisations of Boolean Algebras\<close>
 
 text \<open>
 We consider four axiomatisations of Boolean algebras based only on join and complement.
 The first three are from the literature and the fourth, a version using equational axioms, is new.
 The motivation for Byrne's and the new axiomatisation is that the axioms are easier to understand than Huntington's third axiom.
 We also include Meredith's axiomatisation.
 \<close>
 
 subsection \<open>Lee Byrne's Formulation A\<close>
 
 text \<open>
 The following axiomatisation is from \<^cite>\<open>\<open>Formulation A\<close> in "Byrne1946"\<close>; see also \<^cite>\<open>"Frink1941"\<close>.
 \<close>
 
 text \<open>Theorem 3\<close>
 
 class boolean_algebra_1 = sup + uminus +
   assumes ba1_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes ba1_commutative: "x \<squnion> y = y \<squnion> x"
   assumes ba1_complement: "x \<squnion> -y = z \<squnion> -z \<longleftrightarrow> x \<squnion> y = x"
 begin
 
 subclass huntington
 proof
   show 1: "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: ba1_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: ba1_commutative)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
   proof -
     have 2: "\<forall>x y. y \<squnion> (y \<squnion> x) = y \<squnion> x"
       using 1 by (metis ba1_complement)
     hence "\<forall>x. --x = x"
       by (smt ba1_associative ba1_commutative ba1_complement)
     hence "\<forall>x y. y \<squnion> -(y \<squnion> -x) = y \<squnion> x"
       by (smt ba1_associative ba1_commutative ba1_complement)
     thus "\<And>x y. x = -(-x \<squnion> y) \<squnion> -(-x \<squnion> - y)"
       using 2 by (smt ba1_commutative ba1_complement)
   qed
 qed
 
 end
 
 context huntington
 begin
 
 sublocale h_ba1: boolean_algebra_1
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: commutative)
   show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
   proof
     fix x y z
     have 1: "\<And>x y z. -(-x \<squnion> y) \<squnion> (-(-x \<squnion> -y) \<squnion> z) = x \<squnion> z"
       using associative huntington by force
     have 2: "\<And>x y. -(x \<squnion> -y) \<squnion> -(-y \<squnion> -x) = y"
       by (metis commutative huntington)
     show "x \<squnion> - y = z \<squnion> - z \<Longrightarrow> x \<squnion> y = x"
       by (metis 1 2 associative commutative top_unique)
     show "x \<squnion> y = x \<Longrightarrow> x \<squnion> - y = z \<squnion> - z"
       by (metis associative huntington commutative top_unique)
   qed
 qed
 
 end
 
 subsection \<open>Lee Byrne's Formulation B\<close>
 
 text \<open>
 The following axiomatisation is from \<^cite>\<open>\<open>Formulation B\<close> in "Byrne1946"\<close>.
 \<close>
 
 text \<open>Theorem 4\<close>
 
 class boolean_algebra_2 = sup + uminus +
   assumes ba2_associative_commutative: "(x \<squnion> y) \<squnion> z = (y \<squnion> z) \<squnion> x"
   assumes ba2_complement: "x \<squnion> -y = z \<squnion> -z \<longleftrightarrow> x \<squnion> y = x"
 begin
 
 subclass boolean_algebra_1
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (smt ba2_associative_commutative ba2_complement)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (metis ba2_associative_commutative ba2_complement)
   show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
     by (simp add: ba2_complement)
 qed
 
 end
 
 context boolean_algebra_1
 begin
 
 sublocale ba1_ba2: boolean_algebra_2
 proof
   show "\<And>x y z. x \<squnion> y \<squnion> z = y \<squnion> z \<squnion> x"
     using ba1_associative commutative by force
   show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
     by (simp add: ba1_complement)
 qed
 
 end
 
 subsection \<open>Meredith's Equational Axioms\<close>
 
 text \<open>
 The following axiomatisation is from \<^cite>\<open>\<open>page 221 (1) \{A,N\}\<close> in "MeredithPrior1968"\<close>.
 \<close>
 
 class boolean_algebra_mp = sup + uminus +
   assumes ba_mp_1: "-(-x \<squnion> y) \<squnion> x = x"
   assumes ba_mp_2: "-(-x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
 begin
 
 subclass huntington
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (metis ba_mp_1 ba_mp_2)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (metis ba_mp_1 ba_mp_2)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     by (metis ba_mp_1 ba_mp_2)
 qed
 
 end
 
 context huntington
 begin
 
 sublocale mp_h: boolean_algebra_mp
 proof
   show 1: "\<And>x y. - (- x \<squnion> y) \<squnion> x = x"
     by (metis h_ba1.ba1_associative h_ba1.ba1_complement huntington)
   show "\<And>x y z. - (- x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
   proof -
     fix x y z
     have "y = -(-x \<squnion> -y) \<squnion> y"
       using 1 h_ba1.ba1_commutative by auto
     thus "-(-x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
       by (metis h_ba1.ba1_associative h_ba1.ba1_commutative huntington)
   qed
 qed
 
 end
 
 subsection \<open>An Equational Axiomatisation based on Semilattices\<close>
 
 text \<open>
 The following version is an equational axiomatisation based on semilattices.
 We add the double complement rule and that \<open>top\<close> is unique.
 The final axiom \<open>ba3_export\<close> encodes the logical statement $P \vee Q = P \vee (\neg P \wedge Q)$.
 Its dual appears in \<^cite>\<open>"BalbesHorn1970"\<close>.
 \<close>
 
 text \<open>Theorem 5\<close>
 
 class boolean_algebra_3 = sup + uminus +
   assumes ba3_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes ba3_commutative: "x \<squnion> y = y \<squnion> x"
   assumes ba3_idempotent[simp]: "x \<squnion> x = x"
   assumes ba3_double_complement[simp]: "--x = x"
   assumes ba3_top_unique: "x \<squnion> -x = y \<squnion> -y"
   assumes ba3_export: "x \<squnion> -(x \<squnion> y) = x \<squnion> -y"
 begin
 
 subclass huntington
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: ba3_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: ba3_commutative)
   show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     by (metis ba3_commutative ba3_double_complement ba3_export ba3_idempotent ba3_top_unique)
 qed
 
 end
 
 context huntington
 begin
 
 sublocale h_ba3: boolean_algebra_3
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: h_ba1.ba1_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: h_ba1.ba1_commutative)
   show 3: "\<And>x. x \<squnion> x = x"
     using h_ba1.ba1_complement by blast
   show 4: "\<And>x. - - x = x"
     by (metis h_ba1.ba1_commutative huntington top_unique)
   show "\<And>x y. x \<squnion> - x = y \<squnion> - y"
     by (simp add: top_unique)
   show "\<And>x y. x \<squnion> - (x \<squnion> y) = x \<squnion> - y"
     using 3 4 by (smt h_ba1.ba1_ba2.ba2_associative_commutative h_ba1.ba1_complement)
 qed
 
 end
 
 section \<open>Subset Boolean Algebras\<close>
 
 text \<open>
 We apply Huntington's axioms to the range of a unary operation, which serves as complement on the range.
 This gives a Boolean algebra structure on the range without imposing any further constraints on the set.
 The obtained structure is used as a reference in the subsequent development and to inherit the results proved here.
 This is taken from \<^cite>\<open>"Guttmann2012c" and "GuttmannStruthWeber2011b"\<close> and follows the development of Boolean algebras in \<^cite>\<open>"Maddux1996"\<close>.
 \<close>
 
 text \<open>Definition 6\<close>
 
 class subset_boolean_algebra = sup + uminus +
   assumes sub_associative: "-x \<squnion> (-y \<squnion> -z) = (-x \<squnion> -y) \<squnion> -z"
   assumes sub_commutative: "-x \<squnion> -y = -y \<squnion> -x"
   assumes sub_complement: "-x = -(--x \<squnion> -y) \<squnion> -(--x \<squnion> --y)"
   assumes sub_sup_closed: "-x \<squnion> -y = --(-x \<squnion> -y)"
 begin
 
 text \<open>uniqueness of \<open>top\<close>, resulting in the lemma \<open>top_def\<close> to replace the assumption \<open>sub_top_def\<close>\<close>
 
 lemma top_unique:
   "-x \<squnion> --x = -y \<squnion> --y"
   by (metis sub_associative sub_commutative sub_complement)
 
 text \<open>consequences for join and complement\<close>
 
 lemma double_negation[simp]:
   "---x = -x"
   by (metis sub_complement sub_sup_closed)
 
 lemma complement_1:
   "--x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> --y)"
   by (metis double_negation sub_complement)
 
 lemma sup_right_zero_var:
   "-x \<squnion> (-y \<squnion> --y) = -z \<squnion> --z"
   by (smt complement_1 sub_associative sub_sup_closed top_unique)
 
 lemma sup_right_unit_idempotent:
   "-x \<squnion> -x = -x \<squnion> -(-y \<squnion> --y)"
   by (metis complement_1 double_negation sub_sup_closed sup_right_zero_var)
 
 lemma sup_idempotent[simp]:
   "-x \<squnion> -x = -x"
   by (smt complement_1 double_negation sub_associative sup_right_unit_idempotent)
 
 lemma complement_2:
   "-x = -(-(-x \<squnion> -y) \<squnion> -(-x \<squnion> --y))"
   using complement_1 by auto
 
 lemma sup_eq_cases:
   "-x \<squnion> -y = -x \<squnion> -z \<Longrightarrow> --x \<squnion> -y = --x \<squnion> -z \<Longrightarrow> -y = -z"
   by (metis complement_2 sub_commutative)
 
 lemma sup_eq_cases_2:
   "-y \<squnion> -x = -z \<squnion> -x \<Longrightarrow> -y \<squnion> --x = -z \<squnion> --x \<Longrightarrow> -y = -z"
   using sub_commutative sup_eq_cases by auto
 
 end
 
 text \<open>Definition 7\<close>
 
 class subset_extended = sup + inf + minus + uminus + bot + top + ord +
   assumes sub_top_def: "top = (THE x . \<forall>y . x = -y \<squnion> --y)" (* define without imposing uniqueness *)
   assumes sub_bot_def: "bot = -(THE x . \<forall>y . x = -y \<squnion> --y)"
   assumes sub_inf_def: "-x \<sqinter> -y = -(--x \<squnion> --y)"
   assumes sub_minus_def: "-x - -y = -(--x \<squnion> -y)"
   assumes sub_less_eq_def: "-x \<le> -y \<longleftrightarrow> -x \<squnion> -y = -y"
   assumes sub_less_def: "-x < -y \<longleftrightarrow> -x \<squnion> -y = -y \<and> \<not> (-y \<squnion> -x = -x)"
 
 class subset_boolean_algebra_extended = subset_boolean_algebra + subset_extended
 begin
 
 lemma top_def:
   "top = -x \<squnion> --x"
   using sub_top_def top_unique by blast
 
 text \<open>consequences for meet\<close>
 
 lemma inf_closed:
   "-x \<sqinter> -y = --(-x \<sqinter> -y)"
   by (simp add: sub_inf_def)
 
 lemma inf_associative:
   "-x \<sqinter> (-y \<sqinter> -z) = (-x \<sqinter> -y) \<sqinter> -z"
   using sub_associative sub_inf_def sub_sup_closed by auto
 
 lemma inf_commutative:
   "-x \<sqinter> -y = -y \<sqinter> -x"
   by (simp add: sub_commutative sub_inf_def)
 
 lemma inf_idempotent[simp]:
   "-x \<sqinter> -x = -x"
   by (simp add: sub_inf_def)
 
 lemma inf_absorb[simp]:
   "(-x \<squnion> -y) \<sqinter> -x = -x"
   by (metis complement_1 sup_idempotent sub_inf_def sub_associative sub_sup_closed)
 
 lemma sup_absorb[simp]:
   "-x \<squnion> (-x \<sqinter> -y) = -x"
   by (metis sub_associative sub_complement sub_inf_def sup_idempotent)
 
 lemma inf_demorgan:
   "-(-x \<sqinter> -y) = --x \<squnion> --y"
   using sub_inf_def sub_sup_closed by auto
 
 lemma sub_sup_demorgan:
   "-(-x \<squnion> -y) = --x \<sqinter> --y"
   by (simp add: sub_inf_def)
 
 lemma sup_cases:
   "-x = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> --y)"
   by (metis inf_closed inf_demorgan sub_complement)
 
 lemma inf_cases:
   "-x = (-x \<squnion> -y) \<sqinter> (-x \<squnion> --y)"
   by (metis complement_2 sub_sup_closed sub_sup_demorgan)
 
 lemma inf_complement_intro:
   "(-x \<squnion> -y) \<sqinter> --x = -y \<sqinter> --x"
 proof -
   have "(-x \<squnion> -y) \<sqinter> --x = (-x \<squnion> -y) \<sqinter> (--x \<squnion> -y) \<sqinter> --x"
     by (metis inf_absorb inf_associative sub_sup_closed)
   also have "... = -y \<sqinter> --x"
     by (metis inf_cases sub_commutative)
   finally show ?thesis
     .
 qed
 
 lemma sup_complement_intro:
   "-x \<squnion> -y = -x \<squnion> (--x \<sqinter> -y)"
   by (metis inf_absorb inf_commutative inf_complement_intro sub_sup_closed sup_cases)
 
 lemma inf_left_dist_sup:
   "-x \<sqinter> (-y \<squnion> -z) = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z)"
 proof -
   have "-x \<sqinter> (-y \<squnion> -z) = (-x \<sqinter> (-y \<squnion> -z) \<sqinter> -y) \<squnion> (-x \<sqinter> (-y \<squnion> -z) \<sqinter> --y)"
     by (metis sub_inf_def sub_sup_closed sup_cases)
   also have "... = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z \<sqinter> --y)"
     by (metis inf_absorb inf_associative inf_complement_intro sub_sup_closed)
   also have "... = (-x \<sqinter> -y) \<squnion> ((-x \<sqinter> -y \<sqinter> -z) \<squnion> (-x \<sqinter> -z \<sqinter> --y))"
     using sub_associative sub_inf_def sup_absorb by auto
   also have "... = (-x \<sqinter> -y) \<squnion> ((-x \<sqinter> -z \<sqinter> -y) \<squnion> (-x \<sqinter> -z \<sqinter> --y))"
     by (metis inf_associative inf_commutative)
   also have "... = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z)"
     by (metis sub_inf_def sup_cases)
   finally show ?thesis
     .
 qed
 
 lemma sup_left_dist_inf:
   "-x \<squnion> (-y \<sqinter> -z) = (-x \<squnion> -y) \<sqinter> (-x \<squnion> -z)"
 proof -
   have "-x \<squnion> (-y \<sqinter> -z) = -(--x \<sqinter> (--y \<squnion> --z))"
     by (metis sub_inf_def sub_sup_closed sub_sup_demorgan)
   also have "... = (-x \<squnion> -y) \<sqinter> (-x \<squnion> -z)"
     by (metis inf_left_dist_sup sub_sup_closed sub_sup_demorgan)
   finally show ?thesis
     .
 qed
 
 lemma sup_right_dist_inf:
   "(-y \<sqinter> -z) \<squnion> -x = (-y \<squnion> -x) \<sqinter> (-z \<squnion> -x)"
   using sub_commutative sub_inf_def sup_left_dist_inf by auto
 
 lemma inf_right_dist_sup:
   "(-y \<squnion> -z) \<sqinter> -x = (-y \<sqinter> -x) \<squnion> (-z \<sqinter> -x)"
   by (metis inf_commutative inf_left_dist_sup sub_sup_closed)
 
 lemma case_duality:
   "(--x \<sqinter> -y) \<squnion> (-x \<sqinter> -z) = (-x \<squnion> -y) \<sqinter> (--x \<squnion> -z)"
 proof -
   have 1: "-(--x \<sqinter> --y) \<sqinter> ----x = --x \<sqinter> -y"
     using inf_commutative inf_complement_intro sub_sup_closed sub_sup_demorgan by auto
   have 2: "-(----x \<squnion> -(--x \<squnion> -z)) = -----x \<sqinter> ---z"
     by (metis (no_types) double_negation sup_complement_intro sub_sup_demorgan)
   have 3: "-(--x \<sqinter> --y) \<sqinter> -x = -x"
     using inf_commutative inf_left_dist_sup sub_sup_closed sub_sup_demorgan by auto
   hence "-(--x \<sqinter> --y) = -x \<squnion> -y"
     using sub_sup_closed sub_sup_demorgan by auto
   thus ?thesis
     by (metis double_negation 1 2 3 inf_associative inf_left_dist_sup sup_complement_intro)
 qed
 
 lemma case_duality_2:
   "(-x \<sqinter> -y) \<squnion> (--x \<sqinter> -z) = (-x \<squnion> -z) \<sqinter> (--x \<squnion> -y)"
   using case_duality sub_commutative sub_inf_def by auto
 
 lemma complement_cases:
   "((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> -((-v \<sqinter> -y) \<squnion> (--v \<sqinter> -z)) = (-v \<sqinter> -w \<sqinter> --y) \<squnion> (--v \<sqinter> -x \<sqinter> --z)"
 proof -
   have 1: "(--v \<squnion> -w) = --(--v \<squnion> -w) \<and> (-v \<squnion> -x) = --(-v \<squnion> -x) \<and> (--v \<squnion> --y) = --(--v \<squnion> --y) \<and> (-v \<squnion> --z) = --(-v \<squnion> --z)"
     using sub_inf_def sub_sup_closed by auto
   have 2: "(-v \<squnion> (-x \<sqinter> --z)) = --(-v \<squnion> (-x \<sqinter> --z))"
     using sub_inf_def sub_sup_closed by auto
   have "((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> -((-v \<sqinter> -y) \<squnion> (--v \<sqinter> -z)) = ((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> (-(-v \<sqinter> -y) \<sqinter> -(--v \<sqinter> -z))"
     using sub_inf_def by auto
   also have "... = ((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
     using inf_demorgan by auto
   also have "... = (--v \<squnion> -w) \<sqinter> (-v \<squnion> -x) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
     by (metis case_duality double_negation)
   also have "... = (--v \<squnion> -w) \<sqinter> ((-v \<squnion> -x) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z)))"
     by (metis 1 inf_associative sub_inf_def)
   also have "... = (--v \<squnion> -w) \<sqinter> ((-v \<squnion> -x) \<sqinter> (--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
     by (metis 1 inf_associative)
   also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> -x) \<sqinter> (-v \<squnion> --z))"
     by (metis 1 inf_commutative)
   also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> ((-v \<squnion> -x) \<sqinter> (-v \<squnion> --z)))"
     by (metis 1 inf_associative)
   also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> (-x \<sqinter> --z)))"
     by (simp add: sup_left_dist_inf)
   also have "... = (--v \<squnion> -w) \<sqinter> (--v \<squnion> --y) \<sqinter> (-v \<squnion> (-x \<sqinter> --z))"
     using 1 2 by (metis inf_associative)
   also have "... = (--v \<squnion> (-w \<sqinter> --y)) \<sqinter> (-v \<squnion> (-x \<sqinter> --z))"
     by (simp add: sup_left_dist_inf)
   also have "... = (-v \<sqinter> (-w \<sqinter> --y)) \<squnion> (--v \<sqinter> (-x \<sqinter> --z))"
     by (metis case_duality complement_1 complement_2 sub_inf_def)
   also have "... = (-v \<sqinter> -w \<sqinter> --y) \<squnion> (--v \<sqinter> -x \<sqinter> --z)"
     by (simp add: inf_associative)
   finally show ?thesis
     .
 qed
 
 lemma inf_cases_2: "--x = -(-x \<sqinter> -y) \<sqinter> -(-x \<sqinter> --y)"
   using sub_inf_def sup_cases by auto
 
 text \<open>consequences for \<open>top\<close> and \<open>bot\<close>\<close>
 
 lemma sup_complement[simp]:
   "-x \<squnion> --x = top"
   using top_def by auto
 
 lemma inf_complement[simp]:
   "-x \<sqinter> --x = bot"
   by (metis sub_bot_def sub_inf_def sub_top_def top_def)
 
 lemma complement_bot[simp]:
   "-bot = top"
   using inf_complement inf_demorgan sup_complement by fastforce
 
 lemma complement_top[simp]:
   "-top = bot"
   using sub_bot_def sub_top_def by blast
 
 lemma sup_right_zero[simp]:
   "-x \<squnion> top = top"
   using sup_right_zero_var by auto
 
 lemma sup_left_zero[simp]:
   "top \<squnion> -x = top"
   by (metis complement_bot sub_commutative sup_right_zero)
 
 lemma inf_right_unit[simp]:
   "-x \<sqinter> bot = bot"
   by (metis complement_bot complement_top double_negation sub_sup_demorgan sup_right_zero)
 
 lemma inf_left_unit[simp]:
   "bot \<sqinter> -x = bot"
   by (metis complement_top inf_commutative inf_right_unit)
 
 lemma sup_right_unit[simp]:
   "-x \<squnion> bot = -x"
   using sup_right_unit_idempotent by auto
 
 lemma sup_left_unit[simp]:
   "bot \<squnion> -x = -x"
   by (metis complement_top sub_commutative sup_right_unit)
 
 lemma inf_right_zero[simp]:
   "-x \<sqinter> top = -x"
   by (metis inf_left_dist_sup sup_cases top_def)
 
 lemma sub_inf_left_zero[simp]:
   "top \<sqinter> -x = -x"
   using inf_absorb top_def by fastforce
 
 lemma bot_double_complement[simp]:
   "--bot = bot"
   by simp
 
 lemma top_double_complement[simp]:
   "--top = top"
   by simp
 
 text \<open>consequences for the order\<close>
 
 lemma reflexive:
   "-x \<le> -x"
   by (simp add: sub_less_eq_def)
 
 lemma transitive:
   "-x \<le> -y \<Longrightarrow> -y \<le> -z \<Longrightarrow> -x \<le> -z"
   by (metis sub_associative sub_less_eq_def)
 
 lemma antisymmetric:
   "-x \<le> -y \<Longrightarrow> -y \<le> -x \<Longrightarrow> -x = -y"
   by (simp add: sub_commutative sub_less_eq_def)
 
 lemma sub_bot_least:
   "bot \<le> -x"
   using sup_left_unit complement_top sub_less_eq_def by blast
 
 lemma top_greatest:
   "-x \<le> top"
   using complement_bot sub_less_eq_def sup_right_zero by blast
 
 lemma upper_bound_left:
   "-x \<le> -x \<squnion> -y"
   by (metis sub_associative sub_less_eq_def sub_sup_closed sup_idempotent)
 
 lemma upper_bound_right:
   "-y \<le> -x \<squnion> -y"
   using sub_commutative upper_bound_left by fastforce
 
 lemma sub_sup_left_isotone:
   assumes "-x \<le> -y"
     shows "-x \<squnion> -z \<le> -y \<squnion> -z"
 proof -
   have "-x \<squnion> -y = -y"
     by (meson assms sub_less_eq_def)
   thus ?thesis
     by (metis (full_types) sub_associative sub_commutative sub_sup_closed upper_bound_left)
 qed
 
 lemma sub_sup_right_isotone:
   "-x \<le> -y \<Longrightarrow> -z \<squnion> -x \<le> -z \<squnion> -y"
   by (simp add: sub_commutative sub_sup_left_isotone)
 
 lemma sup_isotone:
   assumes "-p \<le> -q"
       and "-r \<le> -s"
     shows "-p \<squnion> -r \<le> -q \<squnion> -s"
 proof -
   have "\<And>x y. \<not> -x \<le> -y \<squnion> -r \<or> -x \<le> -y \<squnion> -s"
     by (metis (full_types) assms(2) sub_sup_closed sub_sup_right_isotone transitive)
   thus ?thesis
     by (metis (no_types) assms(1) sub_sup_closed sub_sup_left_isotone)
 qed
 
 lemma sub_complement_antitone:
   "-x \<le> -y \<Longrightarrow> --y \<le> --x"
   by (metis inf_absorb inf_demorgan sub_less_eq_def)
 
 lemma less_eq_inf:
   "-x \<le> -y \<longleftrightarrow> -x \<sqinter> -y = -x"
   by (metis inf_absorb inf_commutative sub_less_eq_def upper_bound_right sup_absorb)
 
 lemma inf_complement_left_antitone:
   "-x \<le> -y \<Longrightarrow> -(-y \<sqinter> -z) \<le> -(-x \<sqinter> -z)"
   by (simp add: sub_complement_antitone inf_demorgan sub_sup_left_isotone)
 
 lemma sub_inf_left_isotone:
   "-x \<le> -y \<Longrightarrow> -x \<sqinter> -z \<le> -y \<sqinter> -z"
   using sub_complement_antitone inf_closed inf_complement_left_antitone by fastforce
 
 lemma sub_inf_right_isotone:
   "-x \<le> -y \<Longrightarrow> -z \<sqinter> -x \<le> -z \<sqinter> -y"
   by (simp add: inf_commutative sub_inf_left_isotone)
 
 lemma inf_isotone:
   assumes "-p \<le> -q"
       and "-r \<le> -s"
     shows "-p \<sqinter> -r \<le> -q \<sqinter> -s"
 proof -
   have "\<forall>w x y z. (-w \<le> -x \<sqinter> -y \<or> \<not> -w \<le> -x \<sqinter> -z) \<or> \<not> -z \<le> -y"
     by (metis (no_types) inf_closed sub_inf_right_isotone transitive)
   thus ?thesis
     by (metis (no_types) assms inf_closed sub_inf_left_isotone)
 qed
 
 lemma least_upper_bound:
   "-x \<le> -z \<and> -y \<le> -z \<longleftrightarrow> -x \<squnion> -y \<le> -z"
   by (metis sub_sup_closed transitive upper_bound_right sup_idempotent sup_isotone upper_bound_left)
 
 lemma lower_bound_left:
   "-x \<sqinter> -y \<le> -x"
   by (metis sub_inf_def upper_bound_right sup_absorb)
 
 lemma lower_bound_right:
   "-x \<sqinter> -y \<le> -y"
   using inf_commutative lower_bound_left by fastforce
 
 lemma greatest_lower_bound:
   "-x \<le> -y \<and> -x \<le> -z \<longleftrightarrow> -x \<le> -y \<sqinter> -z"
   by (metis inf_closed sub_inf_left_isotone less_eq_inf transitive lower_bound_left lower_bound_right)
 
 lemma less_eq_sup_top:
   "-x \<le> -y \<longleftrightarrow> --x \<squnion> -y = top"
   by (metis complement_1 inf_commutative inf_complement_intro sub_inf_left_zero less_eq_inf sub_complement sup_complement_intro top_def)
 
 lemma less_eq_inf_bot:
   "-x \<le> -y \<longleftrightarrow> -x \<sqinter> --y = bot"
   by (metis complement_bot complement_top double_negation inf_demorgan less_eq_sup_top sub_inf_def)
 
 lemma shunting:
   "-x \<sqinter> -y \<le> -z \<longleftrightarrow> -y \<le> --x \<squnion> -z"
 proof (cases "--x \<squnion> (-z \<squnion> --y) = top")
   case True
   have "\<forall>v w. -v \<le> -w \<or> -w \<squnion> --v \<noteq> top"
     using less_eq_sup_top sub_commutative by blast
   thus ?thesis
     by (metis True sub_associative sub_commutative sub_inf_def sub_sup_closed)
 next
   case False
   hence "--x \<squnion> (-z \<squnion> --y) \<noteq> top \<and> \<not> -y \<le> -z \<squnion> --x"
     by (metis (no_types) less_eq_sup_top sub_associative sub_commutative sub_sup_closed)
   thus ?thesis
     using less_eq_sup_top sub_associative sub_commutative sub_inf_def sub_sup_closed by auto
 qed
 
 lemma shunting_right:
   "-x \<sqinter> -y \<le> -z \<longleftrightarrow> -x \<le> -z \<squnion> --y"
   by (metis inf_commutative sub_commutative shunting)
 
 lemma sup_less_eq_cases:
   assumes "-z \<le> -x \<squnion> -y"
       and "-z \<le> --x \<squnion> -y"
     shows "-z \<le> -y"
 proof -
   have "-z \<le> (-x \<squnion> -y) \<sqinter> (--x \<squnion> -y)"
     by (metis assms greatest_lower_bound sub_sup_closed)
   also have "... = -y"
     by (metis inf_cases sub_commutative)
   finally show ?thesis
     .
 qed
 
 lemma sup_less_eq_cases_2:
   "-x \<squnion> -y \<le> -x \<squnion> -z \<Longrightarrow> --x \<squnion> -y \<le> --x \<squnion> -z \<Longrightarrow> -y \<le> -z"
   by (metis least_upper_bound sup_less_eq_cases sub_sup_closed)
 
 lemma sup_less_eq_cases_3:
   "-y \<squnion> -x \<le> -z \<squnion> -x \<Longrightarrow> -y \<squnion> --x \<le> -z \<squnion> --x \<Longrightarrow> -y \<le> -z"
   by (simp add: sup_less_eq_cases_2 sub_commutative)
 
 lemma inf_less_eq_cases:
   "-x \<sqinter> -y \<le> -z \<Longrightarrow> --x \<sqinter> -y \<le> -z \<Longrightarrow> -y \<le> -z"
   by (simp add: shunting sup_less_eq_cases)
 
 lemma inf_less_eq_cases_2:
   "-x \<sqinter> -y \<le> -x \<sqinter> -z \<Longrightarrow> --x \<sqinter> -y \<le> --x \<sqinter> -z \<Longrightarrow> -y \<le> -z"
   by (metis greatest_lower_bound inf_closed inf_less_eq_cases)
 
 lemma inf_less_eq_cases_3:
   "-y \<sqinter> -x \<le> -z \<sqinter> -x \<Longrightarrow> -y \<sqinter> --x \<le> -z \<sqinter> --x \<Longrightarrow> -y \<le> -z"
   by (simp add: inf_commutative inf_less_eq_cases_2)
 
 lemma inf_eq_cases:
   "-x \<sqinter> -y = -x \<sqinter> -z \<Longrightarrow> --x \<sqinter> -y = --x \<sqinter> -z \<Longrightarrow> -y = -z"
   by (metis inf_commutative sup_cases)
 
 lemma inf_eq_cases_2:
   "-y \<sqinter> -x = -z \<sqinter> -x \<Longrightarrow> -y \<sqinter> --x = -z \<sqinter> --x \<Longrightarrow> -y = -z"
   using inf_commutative inf_eq_cases by auto
 
 lemma wnf_lemma_1:
   "((-x \<squnion> -y) \<sqinter> (--x \<squnion> -z)) \<squnion> -x = -x \<squnion> -y"
 proof -
   have "\<forall>u v w. (-u \<sqinter> (-v \<squnion> --w)) \<squnion> -w = -u \<squnion> -w"
     by (metis inf_right_zero sub_associative sub_sup_closed sup_complement sup_idempotent sup_right_dist_inf)
   thus ?thesis
     by (metis (no_types) sub_associative sub_commutative sub_sup_closed sup_idempotent)
 qed
 
 lemma wnf_lemma_2:
   "((-x \<squnion> -y) \<sqinter> (-z \<squnion> --y)) \<squnion> -y = -x \<squnion> -y"
   using sub_commutative wnf_lemma_1 by fastforce
 
 lemma wnf_lemma_3:
   "((-x \<squnion> -z) \<sqinter> (--x \<squnion> -y)) \<squnion> --x = --x \<squnion> -y"
   by (metis case_duality case_duality_2 double_negation sub_commutative wnf_lemma_2)
 
 lemma wnf_lemma_4:
   "((-z \<squnion> -y) \<sqinter> (-x \<squnion> --y)) \<squnion> --y = -x \<squnion> --y"
   using sub_commutative wnf_lemma_3 by auto
 
 end
 
 class subset_boolean_algebra' = sup + uminus +
   assumes sub_associative': "-x \<squnion> (-y \<squnion> -z) = (-x \<squnion> -y) \<squnion> -z"
   assumes sub_commutative': "-x \<squnion> -y = -y \<squnion> -x"
   assumes sub_complement': "-x = -(--x \<squnion> -y) \<squnion> -(--x \<squnion> --y)"
   assumes sub_sup_closed': "\<exists>z . -x \<squnion> -y = -z"
 begin
 
 subclass subset_boolean_algebra
 proof
   show "\<And>x y z. - x \<squnion> (- y \<squnion> - z) = - x \<squnion> - y \<squnion> - z"
     by (simp add: sub_associative')
   show "\<And>x y. - x \<squnion> - y = - y \<squnion> - x"
     by (simp add: sub_commutative')
   show "\<And>x y. - x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)"
     by (simp add: sub_complement')
   show "\<And>x y. - x \<squnion> - y = - - (- x \<squnion> - y)"
   proof -
     fix x y
     have "\<forall>x y. -y \<squnion> (-(--y \<squnion> -x) \<squnion> -(---x \<squnion> -y)) = -y \<squnion> --x"
       by (metis (no_types) sub_associative' sub_commutative' sub_complement')
     hence "\<forall>x. ---x = -x"
       by (metis (no_types) sub_commutative' sub_complement')
     thus "-x \<squnion> -y = --(-x \<squnion> -y)"
       by (metis sub_sup_closed')
   qed
 qed
 
 end
 
 text \<open>
 We introduce a type for the range of complement and show that it is an instance of \<open>boolean_algebra\<close>.
 \<close>
 
 typedef (overloaded) 'a boolean_subset = "{ x::'a::uminus . \<exists>y . x = -y }"
   by auto
 
 lemma simp_boolean_subset[simp]:
   "\<exists>y . Rep_boolean_subset x = -y"
   using Rep_boolean_subset by simp
 
 setup_lifting type_definition_boolean_subset
 
 text \<open>Theorem 8.1\<close>
 
 instantiation boolean_subset :: (subset_boolean_algebra) huntington
 begin
 
 lift_definition sup_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is sup
   using sub_sup_closed by auto
 
 lift_definition uminus_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset" is uminus
   by auto
 
 instance
 proof
   show "\<And>x y z::'a boolean_subset. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     apply transfer
     using sub_associative by blast
   show "\<And>x y::'a boolean_subset. x \<squnion> y = y \<squnion> x"
     apply transfer
     using sub_commutative by blast
   show "\<And>x y::'a boolean_subset. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
     apply transfer
     using sub_complement by blast
 qed
 
 end
 
 text \<open>Theorem 8.2\<close>
 
 instantiation boolean_subset :: (subset_boolean_algebra_extended) huntington_extended
 begin
 
 lift_definition inf_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is inf
   using inf_closed by auto
 
 lift_definition minus_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is minus
   using sub_minus_def by auto
 
 lift_definition bot_boolean_subset :: "'a boolean_subset" is bot
   by (metis complement_top)
 
 lift_definition top_boolean_subset :: "'a boolean_subset" is top
   by (metis complement_bot)
 
 lift_definition less_eq_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> bool" is less_eq .
 
 lift_definition less_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> bool" is less .
 
 instance
 proof
   show 1: "top = (THE x. \<forall>y::'a boolean_subset. x = y \<squnion> - y)"
   proof (rule the_equality[symmetric])
     show "\<forall>y::'a boolean_subset. top = y \<squnion> - y"
       apply transfer
       by auto
     show "\<And>x::'a boolean_subset. \<forall>y. x = y \<squnion> - y \<Longrightarrow> x = top"
       apply transfer
       by force
   qed
   have "(bot::'a boolean_subset) = - top"
     apply transfer
     by simp
   thus "bot = - (THE x. \<forall>y::'a boolean_subset. x = y \<squnion> - y)"
     using 1 by simp
   show "\<And>x y::'a boolean_subset. x \<sqinter> y = - (- x \<squnion> - y)"
     apply transfer
     using sub_inf_def by blast
   show "\<And>x y::'a boolean_subset. x - y = - (- x \<squnion> y)"
     apply transfer
     using sub_minus_def by blast
   show "\<And>x y::'a boolean_subset. (x \<le> y) = (x \<squnion> y = y)"
     apply transfer
     using sub_less_eq_def by blast
   show "\<And>x y::'a boolean_subset. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     apply transfer
     using sub_less_def by blast
 qed
 
 end
 
 section \<open>Subset Boolean algebras with Additional Structure\<close>
 
 text \<open>
 We now discuss axioms that make the range of a unary operation a Boolean algebra, but add further properties that are common to the intended models.
 In the intended models, the unary operation can be a complement, a pseudocomplement or the antidomain operation.
 For simplicity, we mostly call the unary operation `complement'.
 
 We first look at structures based only on join and complement, and then add axioms for the remaining operations of Boolean algebras.
 In the intended models, the operation that is meet on the range of the complement can be a meet in the whole algebra or composition.
 \<close>
 
 subsection \<open>Axioms Derived from the New Axiomatisation\<close>
 
 text \<open>
 The axioms of the first algebra are based on \<open>boolean_algebra_3\<close>.
 \<close>
 
 text \<open>Definition 9\<close>
 
 class subset_boolean_algebra_1 = sup + uminus +
   assumes sba1_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes sba1_commutative: "x \<squnion> y = y \<squnion> x"
   assumes sba1_idempotent[simp]: "x \<squnion> x = x"
   assumes sba1_double_complement[simp]: "---x = -x"
   assumes sba1_bot_unique: "-(x \<squnion> -x) = -(y \<squnion> -y)"
   assumes sba1_export: "-x \<squnion> -(-x \<squnion> y) = -x \<squnion> -y"
 begin
 
 text \<open>Theorem 11.1\<close>
 
 subclass subset_boolean_algebra
 proof
   show "\<And>x y z. - x \<squnion> (- y \<squnion> - z) = - x \<squnion> - y \<squnion> - z"
     by (simp add: sba1_associative)
   show "\<And>x y. - x \<squnion> - y = - y \<squnion> - x"
     by (simp add: sba1_commutative)
   show "\<And>x y. - x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)"
     by (smt sba1_bot_unique sba1_commutative sba1_double_complement sba1_export sba1_idempotent)
   thus "\<And>x y. - x \<squnion> - y = - - (- x \<squnion> - y)"
     by (metis sba1_double_complement sba1_export)
 qed
 
 definition "sba1_bot \<equiv> THE x . \<forall>z . x = -(z \<squnion> -z)"
 
 lemma sba1_bot:
   "sba1_bot = -(z \<squnion> -z)"
   using sba1_bot_def sba1_bot_unique by auto
 
 end
 
 text \<open>Boolean algebra operations based on join and complement\<close>
 
 text \<open>Definition 10\<close>
 
 class subset_extended_1 = sup + inf + minus + uminus + bot + top + ord +
   assumes ba_bot: "bot = (THE x . \<forall>z . x = -(z \<squnion> -z))"
   assumes ba_top: "top = -(THE x . \<forall>z . x = -(z \<squnion> -z))"
   assumes ba_inf: "-x \<sqinter> -y = -(--x \<squnion> --y)"
   assumes ba_minus: "-x - -y = -(--x \<squnion> -y)"
   assumes ba_less_eq: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
   assumes ba_less: "x < y \<longleftrightarrow> x \<squnion> y = y \<and> \<not> (y \<squnion> x = x)"
 
 class subset_extended_2 = subset_extended_1 +
   assumes ba_bot_unique: "-(x \<squnion> -x) = -(y \<squnion> -y)"
 begin
 
 lemma ba_bot_def:
   "bot = -(z \<squnion> -z)"
   using ba_bot ba_bot_unique by auto
 
 lemma ba_top_def:
   "top = --(z \<squnion> -z)"
   using ba_bot_def ba_top by simp
 
 end
 
 text \<open>Subset forms Boolean Algebra, extended by Boolean algebra operations\<close>
 
 class subset_boolean_algebra_1_extended = subset_boolean_algebra_1 + subset_extended_1
 begin
 
 subclass subset_extended_2
 proof
   show "\<And>x y. - (x \<squnion> - x) = - (y \<squnion> - y)"
     by (simp add: sba1_bot_unique)
 qed
 
 subclass semilattice_sup
 proof
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: ba_less ba_less_eq)
   show "\<And>x. x \<le> x"
     by (simp add: ba_less_eq)
   show "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
     by (metis sba1_associative ba_less_eq)
   show "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     by (simp add: sba1_commutative ba_less_eq)
   show "\<And>x y. x \<le> x \<squnion> y"
     by (simp add: sba1_associative ba_less_eq)
   thus "\<And>y x. y \<le> x \<squnion> y"
     by (simp add: sba1_commutative)
   show "\<And>y x z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
     by (metis sba1_associative ba_less_eq)
 qed
 
 text \<open>Theorem 11.2\<close>
 
 subclass subset_boolean_algebra_extended
 proof
   show "top = (THE x. \<forall>y. x = - y \<squnion> - - y)"
     by (smt ba_bot ba_bot_def ba_top sub_sup_closed the_equality)
   thus "bot = - (THE x. \<forall>y. x = - y \<squnion> - - y)"
     using ba_bot_def ba_top_def by force
   show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
     by (simp add: ba_inf)
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: ba_minus)
   show "\<And>x y. (- x \<le> - y) = (- x \<squnion> - y = - y)"
     using le_iff_sup by auto
   show "\<And>x y. (- x < - y) = (- x \<squnion> - y = - y \<and> - y \<squnion> - x \<noteq> - x)"
     by (simp add: ba_less)
 qed
 
 end
 
 subsection \<open>Stronger Assumptions based on Join and Complement\<close>
 
 text \<open>
 We add further axioms covering properties common to the antidomain and (pseudo)complement instances.
 \<close>
 
 text \<open>Definition 12\<close>
 
 class subset_boolean_algebra_2 = sup + uminus +
   assumes sba2_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes sba2_commutative: "x \<squnion> y = y \<squnion> x"
   assumes sba2_idempotent[simp]: "x \<squnion> x = x"
   assumes sba2_bot_unit: "x \<squnion> -(y \<squnion> -y) = x"
   assumes sba2_sub_sup_demorgan: "-(x \<squnion> y) = -(--x \<squnion> --y)"
   assumes sba2_export: "-x \<squnion> -(-x \<squnion> y) = -x \<squnion> -y"
 begin
 
 text \<open>Theorem 13.1\<close>
 
 subclass subset_boolean_algebra_1
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sba2_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sba2_commutative)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x. - - - x = - x"
     by (metis sba2_idempotent sba2_sub_sup_demorgan)
   show "\<And>x y. - (x \<squnion> - x) = - (y \<squnion> - y)"
     by (metis sba2_bot_unit sba2_commutative)
   show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
     by (simp add: sba2_export)
 qed
 
 text \<open>Theorem 13.2\<close>
 
 lemma double_complement_dist_sup:
   "--(x \<squnion> y) = --x \<squnion> --y"
   by (metis sba2_commutative sba2_export sba2_idempotent sba2_sub_sup_demorgan)
 
 lemma maddux_3_3[simp]:
   "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
   by (metis double_complement_dist_sup sba1_double_complement sba2_commutative sub_complement)
 
 lemma huntington_3_pp[simp]:
   "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
   using sba2_commutative maddux_3_3 by fastforce
 
 end
 
 class subset_boolean_algebra_2_extended = subset_boolean_algebra_2 + subset_extended_1
 begin
 
 subclass subset_boolean_algebra_1_extended ..
 
 subclass bounded_semilattice_sup_bot
 proof
   show "\<And>x. bot \<le> x"
     using sba2_bot_unit ba_bot_def sup_right_divisibility by auto
 qed
 
 text \<open>Theorem 13.3\<close>
 
 lemma complement_antitone:
   "x \<le> y \<Longrightarrow> -y \<le> -x"
   by (metis le_iff_sup maddux_3_3 sba2_export sup_monoid.add_commute)
 
 lemma double_complement_isotone:
   "x \<le> y \<Longrightarrow> --x \<le> --y"
   by (simp add: complement_antitone)
 
 lemma sup_demorgan:
   "-(x \<squnion> y) = -x \<sqinter> -y"
   using sba2_sub_sup_demorgan ba_inf by auto
 
 end
 
 subsection \<open>Axioms for Meet\<close>
 
 text \<open>
 We add further axioms of \<open>inf\<close> covering properties common to the antidomain and pseudocomplement instances.
 We omit the left distributivity rule and the right zero rule as they do not hold in some models.
 In particular, the operation \<open>inf\<close> does not have to be commutative.
 \<close>
 
 text \<open>Definition 14\<close>
 
 class subset_boolean_algebra_3_extended = subset_boolean_algebra_2_extended +
   assumes sba3_inf_associative: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
   assumes sba3_inf_right_dist_sup: "(x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
   assumes sba3_inf_complement_bot: "-x \<sqinter> x = bot"
   assumes sba3_inf_left_unit[simp]: "top \<sqinter> x = x"
   assumes sba3_complement_inf_double_complement: "-(x \<sqinter> --y) = -(x \<sqinter> y)"
 begin
 
 text \<open>Theorem 15\<close>
 
 lemma inf_left_zero:
   "bot \<sqinter> x = bot"
   by (metis inf_right_unit sba3_inf_associative sba3_inf_complement_bot)
 
 lemma inf_double_complement_export:
   "--(--x \<sqinter> y) = --x \<sqinter> --y"
   by (metis inf_closed sba3_complement_inf_double_complement)
 
 lemma inf_left_isotone:
   "x \<le> y \<Longrightarrow> x \<sqinter> z \<le> y \<sqinter> z"
   using sba3_inf_right_dist_sup sup_right_divisibility by auto
 
 lemma inf_complement_export:
   "--(-x \<sqinter> y) = -x \<sqinter> --y"
   by (metis inf_double_complement_export sba1_double_complement)
 
 lemma double_complement_above:
   "--x \<sqinter> x = x"
   by (metis sup_monoid.add_0_right complement_bot inf_demorgan sba1_double_complement sba3_inf_complement_bot sba3_inf_right_dist_sup sba3_inf_left_unit)
 
 lemma "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y" nitpick [expect=genuine] oops
 lemma "x \<sqinter> top = x" nitpick [expect=genuine] oops
 lemma "x \<sqinter> y = y \<sqinter> x" nitpick [expect=genuine] oops
 
 end
 
 subsection \<open>Stronger Assumptions for Meet\<close>
 
 text \<open>
 The following axioms also hold in both models, but follow from the axioms of \<open>subset_boolean_algebra_5_operations\<close>.
 \<close>
 
 text \<open>Definition 16\<close>
 
 class subset_boolean_algebra_4_extended = subset_boolean_algebra_3_extended +
   assumes sba4_inf_right_unit[simp]: "x \<sqinter> top = x"
   assumes inf_right_isotone: "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
 begin
 
 lemma "x \<squnion> top = top" nitpick [expect=genuine] oops
 lemma "x \<sqinter> bot = bot" nitpick [expect=genuine] oops
 lemma "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" nitpick [expect=genuine] oops
 lemma "(x \<sqinter> y = bot) = (x \<le> - y)" nitpick [expect=genuine] oops
 
 end
 
 section \<open>Boolean Algebras in Stone Algebras\<close>
 
 text \<open>
 We specialise \<open>inf\<close> to meet and complement to pseudocomplement.
 This puts Stone algebras into the picture; for these it is well known that regular elements form a Boolean subalgebra \<^cite>\<open>"Graetzer1971"\<close>.
 \<close>
 
 text \<open>Definition 17\<close>
 
 class subset_boolean_algebra_5_extended = subset_boolean_algebra_3_extended +
   assumes sba5_inf_commutative: "x \<sqinter> y = y \<sqinter> x"
   assumes sba5_inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
 begin
 
 subclass distrib_lattice_bot
 proof
   show "\<And>x y. x \<sqinter> y \<le> x"
     by (metis sba5_inf_commutative sba3_inf_right_dist_sup sba5_inf_absorb sup_right_divisibility)
   show "\<And>x y. x \<sqinter> y \<le> y"
     by (metis inf_left_isotone sba5_inf_absorb sba5_inf_commutative sup_ge2)
   show "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
     by (metis inf_left_isotone sba5_inf_absorb sup.orderE sup_monoid.add_commute)
   show "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z) "
     by (metis sba3_inf_right_dist_sup sba5_inf_absorb sba5_inf_commutative sup_assoc)
 qed
 
 lemma inf_demorgan_2:
   "-(x \<sqinter> y) = -x \<squnion> -y"
   using sba3_complement_inf_double_complement sba5_inf_commutative sub_sup_closed sub_sup_demorgan by auto
 
 lemma inf_export:
   "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
   using inf_demorgan_2 sba3_inf_complement_bot sba3_inf_right_dist_sup sba5_inf_commutative by auto
 
 lemma complement_inf[simp]:
   "x \<sqinter> -x = bot"
   using sba3_inf_complement_bot sba5_inf_commutative by auto
 
 text \<open>Theorem 18.2\<close>
 
 subclass stone_algebra
 proof
   show "\<And>x. x \<le> top"
     by (simp add: inf.absorb_iff2)
   show "\<And>x y. (x \<sqinter> y = bot) = (x \<le> - y)"
     by (metis (full_types) complement_bot complement_inf inf.cobounded1 inf.order_iff inf_export sba3_complement_inf_double_complement sba3_inf_left_unit)
   show "\<And>x. - x \<squnion> - - x = top"
     by simp
 qed
 
 text \<open>Theorem 18.1\<close>
 
 subclass subset_boolean_algebra_4_extended
 proof
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     using inf.sup_right_isotone by blast
 qed
 
 end
 
 context stone_algebra_extended
 begin
 
 text \<open>Theorem 18.3\<close>
 
 subclass subset_boolean_algebra_5_extended
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     using sup_assoc by auto
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x y. x \<squnion> - (y \<squnion> - y) = x"
     by simp
   show "\<And>x y. - (x \<squnion> y) = - (- - x \<squnion> - - y)"
     by auto
   show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
     by (metis maddux_3_21_pp p_dist_sup regular_closed_p)
   show "bot = (THE x. \<forall>z. x = - (z \<squnion> - z))"
     by simp
   thus "top = - (THE x. \<forall>z. x = - (z \<squnion> - z))"
     using p_bot by blast
   show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
     by simp
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by auto
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   thus "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     by (simp add: less_le_not_le)
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: inf.sup_monoid.add_assoc)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: inf_sup_distrib2)
   show "\<And>x. - x \<sqinter> x = bot"
     by simp
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)"
     by simp
   show "\<And>x y. x \<sqinter> y = y \<sqinter> x"
     by (simp add: inf_commute)
   show "\<And>x y. x \<sqinter> (x \<squnion> y) = x"
     by simp
 qed
 
 end
 
 section \<open>Domain Semirings\<close>
 
 text \<open>
 The following development of tests in IL-semirings, prepredomain semirings, predomain semirings and domain semirings is mostly based on \<^cite>\<open>"MoellerDesharnais2019"\<close>; see also \<^cite>\<open>"DesharnaisMoeller2014"\<close>.
 See \<^cite>\<open>"DesharnaisMoellerStruth2006b"\<close> for domain axioms in idempotent semirings.
 See \<^cite>\<open>"DesharnaisJipsenStruth2009" and "JacksonStokes2004"\<close> for domain axioms in semigroups and monoids.
 Some variants have been implemented in \<^cite>\<open>"GomesGuttmannHoefnerStruthWeber2016"\<close>.
 \<close>
 
 subsection \<open>Idempotent Left Semirings\<close>
 
 text \<open>Definition 19\<close>
 
 class il_semiring = sup + inf + bot + top + ord +
   assumes il_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
   assumes il_commutative: "x \<squnion> y = y \<squnion> x"
   assumes il_idempotent[simp]: "x \<squnion> x = x"
   assumes il_bot_unit: "x \<squnion> bot = x"
   assumes il_inf_associative: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
   assumes il_inf_right_dist_sup: "(x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
   assumes il_inf_left_unit[simp]: "top \<sqinter> x = x"
   assumes il_inf_right_unit[simp]: "x \<sqinter> top = x"
   assumes il_sub_inf_left_zero[simp]: "bot \<sqinter> x = bot"
   assumes il_sub_inf_right_isotone: "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
   assumes il_less_eq: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
   assumes il_less_def: "x < y \<longleftrightarrow> x \<le> y \<and> \<not>(y \<le> x)"
 begin
 
 lemma il_unit_bot: "bot \<squnion> x = x"
   using il_bot_unit il_commutative by fastforce
 
 subclass order
 proof
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: il_less_def)
   show "\<And>x. x \<le> x"
     by (simp add: il_less_eq)
   show "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
     by (metis il_associative il_less_eq)
   show "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
     by (simp add: il_commutative il_less_eq)
 qed
 
 lemma il_sub_inf_right_isotone_var:
   "(x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
   by (smt il_associative il_commutative il_idempotent il_less_eq il_sub_inf_right_isotone)
 
 lemma il_sub_inf_left_isotone:
   "x \<le> y \<Longrightarrow> x \<sqinter> z \<le> y \<sqinter> z"
   by (metis il_inf_right_dist_sup il_less_eq)
 
 lemma il_sub_inf_left_isotone_var:
   "(y \<sqinter> x) \<squnion> (z \<sqinter> x) \<le> (y \<squnion> z) \<sqinter> x"
   by (simp add: il_inf_right_dist_sup)
 
 lemma sup_left_isotone:
   "x \<le> y \<Longrightarrow> x \<squnion> z \<le> y \<squnion> z"
   by (smt il_associative il_commutative il_idempotent il_less_eq)
 
 lemma sup_right_isotone:
   "x \<le> y \<Longrightarrow> z \<squnion> x \<le> z \<squnion> y"
   by (simp add: il_commutative sup_left_isotone)
 
 lemma bot_least:
   "bot \<le> x"
   by (simp add: il_less_eq il_unit_bot)
 
 lemma less_eq_bot:
   "x \<le> bot \<longleftrightarrow> x = bot"
   by (simp add: il_bot_unit il_less_eq)
 
 abbreviation are_complementary :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "are_complementary x y \<equiv> x \<squnion> y = top \<and> x \<sqinter> y = bot \<and> y \<sqinter> x = bot"
 
 abbreviation test :: "'a \<Rightarrow> bool"
   where "test x \<equiv> \<exists>y . are_complementary x y"
 
 definition tests :: "'a set"
   where "tests = { x . test x }"
 
 lemma bot_test:
   "test bot"
   by (simp add: il_unit_bot)
 
 lemma top_test:
   "test top"
   by (simp add: il_bot_unit)
 
 lemma test_sub_identity:
   "test x \<Longrightarrow> x \<le> top"
   using il_associative il_less_eq by auto
 
 lemma neg_unique:
   "are_complementary x y \<Longrightarrow> are_complementary x z \<Longrightarrow> y = z"
   by (metis order.antisym il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone_var)
 
 definition neg :: "'a \<Rightarrow> 'a" ("!")
   where "!x \<equiv> THE y . are_complementary x y"
 
 lemma neg_char:
   assumes "test x"
     shows "are_complementary x (!x)"
 proof (unfold neg_def)
   from assms obtain y where 1: "are_complementary x y"
     by auto
   show "are_complementary x (THE y. are_complementary x y)"
   proof (rule theI)
     show "are_complementary x y"
       using 1 by simp
     show "\<And>z. are_complementary x z \<Longrightarrow> z = y"
       using 1 neg_unique by blast
   qed
 qed
 
 lemma are_complementary_symmetric:
   "are_complementary x y \<longleftrightarrow> are_complementary y x"
   using il_commutative by auto
 
 lemma neg_test:
   "test x \<Longrightarrow> test (!x)"
   using are_complementary_symmetric neg_char by blast
 
 lemma are_complementary_test:
   "test x \<Longrightarrow> are_complementary x y \<Longrightarrow> test y"
   using il_commutative by auto
 
 lemma neg_involutive:
   "test x \<Longrightarrow> !(!x) = x"
   using are_complementary_symmetric neg_char neg_unique by blast
 
 lemma test_inf_left_below:
   "test x \<Longrightarrow> x \<sqinter> y \<le> y"
   by (metis il_associative il_idempotent il_inf_left_unit il_inf_right_dist_sup il_less_eq)
 
 lemma test_inf_right_below:
   "test x \<Longrightarrow> y \<sqinter> x \<le> y"
   by (metis il_inf_right_unit il_sub_inf_right_isotone test_sub_identity)
 
 lemma neg_bot:
   "!bot = top"
   using il_unit_bot neg_char by fastforce
 
 lemma neg_top:
   "!top = bot"
   using bot_test neg_bot neg_involutive by fastforce
 
 lemma test_inf_idempotent:
   "test x \<Longrightarrow> x \<sqinter> x = x"
   by (metis il_bot_unit il_inf_left_unit il_inf_right_dist_sup)
 
 lemma test_inf_semicommutative:
   assumes "test x"
       and "test y"
   shows "x \<sqinter> y \<le> y \<sqinter> x"
 proof -
   have "x \<sqinter> y = (y \<sqinter> x \<sqinter> y) \<squnion> (!y \<sqinter> x \<sqinter> y)"
     by (metis assms(2) il_inf_left_unit il_inf_right_dist_sup neg_char)
   also have "... \<le> (y \<sqinter> x \<sqinter> y) \<squnion> (!y \<sqinter> y)"
   proof -
     obtain z where "are_complementary y z"
       using assms(2) by blast
     hence "y \<sqinter> (x \<sqinter> y) \<squnion> !y \<sqinter> (x \<sqinter> y) \<le> y \<sqinter> (x \<sqinter> y)"
       by (metis assms(1) calculation il_sub_inf_left_isotone il_bot_unit il_idempotent il_inf_associative il_less_eq neg_char test_inf_right_below)
     thus ?thesis
       by (simp add: il_associative il_inf_associative il_less_eq)
   qed
   also have "... \<le> (y \<sqinter> x) \<squnion> (!y \<sqinter> y)"
     by (metis assms(2) il_bot_unit il_inf_right_unit il_sub_inf_right_isotone neg_char test_sub_identity)
   also have "... = y \<sqinter> x"
     by (simp add: assms(2) il_bot_unit neg_char)
   finally show ?thesis
     .
 qed
 
 lemma test_inf_commutative:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<sqinter> y = y \<sqinter> x"
   by (simp add: order.antisym test_inf_semicommutative)
 
 lemma test_inf_bot:
   "test x \<Longrightarrow> x \<sqinter> bot = bot"
   using il_inf_associative test_inf_idempotent by fastforce
 
 lemma test_absorb_1:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<squnion> (x \<sqinter> y) = x"
   using il_commutative il_less_eq test_inf_right_below by auto
 
 lemma test_absorb_2:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<squnion> (y \<sqinter> x) = x"
   by (metis test_absorb_1 test_inf_commutative)
 
 lemma test_absorb_3:
   "test x \<Longrightarrow> test y \<Longrightarrow> x \<sqinter> (x \<squnion> y) = x"
   apply (rule order.antisym)
   apply (metis il_associative il_inf_right_unit il_less_eq il_sub_inf_right_isotone test_sub_identity)
   by (metis il_sub_inf_right_isotone_var test_absorb_1 test_inf_idempotent)
 
 lemma test_absorb_4:
   "test x \<Longrightarrow> test y \<Longrightarrow> (x \<squnion> y) \<sqinter> x = x"
   by (smt il_inf_right_dist_sup test_inf_idempotent il_commutative il_less_eq test_inf_left_below)
 
 lemma test_import_1:
   assumes "test x"
       and "test y"
     shows "x \<squnion> (!x \<sqinter> y) = x \<squnion> y"
 proof -
   have "x \<squnion> (!x \<sqinter> y) = x \<squnion> ((y \<squnion> !y) \<sqinter> x) \<squnion> (!x \<sqinter> y)"
     by (simp add: assms(2) neg_char)
   also have "... = x \<squnion> (!y \<sqinter> x) \<squnion> (x \<sqinter> y) \<squnion> (!x \<sqinter> y)"
     by (smt assms il_associative il_commutative il_inf_right_dist_sup test_inf_commutative)
   also have "... = x \<squnion> ((x \<squnion> !x) \<sqinter> y)"
     by (smt calculation il_associative il_commutative il_idempotent il_inf_right_dist_sup)
   also have "... = x \<squnion> y"
     by (simp add: assms(1) neg_char)
   finally show ?thesis
     .
 qed
 
 lemma test_import_2:
   assumes "test x"
       and "test y"
     shows "x \<squnion> (y \<sqinter> !x) = x \<squnion> y"
 proof -
   obtain z where 1: "are_complementary y z"
-    using assms(2) by moura
+    using assms(2) by blast
   obtain w where 2: "are_complementary x w"
     using assms(1) by auto
   hence "x \<sqinter> !x = bot"
     using neg_char by blast
   hence "!x \<sqinter> y = y \<sqinter> !x"
     using 1 2 by (metis il_commutative neg_char test_inf_commutative)
   thus ?thesis
     using 1 2 by (metis test_import_1)
 qed
 
 lemma test_import_3:
   assumes "test x"
     shows "(!x \<squnion> y) \<sqinter> x = y \<sqinter> x"
   by (simp add: assms(1) il_inf_right_dist_sup il_unit_bot neg_char)
 
 lemma test_import_4:
   assumes "test x"
       and "test y"
     shows "(!x \<squnion> y) \<sqinter> x = x \<sqinter> y"
   by (metis assms test_import_3 test_inf_commutative)
 
 lemma test_inf:
   "test x \<Longrightarrow> test y \<Longrightarrow> test z \<Longrightarrow> z \<le> x \<sqinter> y \<longleftrightarrow> z \<le> x \<and> z \<le> y"
   apply (rule iffI)
   using dual_order.trans test_inf_left_below test_inf_right_below apply blast
   by (smt il_less_eq il_sub_inf_right_isotone test_absorb_4)
 
 lemma test_shunting:
   assumes "test x"
       and "test y"
     shows "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> !y \<squnion> z"
 proof
   assume 1: "x \<sqinter> y \<le> z"
   have "x = (!y \<sqinter> x) \<squnion> (y \<sqinter> x)"
     by (metis assms(2) il_commutative il_inf_left_unit il_inf_right_dist_sup neg_char)
   also have "... \<le> !y \<squnion> (y \<sqinter> x)"
     by (simp add: assms(1) sup_left_isotone test_inf_right_below)
   also have "... \<le> !y \<squnion> z"
     using 1 by (simp add: assms sup_right_isotone test_inf_commutative)
   finally show "x \<le> !y \<squnion> z"
     .
 next
   assume "x \<le> !y \<squnion> z"
   hence "x \<sqinter> y \<le> (!y \<squnion> z) \<sqinter> y"
     using il_sub_inf_left_isotone by blast
   also have "... = z \<sqinter> y"
     by (simp add: assms(2) test_import_3)
   also have "... \<le> z"
     by (simp add: assms(2) test_inf_right_below)
   finally show "x \<sqinter> y \<le> z"
     .
 qed
 
 lemma test_shunting_bot:
   assumes "test x"
       and "test y"
     shows "x \<le> y \<longleftrightarrow> x \<sqinter> !y \<le> bot"
   by (simp add: assms il_bot_unit neg_involutive neg_test test_shunting)
 
 lemma test_shunting_bot_eq:
   assumes "test x"
       and "test y"
     shows "x \<le> y \<longleftrightarrow> x \<sqinter> !y = bot"
   by (simp add: assms test_shunting_bot less_eq_bot)
 
 lemma neg_antitone:
   assumes "test x"
       and "test y"
       and "x \<le> y"
     shows "!y \<le> !x"
 proof -
   have 1: "x \<sqinter> !y = bot"
     using assms test_shunting_bot_eq by blast
   have 2: "x \<squnion> !x = top"
     by (simp add: assms(1) neg_char)
   have "are_complementary y (!y)"
     by (simp add: assms(2) neg_char)
   thus ?thesis
     using 1 2 by (metis il_unit_bot il_commutative il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone test_sub_identity)
 qed
 
 lemma test_sup_neg_1:
   assumes "test x"
       and "test y"
     shows "(x \<squnion> y) \<squnion> (!x \<sqinter> !y) = top"
 proof -
   have "x \<squnion> !x = top"
     by (simp add: assms(1) neg_char)
   hence "x \<squnion> (y \<squnion> !x) = top"
     by (metis assms(2) il_associative il_commutative il_idempotent)
   hence "x \<squnion> (y \<squnion> !x \<sqinter> !y) = top"
     by (simp add: assms neg_test test_import_2)
   thus ?thesis
     by (simp add: il_associative)
 qed
 
 lemma test_sup_neg_2:
   assumes "test x"
       and "test y"
     shows "(x \<squnion> y) \<sqinter> (!x \<sqinter> !y) = bot"
 proof -
   have 1: "are_complementary y (!y)"
     by (simp add: assms(2) neg_char)
   obtain z where 2: "are_complementary x z"
     using assms(1) by auto
   hence "!x = z"
     using neg_char neg_unique by blast
   thus ?thesis
     using 1 2 by (metis are_complementary_symmetric il_inf_associative neg_involutive test_import_3 test_inf_bot test_inf_commutative)
 qed
 
 lemma de_morgan_1:
   assumes "test x"
       and "test y"
       and "test (x \<sqinter> y)"
     shows "!(x \<sqinter> y) = !x \<squnion> !y"
 proof (rule order.antisym)
   have 1: "test (!(x \<sqinter> y))"
     by (simp add: assms neg_test)
   have "x \<le> (x \<sqinter> y) \<squnion> !y"
     by (metis (full_types) assms il_commutative neg_char test_shunting test_shunting_bot_eq)
   hence "x \<sqinter> !(x \<sqinter> y) \<le> !y"
     using 1 by (simp add: assms(1,3) neg_involutive test_shunting)
   hence "!(x \<sqinter> y) \<sqinter> x \<le> !y"
     using 1 by (metis assms(1) test_inf_commutative)
   thus "!(x \<sqinter> y) \<le> !x \<squnion> !y"
     using 1 assms(1) test_shunting by blast
   have 2: "!x \<le> !(x \<sqinter> y)"
     by (simp add: assms neg_antitone test_inf_right_below)
   have "!y \<le> !(x \<sqinter> y)"
     by (simp add: assms neg_antitone test_inf_left_below)
   thus "!x \<squnion> !y \<le> !(x \<sqinter> y)"
     using 2 by (metis il_associative il_less_eq)
 qed
 
 lemma de_morgan_2:
   assumes "test x"
       and "test y"
       and "test (x \<squnion> y)"
     shows "!(x \<squnion> y) = !x \<sqinter> !y"
 proof (rule order.antisym)
   have 1: "!(x \<squnion> y) \<le> !x"
     by (metis assms il_inf_left_unit il_sub_inf_left_isotone neg_antitone test_absorb_3 test_sub_identity)
   have "!(x \<squnion> y) \<le> !y"
     by (metis assms il_commutative il_inf_left_unit il_sub_inf_left_isotone neg_antitone test_absorb_3 test_sub_identity)
   thus "!(x \<squnion> y) \<le> !x \<sqinter> !y"
     using 1 by (simp add: assms neg_test test_inf)
   have "top \<le> x \<squnion> y \<squnion> !(x \<squnion> y)"
     by (simp add: assms(3) neg_char)
   hence "top \<sqinter> !x \<le> y \<squnion> !(x \<squnion> y)"
     by (smt assms(1) assms(3) il_commutative il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone il_unit_bot neg_char test_sub_identity)
   thus "!x \<sqinter> !y \<le> !(x \<squnion> y)"
     by (simp add: assms(1) assms(2) neg_involutive neg_test test_shunting)
 qed
 
 lemma test_inf_closed_sup_complement:
   assumes "test x"
       and "test y"
       and "\<forall>u v . test u \<and> test v \<longrightarrow> test (u \<sqinter> v)"
     shows "!x \<sqinter> !y \<sqinter> (x \<squnion> y) = bot"
 proof -
   have 1: "!(!x \<sqinter> !y) = x \<squnion> y"
     by (simp add: assms de_morgan_1 neg_involutive neg_test)
   have "test (!(!x \<sqinter> !y))"
     by (metis assms neg_test)
   thus ?thesis
     using 1 by (metis assms(1,2) de_morgan_2 neg_char)
 qed
 
 lemma test_sup_complement_sup_closed:
   assumes "test x"
       and "test y"
       and "\<forall>u v . test u \<and> test v \<longrightarrow> !u \<sqinter> !v \<sqinter> (u \<squnion> v) = bot"
     shows "test (x \<squnion> y)"
   by (meson assms test_sup_neg_1 test_sup_neg_2)
 
 lemma test_inf_closed_sup_closed:
   assumes "test x"
       and "test y"
       and "\<forall>u v . test u \<and> test v \<longrightarrow> test (u \<sqinter> v)"
     shows "test (x \<squnion> y)"
   using assms test_inf_closed_sup_complement test_sup_complement_sup_closed by simp
 
 end
 
 subsection \<open>Prepredomain Semirings\<close>
 
 class dom =
   fixes d :: "'a \<Rightarrow> 'a"
 
 class ppd_semiring = il_semiring + dom +
   assumes d_closed: "test (d x)"
   assumes d1: "x \<le> d x \<sqinter> x"
 begin
 
 lemma d_sub_identity:
   "d x \<le> top"
   using d_closed test_sub_identity by blast
 
 lemma d1_eq:
   "x = d x \<sqinter> x"
 proof -
   have "x = (d x \<squnion> top) \<sqinter> x"
     using d_sub_identity il_less_eq by auto
   thus ?thesis
     using d1 il_commutative il_inf_right_dist_sup il_less_eq by force
 qed
 
 lemma d_increasing_sub_identity:
   "x \<le> top \<Longrightarrow> x \<le> d x"
   by (metis d1_eq il_inf_right_unit il_sub_inf_right_isotone)
 
 lemma d_top:
   "d top = top"
   by (simp add: d_increasing_sub_identity d_sub_identity dual_order.antisym)
 
 lemma d_bot_only:
   "d x = bot \<Longrightarrow> x = bot"
   by (metis d1_eq il_sub_inf_left_zero)
 
 lemma d_strict: "d bot \<le> bot" nitpick [expect=genuine] oops
 lemma d_isotone_var: "d x \<le> d (x \<squnion> y)" nitpick [expect=genuine] oops
 lemma d_fully_strict: "d x = bot \<longleftrightarrow> x = bot" nitpick [expect=genuine] oops
 lemma test_d_fixpoint: "test x \<Longrightarrow> d x = x" nitpick [expect=genuine] oops
 
 end
 
 subsection \<open>Predomain Semirings\<close>
 
 class pd_semiring = ppd_semiring +
   assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
 begin
 
 lemma d_strict:
   "d bot \<le> bot"
   using bot_test d2 by fastforce
 
 lemma d_strict_eq:
   "d bot = bot"
   using d_strict il_bot_unit il_less_eq by auto
 
 lemma test_d_fixpoint:
   "test x \<Longrightarrow> d x = x"
   by (metis order.antisym d1_eq d2 test_inf_idempotent test_inf_right_below)
 
 lemma d_surjective:
   "test x \<Longrightarrow> \<exists>y . d y = x"
   using test_d_fixpoint by blast
 
 lemma test_d_fixpoint_iff:
   "test x \<longleftrightarrow> d x = x"
   by (metis d_closed test_d_fixpoint)
 
 lemma d_surjective_iff:
   "test x \<longleftrightarrow> (\<exists>y . d y = x)"
   using d_surjective d_closed by blast
 
 lemma tests_d_range:
   "tests = range d"
   using tests_def image_def d_surjective_iff by auto
 
 lemma llp:
   assumes "test y"
     shows "d x \<le> y \<longleftrightarrow> x \<le> y \<sqinter> x"
   by (metis assms d1_eq d2 order.eq_iff il_sub_inf_left_isotone test_inf_left_below)
 
 lemma gla:
   assumes "test y"
     shows "y \<le> !(d x) \<longleftrightarrow> y \<sqinter> x \<le> bot"
 proof -
   obtain ad where 1: "\<forall>x. are_complementary (d x) (ad x)"
     using d_closed by moura
   hence 2: "\<forall>x y. d (d y \<sqinter> x) \<le> d y"
     using d2 by blast
   have 3: "\<forall>x. ad x \<sqinter> x = bot"
     using 1 by (metis d1_eq il_inf_associative il_sub_inf_left_zero)
   have 4: "\<forall>x y. d y \<sqinter> x \<squnion> ad y \<sqinter> x = top \<sqinter> x"
     using 1 by (metis il_inf_right_dist_sup)
   have 5: "\<forall>x y z. z \<sqinter> y \<le> x \<sqinter> y \<or> (z \<squnion> x) \<sqinter> y \<noteq> x \<sqinter> y"
     by (simp add: il_inf_right_dist_sup il_less_eq)
   have 6: "\<forall>x. !(d x) = ad x"
     using 1 neg_char neg_unique by blast
   have 7: "\<forall>x. top \<sqinter> x = x"
     by auto
   hence "\<forall>x. y \<sqinter> x \<squnion> !y \<sqinter> x = x"
     by (metis assms il_inf_right_dist_sup neg_char)
   thus ?thesis
     using 1 2 3 4 5 6 7 by (metis assms d1_eq il_commutative il_less_eq test_d_fixpoint)
 qed
 
 lemma gla_var:
   "test y \<Longrightarrow> y \<sqinter> d x \<le> bot \<longleftrightarrow> y \<sqinter> x \<le> bot"
   using gla d_closed il_bot_unit test_shunting by auto
 
 lemma llp_var:
   assumes "test y"
     shows "y \<le> !(d x) \<longleftrightarrow> x \<le> !y \<sqinter> x"
   apply (rule iffI)
   apply (metis (no_types, opaque_lifting) assms gla Least_equality il_inf_left_unit il_inf_right_dist_sup il_less_eq il_unit_bot order.refl neg_char)
   by (metis assms gla gla_var llp il_commutative il_sub_inf_right_isotone neg_char)
 
 lemma d_idempotent:
   "d (d x) = d x"
   using d_closed test_d_fixpoint_iff by auto
 
 lemma d_neg:
   "test x \<Longrightarrow> d (!x) = !x"
   using il_commutative neg_char test_d_fixpoint_iff by fastforce
 
 lemma d_fully_strict:
   "d x = bot \<longleftrightarrow> x = bot"
   using d_strict_eq d_bot_only by blast
 
 lemma d_ad_comp:
   "!(d x) \<sqinter> x = bot"
 proof -
   have "\<forall>x. !(d x) \<sqinter> d x = bot"
     by (simp add: d_closed neg_char)
   thus ?thesis
     by (metis d1_eq il_inf_associative il_sub_inf_left_zero)
 qed
 
 lemma d_isotone:
   assumes "x \<le> y"
     shows "d x \<le> d y"
 proof -
   obtain ad where 1: "\<forall>x. are_complementary (d x) (ad x)"
     using d_closed by moura
   hence "ad y \<sqinter> x \<le> bot"
     by (metis assms d1_eq il_inf_associative il_sub_inf_left_zero il_sub_inf_right_isotone)
   thus ?thesis
     using 1 by (metis d2 il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_less_eq)
 qed
 
 lemma d_isotone_var:
   "d x \<le> d (x \<squnion> y)"
   using d_isotone il_associative il_less_eq by auto
 
 lemma d3_conv:
   "d (x \<sqinter> y) \<le> d (x \<sqinter> d y)"
   by (metis (mono_tags, opaque_lifting) d1_eq d2 d_closed il_inf_associative)
 
 lemma d_test_inf_idempotent:
   "d x \<sqinter> d x = d x"
   by (metis d_idempotent d1_eq)
 
 lemma d_test_inf_closed:
   assumes "test x"
       and "test y"
     shows "d (x \<sqinter> y) = x \<sqinter> y"
 proof (rule order.antisym)
   have "d (x \<sqinter> y) = d (x \<sqinter> y) \<sqinter> d (x \<sqinter> y)"
     by (simp add: d_test_inf_idempotent)
   also have "... \<le> x \<sqinter> d (x \<sqinter> y)"
     by (simp add: assms(1) d2 il_sub_inf_left_isotone)
   also have "... \<le> x \<sqinter> y"
     by (metis assms d_isotone il_sub_inf_right_isotone test_inf_left_below test_d_fixpoint)
   finally show "d (x \<sqinter> y) \<le> x \<sqinter> y"
     .
   show "x \<sqinter> y \<le> d (x \<sqinter> y)"
     using assms d_increasing_sub_identity dual_order.trans test_inf_left_below test_sub_identity by blast
 qed
 
 lemma test_inf_closed:
   "test x \<Longrightarrow> test y \<Longrightarrow> test (x \<sqinter> y)"
   using d_test_inf_closed test_d_fixpoint_iff by simp
 
 lemma test_sup_closed:
   "test x \<Longrightarrow> test y \<Longrightarrow> test (x \<squnion> y)"
   using test_inf_closed test_inf_closed_sup_closed by simp
 
 lemma d_export:
   assumes "test x"
     shows "d (x \<sqinter> y) = x \<sqinter> d y"
 proof (rule order.antisym)
   have 1: "d (x \<sqinter> y) \<le> x"
     by (simp add: assms d2)
   have "d (x \<sqinter> y) \<le> d y"
     by (metis assms d_isotone_var il_inf_left_unit il_inf_right_dist_sup)
   thus "d (x \<sqinter> y) \<le> x \<sqinter> d y"
     using 1 by (metis assms d_idempotent llp dual_order.trans il_sub_inf_right_isotone)
   have "y = (!x \<sqinter> y) \<squnion> (x \<sqinter> y)"
     by (metis assms il_commutative il_inf_left_unit il_inf_right_dist_sup neg_char)
   also have "... = (!x \<sqinter> y) \<squnion> (d (x \<sqinter> y) \<sqinter> x \<sqinter> y)"
     by (metis d1_eq il_inf_associative)
   also have "... = (!x \<sqinter> y) \<squnion> (d (x \<sqinter> y) \<sqinter> y)"
     using 1 by (smt calculation d1_eq il_associative il_commutative il_inf_associative il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone_var)
   also have "... = (!x \<squnion> d (x \<sqinter> y)) \<sqinter> y"
     by (simp add: il_inf_right_dist_sup)
   finally have "y \<le> (!x \<squnion> d (x \<sqinter> y)) \<sqinter> y"
     by simp
   hence "d y \<le> !x \<squnion> d (x \<sqinter> y)"
     using assms llp test_sup_closed neg_test d_closed by simp
   hence "d y \<sqinter> x \<le> d (x \<sqinter> y)"
     by (simp add: assms d_closed test_shunting)
   thus "x \<sqinter> d y \<le> d (x \<sqinter> y)"
     by (metis assms d_closed test_inf_commutative)
 qed
 
 lemma test_inf_left_dist_sup:
   assumes "test x"
       and "test y"
       and "test z"
     shows "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
 proof -
   have "x \<sqinter> (y \<squnion> z) = (y \<squnion> z) \<sqinter> x"
     using assms test_sup_closed test_inf_commutative by smt
   also have "... = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
     using il_inf_right_dist_sup by simp
   also have "... = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
     using assms test_sup_closed test_inf_commutative by smt
   finally show ?thesis
     .
 qed
 
 lemma "!x \<squnion> !y = !(!(!x \<squnion> !y))" nitpick [expect=genuine] oops
 lemma "d x = !(!x)" nitpick [expect=genuine] oops
 
 sublocale subset_boolean_algebra where uminus = "\<lambda> x . !(d x)"
 proof
   show "\<And>x y z. !(d x) \<squnion> (!(d y) \<squnion> !(d z)) = !(d x) \<squnion> !(d y) \<squnion> !(d z)"
     using il_associative by blast
   show "\<And>x y. !(d x) \<squnion> !(d y) = !(d y) \<squnion> !(d x)"
     by (simp add: il_commutative)
   show "\<And>x y. !(d x) \<squnion> !(d y) = !(d (!(d (!(d x) \<squnion> !(d y)))))"
   proof -
     fix x y
     have "test (!(d x)) \<and> test (!(d y))"
       by (simp add: d_closed neg_test)
     hence "test (!(d x) \<squnion> !(d y))"
       by (simp add: test_sup_closed)
     thus "!(d x) \<squnion> !(d y) = !(d (!(d (!(d x) \<squnion> !(d y)))))"
       by (simp add: d_neg neg_involutive test_d_fixpoint)
   qed
   show "\<And>x y. !(d x) = !(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y)))))"
   proof -
     fix x y
     have "!(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y))))) = !(d x \<squnion> !(d y)) \<squnion> !(d x \<squnion> d y)"
       using d_closed neg_test test_sup_closed neg_involutive test_d_fixpoint by auto
     also have "... = (!(d x) \<sqinter> d y) \<squnion> (!(d x) \<sqinter> !(d y))"
       using d_closed neg_test test_sup_closed neg_involutive de_morgan_2 by auto
     also have "... = !(d x) \<sqinter> (d y \<squnion> !(d y))"
       using d_closed neg_test test_inf_left_dist_sup by auto
     also have "... = !(d x) \<sqinter> top"
       by (simp add: neg_char d_closed)
     finally show "!(d x) = !(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y)))))"
       by simp
   qed
 qed
 
 lemma d_dist_sup:
   "d (x \<squnion> y) = d x \<squnion> d y"
 proof (rule order.antisym)
   have "x \<le> d x \<sqinter> x"
     by (simp add: d1)
   also have "... \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     using il_associative il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone by auto
   finally have 1: "x \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     .
   have "y \<le> d y \<sqinter> y"
     by (simp add: d1)
   also have "... \<le> (d y \<squnion> d x) \<sqinter> (y \<squnion> x)"
     using il_associative il_idempotent il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone by simp
   finally have "y \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     using il_commutative by auto
   hence "x \<squnion> y \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
     using 1 by (metis il_associative il_less_eq)
   thus "d (x \<squnion> y) \<le> d x \<squnion> d y"
     using llp test_sup_closed neg_test d_closed by simp
   show "d x \<squnion> d y \<le> d (x \<squnion> y)"
     using d_isotone_var il_associative il_commutative il_less_eq by fastforce
 qed
 
 end
 
 class pd_semiring_extended = pd_semiring + uminus +
   assumes uminus_def: "-x = !(d x)"
 begin
 
 subclass subset_boolean_algebra
   by (metis subset_boolean_algebra_axioms uminus_def ext)
 
 end
 
 subsection \<open>Domain Semirings\<close>
 
 class d_semiring = pd_semiring +
   assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
 begin
 
 lemma d3_eq: "d (x \<sqinter> d y) = d (x \<sqinter> y)"
   by (simp add: order.antisym d3 d3_conv)
 
 end
 
 text \<open>
 Axioms (d1), (d2) and (d3) are independent in IL-semirings.
 \<close>
 
 context il_semiring
 begin
 
 context
   fixes d :: "'a \<Rightarrow> 'a"
   assumes d_closed: "test (d x)"
 begin
 
 context
   assumes d1: "x \<le> d x \<sqinter> x"
   assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
 begin
 
 lemma d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)" nitpick [expect=genuine] oops
 
 end
 
 context
   assumes d1: "x \<le> d x \<sqinter> x"
   assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
 begin
 
 lemma d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p" nitpick [expect=genuine] oops
 
 end
 
 context
   assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
   assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
 begin
 
 lemma d1: "x \<le> d x \<sqinter> x" nitpick [expect=genuine] oops
 
 end
 
 end
 
 end
 
 class d_semiring_var = ppd_semiring +
   assumes d3_var: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
   assumes d_strict_eq_var: "d bot = bot"
 begin
 
 lemma d2_var:
   assumes "test p"
     shows "d (p \<sqinter> x) \<le> p"
 proof -
   have "!p \<sqinter> p \<sqinter> x = bot"
     by (simp add: assms neg_char)
   hence "d (!p \<sqinter> p \<sqinter> x) = bot"
     by (simp add: d_strict_eq_var)
   hence "d (!p \<sqinter> d (p \<sqinter> x)) = bot"
     by (metis d3_var il_inf_associative less_eq_bot)
   hence "!p \<sqinter> d (p \<sqinter> x) = bot"
     using d_bot_only by blast
   thus ?thesis
     by (metis (no_types, opaque_lifting) assms d_sub_identity il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone neg_char)
 qed
 
 subclass d_semiring
 proof
   show "\<And>p x. test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
     by (simp add: d2_var)
   show "\<And>x y. d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
     by (simp add: d3_var)
 qed
 
 end
 
 section \<open>Antidomain Semirings\<close>
 
 text \<open>
 We now develop prepreantidomain semirings, preantidomain semirings and antidomain semirings.
 See \<^cite>\<open>"DesharnaisStruth2008b" and "DesharnaisStruth2008a" and "DesharnaisStruth2011"\<close> for related work on internal axioms for antidomain.
 \<close>
 
 subsection \<open>Prepreantidomain Semirings\<close>
 
 text \<open>Definition 20\<close>
 
 class ppa_semiring = il_semiring + uminus +
   assumes a_inf_complement_bot: "-x \<sqinter> x = bot"
   assumes a_stone[simp]: "-x \<squnion> --x = top"
 begin
 
 text \<open>Theorem 21\<close>
 
 lemma l1:
   "-top = bot"
   by (metis a_inf_complement_bot il_inf_right_unit)
 
 lemma l2:
   "-bot = top"
   by (metis l1 a_stone il_unit_bot)
 
 lemma l3:
   "-x \<le> -y \<Longrightarrow> -x \<sqinter> y = bot"
   by (metis a_inf_complement_bot il_bot_unit il_inf_right_dist_sup il_less_eq)
 
 lemma l5:
   "--x \<le> --y \<Longrightarrow> -y \<le> -x"
   by (metis (mono_tags, opaque_lifting) l3 a_stone bot_least il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone sup_right_isotone)
 
 lemma l4:
   "---x = -x"
   by (metis l5 a_inf_complement_bot a_stone order.antisym bot_least il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone il_unit_bot)
 
 lemma l6:
   "-x \<sqinter> --x = bot"
   by (metis l3 l5 a_inf_complement_bot a_stone il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_less_eq il_sub_inf_right_isotone il_unit_bot)
 
 lemma l7:
   "-x \<sqinter> -y = -y \<sqinter> -x"
   using l6 a_inf_complement_bot a_stone test_inf_commutative by blast
 
 lemma l8:
   "x \<le> --x \<sqinter> x"
   by (metis a_inf_complement_bot a_stone il_idempotent il_inf_left_unit il_inf_right_dist_sup il_less_eq il_unit_bot)
 
 sublocale ppa_ppd: ppd_semiring where d = "\<lambda>x . --x"
 proof
   show "\<And>x. test (- - x)"
     using l4 l6 by force
   show "\<And>x. x \<le> - - x \<sqinter> x"
     by (simp add: l8)
 qed
 
 (*
 The following statements have counterexamples, but they take a while to find.
 
 lemma "- x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)" nitpick [card=8, expect=genuine] oops
 lemma "- x \<squnion> - y = - - (- x \<squnion> - y)" nitpick [card=8, expect=genuine] oops
 *)
 
 end
 
 subsection \<open>Preantidomain Semirings\<close>
 
 text \<open>Definition 22\<close>
 
 class pa_semiring = ppa_semiring +
   assumes pad2: "--x \<le> -(-x \<sqinter> y)"
 begin
 
 text \<open>Theorem 23\<close>
 
 lemma l10:
   "-x \<sqinter> y = bot \<Longrightarrow> -x \<le> -y"
   by (metis a_stone il_inf_left_unit il_inf_right_dist_sup il_unit_bot l4 pad2)
 
 lemma l10_iff:
   "-x \<sqinter> y = bot \<longleftrightarrow> -x \<le> -y"
   using l10 l3 by blast
 
 lemma l13:
   "--(--x \<sqinter> y) \<le> --x"
   by (metis l4 l5 pad2)
 
 lemma l14:
   "-(x \<sqinter> --y) \<le> -(x \<sqinter> y)"
   by (metis il_inf_associative l4 pad2 ppa_ppd.d1_eq)
 
 lemma l9:
   "x \<le> y \<Longrightarrow> -y \<le> -x"
   by (metis l10 a_inf_complement_bot il_commutative il_less_eq il_sub_inf_right_isotone il_unit_bot)
 
 lemma l11:
   "- x \<squnion> - y = - (- - x \<sqinter> - - y)"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     by (simp add: pad2)
   have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 7 by metis
   have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 10: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 11: "\<And>x . x \<squnion> x = x"
     by simp
   have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 12 by metis
   have 14: "\<And>x . top \<sqinter> x = x"
     by simp
   have 15: "\<And>x . x \<sqinter> top = x"
     by simp
   have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 16 by metis
   have 18: "\<And>x . bot \<sqinter> x = bot"
     by simp
   have 19: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 20: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 23: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 4 5 by metis
   have 24: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
     using 9 23 by metis
   have 25: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
     using 4 6 by metis
   have 26: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 8 9 by metis
   have 27: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 9 24 26 by metis
   have 30: "\<And>x . bot \<squnion> x = x"
     using 9 10 by metis
   have 31: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 8 11 by metis
   have 34: "\<And>u x y z . ((x \<squnion> y) \<sqinter> z) \<squnion> u = (x \<sqinter> z) \<squnion> ((y \<sqinter> z) \<squnion> u)"
     using 8 17 by metis
   have 35: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
     using 13 17 by metis
   have 36: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
     using 13 17 by metis
   have 39: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 8 19 by metis
   have 41: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
     using 13 18 20 by metis
   have 42: "- top = bot"
     using 15 20 by metis
   have 43: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 17 20 30 by metis
   have 44: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 9 17 20 30 by metis
   have 46: "\<And>x . - bot \<squnion> - - x = - bot"
     using 9 20 25 by metis
   have 50: "- bot = top"
     using 19 30 42 by metis
   have 51: "\<And>x . top \<squnion> - - x = top"
     using 46 50 by metis
   have 63: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
     using 9 15 19 26 27 by metis
   have 66: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
     using 9 20 27 30 by metis
   have 67: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
     using 11 25 27 by metis
   have 70: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
     using 9 15 27 31 51 by metis
   have 82: "\<And>x . top \<squnion> - x = top"
     using 9 19 31 by metis
   have 89: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
     using 14 17 82 by metis
   have 102: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
     using 26 70 by metis
   have 104: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 9 63 102 by metis
   have 112: "\<And>x y z . (- x \<sqinter> y) \<squnion> ((- - x \<sqinter> y) \<squnion> z) = y \<squnion> z"
     using 14 19 34 by metis
   have 117: "\<And>x y z . x \<squnion> ((x \<sqinter> - y) \<squnion> z) = x \<squnion> z"
     using 8 104 by metis
   have 120: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - z)) = y \<squnion> x"
     using 26 104 by metis
   have 124: "\<And>x . - - x \<sqinter> x = x"
     using 14 19 43 by metis
   have 128: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
     using 13 124 by metis
   have 131: "\<And>x . - x \<squnion> - - - x = - x"
     using 9 25 124 by metis
   have 133: "\<And>x . - - - x = - x"
     using 9 104 124 131 by metis
   have 135: "\<And>x y . - x \<squnion> - (- - x \<sqinter> y) = - (- - x \<sqinter> y)"
     using 25 133 by metis
   have 137: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
     using 43 133 by metis
   have 145: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
     using 20 30 35 by metis
   have 183: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
     using 17 36 124 by metis
   have 289: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 25 39 82 by metis
   have 316: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 14 43 289 by metis
   have 317: "\<And>x y z . - (- x \<sqinter> y) \<sqinter> (x \<sqinter> z) = x \<sqinter> z"
     using 13 316 by metis
   have 320: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 9 25 316 by metis
   have 321: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> x = bot"
     using 41 316 by metis
   have 374: "\<And>x y . - x \<squnion> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 25 128 133 by metis
   have 388: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
     using 128 316 by metis
   have 389: "\<And>x y . - - (x \<sqinter> y) \<sqinter> - x = bot"
     using 128 321 by metis
   have 405: "\<And>x y z . - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = - x \<sqinter> z"
     using 13 388 by metis
   have 406: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 13 388 by metis
   have 420: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
     using 316 388 by metis
   have 422: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = bot"
     using 13 18 389 by metis
   have 758: "\<And>x y z . x \<squnion> (x \<sqinter> (- y \<sqinter> - z)) = x"
     using 13 104 117 by metis
   have 1092: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
     using 9 30 31 66 by metis
   have 1130: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
     using 17 30 1092 by metis
   have 1156: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
     using 67 104 124 133 by metis
   have 2098: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
     using 14 19 1130 by metis
   have 2125: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
     using 9 2098 by metis
   have 2138: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
     using 9 289 2098 by metis
   have 2139: "\<And>x y . - x \<sqinter> - (x \<squnion> y) = - (x \<squnion> y)"
     using 316 2098 by metis
   have 2192: "\<And>x y . - - x \<sqinter> (- y \<sqinter> x) = - y \<sqinter> x"
     using 89 2125 by metis
   have 2202: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
     using 9 289 2125 by metis
   have 2344: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
     using 89 2202 by metis
   have 2547: "\<And>x y z . - x \<squnion> ((- - x \<sqinter> - y) \<squnion> z) = - x \<squnion> (- y \<squnion> z)"
     using 112 117 by metis
   have 3023: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
     using 9 133 2344 by metis
   have 3134: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
     using 14 43 3023 by metis
   have 3135: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
     using 14 44 3023 by metis
   have 3962: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
     using 14 137 2138 by metis
   have 5496: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> - (x \<squnion> z) = bot"
     using 422 2139 by metis
   have 9414: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
     using 9 104 183 320 by metis
   have 9520: "\<And>x y z . - - (- x \<sqinter> y) \<sqinter> - - (x \<sqinter> z) = bot"
     using 374 5496 by metis
   have 11070: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> (- x \<sqinter> - z) = - (- - x \<sqinter> y)"
     using 317 758 by metis
   have 12371: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
     using 133 1156 by metis
   have 12377: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
     using 128 133 1156 by metis
   have 12384: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
     using 133 1156 2125 by metis
   have 12394: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
     using 1156 3134 9414 by metis
   have 12640: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
     using 89 12384 by metis
   have 24648: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
     using 19 12394 by metis
   have 28270: "\<And>x y z . - - (x \<sqinter> y) \<squnion> - (- x \<sqinter> z) = - (- x \<sqinter> z)"
     using 374 405 by metis
   have 28339: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
     using 124 406 12371 by metis
   have 28423: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
     using 13 3135 12394 28339 by metis
   have 28487: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
     using 2098 3962 12394 28423 by metis
   have 52423: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 145 24648 28487 by metis
   have 52522: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
     using 13 12377 12394 12640 28487 52423 by metis
   have 61103: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> z = - x \<squnion> (- y \<squnion> z)"
     using 112 2547 12371 52522 by metis
   have 61158: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
     using 420 52522 by metis
   have 61231: "\<And>x y z . - x \<sqinter> (- - y \<sqinter> - (x \<sqinter> z)) = - x \<sqinter> - - y"
     using 13 15 50 133 9520 52522 61158 by metis
   have 61313: "\<And>x y . - x \<squnion> - y = - (- - y \<sqinter> x)"
     using 120 11070 61103 by metis
   have 61393: "\<And>x y . - (- x \<sqinter> - - y) = - (- x \<sqinter> y)"
     using 13 28270 61158 61231 61313 by metis
   have 61422: "\<And>x y . - (- - x \<sqinter> y) = - (- - y \<sqinter> x)"
     using 13 135 2192 61158 61313 by metis
   show ?thesis
     using 61313 61393 61422 by metis
 qed
 
 lemma l12:
   "- x \<sqinter> - y = - (x \<squnion> y)"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     by (simp add: pad2)
   have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 7 by metis
   have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 10: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 11: "\<And>x . x \<squnion> x = x"
     by simp
   have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 12 by metis
   have 14: "\<And>x . top \<sqinter> x = x"
     by simp
   have 15: "\<And>x . x \<sqinter> top = x"
     by simp
   have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 16 by metis
   have 18: "\<And>x . bot \<sqinter> x = bot"
     by simp
   have 19: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 20: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 22: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 4 5 by metis
   have 23: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
     using 9 22 by metis
   have 24: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
     using 4 6 by metis
   have 25: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 8 9 by metis
   have 26: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 9 23 25 by metis
   have 29: "\<And>x . bot \<squnion> x = x"
     using 9 10 by metis
   have 30: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 8 11 by metis
   have 32: "\<And>x y . x \<squnion> (y \<squnion> x) = y \<squnion> x"
     using 8 9 11 by metis
   have 33: "\<And>u x y z . ((x \<squnion> y) \<sqinter> z) \<squnion> u = (x \<sqinter> z) \<squnion> ((y \<sqinter> z) \<squnion> u)"
     using 8 17 by metis
   have 34: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
     using 13 17 by metis
   have 35: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
     using 13 17 by metis
   have 36: "\<And>x y . (top \<squnion> x) \<sqinter> y = y \<squnion> (x \<sqinter> y)"
     using 14 17 by metis
   have 37: "\<And>x y . (x \<squnion> top) \<sqinter> y = y \<squnion> (x \<sqinter> y)"
     using 9 14 17 by metis
   have 38: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 8 19 by metis
   have 40: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
     using 13 18 20 by metis
   have 41: "- top = bot"
     using 15 20 by metis
   have 42: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 17 20 29 by metis
   have 43: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 9 17 20 29 by metis
   have 45: "\<And>x . - bot \<squnion> - - x = - bot"
     using 9 20 24 by metis
   have 46: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<squnion> (u \<sqinter> y)) = z \<squnion> ((x \<squnion> u) \<sqinter> y)"
     using 17 25 by metis
   have 47: "\<And>x y . - x \<squnion> (y \<squnion> - - x) = y \<squnion> top"
     using 19 25 by metis
   have 49: "- bot = top"
     using 19 29 41 by metis
   have 50: "\<And>x . top \<squnion> - - x = top"
     using 45 49 by metis
   have 54: "\<And>u x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> ((x \<sqinter> (y \<squnion> z)) \<squnion> u)) = (x \<sqinter> (y \<squnion> z)) \<squnion> u"
     using 8 26 by metis
   have 58: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> ((x \<sqinter> (y \<sqinter> u)) \<squnion> (x \<sqinter> (y \<sqinter> (z \<squnion> u)))) = x \<sqinter> (y \<sqinter> (z \<squnion> u))"
     using 13 26 by metis
   have 60: "\<And>x y . x \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> top))) = x \<sqinter> (y \<squnion> top)"
     using 15 25 26 by metis
   have 62: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
     using 9 15 19 25 26 by metis
   have 65: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
     using 9 20 26 29 by metis
   have 66: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
     using 11 24 26 by metis
   have 69: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
     using 9 15 26 30 50 by metis
   have 81: "\<And>x . top \<squnion> - x = top"
     using 9 19 30 by metis
   have 82: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 11 26 30 by metis
   have 83: "\<And>x y . x \<squnion> (x \<sqinter> (y \<squnion> top)) = x \<sqinter> (y \<squnion> top)"
     using 60 82 by metis
   have 88: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
     using 14 17 81 by metis
   have 89: "\<And>x y . top \<squnion> (x \<squnion> - y) = x \<squnion> top"
     using 25 81 by metis
   have 91: "\<And>x y z . x \<squnion> (y \<squnion> (z \<squnion> x)) = y \<squnion> (z \<squnion> x)"
     using 8 32 by metis
   have 94: "\<And>x y z . x \<squnion> (y \<squnion> (- z \<sqinter> x)) = y \<squnion> x"
     using 25 88 by metis
   have 101: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
     using 25 69 by metis
   have 102: "\<And>x . x \<squnion> (x \<sqinter> bot) = x"
     using 41 49 69 by metis
   have 103: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 9 62 101 by metis
   have 109: "\<And>x y . x \<squnion> (y \<squnion> (x \<sqinter> bot)) = y \<squnion> x"
     using 25 102 by metis
   have 111: "\<And>x y z . (- x \<sqinter> y) \<squnion> ((- - x \<sqinter> y) \<squnion> z) = y \<squnion> z"
     using 14 19 33 by metis
   have 116: "\<And>x y z . x \<squnion> ((x \<sqinter> - y) \<squnion> z) = x \<squnion> z"
     using 8 103 by metis
   have 119: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - z)) = y \<squnion> x"
     using 25 103 by metis
   have 123: "\<And>x . - - x \<sqinter> x = x"
     using 14 19 42 by metis
   have 127: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
     using 13 123 by metis
   have 130: "\<And>x . - x \<squnion> - - - x = - x"
     using 9 24 123 by metis
   have 132: "\<And>x . - - - x = - x"
     using 9 103 123 130 by metis
   have 134: "\<And>x y . - x \<squnion> - (- - x \<sqinter> y) = - (- - x \<sqinter> y)"
     using 24 132 by metis
   have 136: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
     using 42 132 by metis
   have 138: "\<And>x . - x \<sqinter> - x = - x"
     using 123 132 by metis
   have 144: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
     using 20 29 34 by metis
   have 157: "\<And>x y . (- x \<squnion> y) \<sqinter> - x = (top \<squnion> y) \<sqinter> - x"
     using 17 36 138 by metis
   have 182: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
     using 17 35 123 by metis
   have 288: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 24 38 81 by metis
   have 315: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 14 42 288 by metis
   have 316: "\<And>x y z . - (- x \<sqinter> y) \<sqinter> (x \<sqinter> z) = x \<sqinter> z"
     using 13 315 by metis
   have 319: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 9 24 315 by metis
   have 320: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> x = bot"
     using 40 315 by metis
   have 373: "\<And>x y . - x \<squnion> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 24 127 132 by metis
   have 387: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
     using 127 315 by metis
   have 388: "\<And>x y . - - (x \<sqinter> y) \<sqinter> - x = bot"
     using 127 320 by metis
   have 404: "\<And>x y z . - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = - x \<sqinter> z"
     using 13 387 by metis
   have 405: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 13 387 by metis
   have 419: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
     using 315 387 by metis
   have 420: "\<And>x y . - - x \<sqinter> - - (x \<sqinter> y) = - - (x \<sqinter> y)"
     using 387 by metis
   have 421: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = bot"
     using 13 18 388 by metis
   have 536: "\<And>x y . (x \<squnion> - - y) \<sqinter> y = (x \<squnion> top) \<sqinter> y"
     using 42 47 by metis
   have 662: "\<And>u x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> (z \<squnion> y)) \<squnion> u) = (x \<sqinter> (z \<squnion> y)) \<squnion> u"
     using 9 32 54 by metis
   have 705: "\<And>u x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> (y \<squnion> (z \<sqinter> bot))) \<squnion> u) = (x \<sqinter> (y \<squnion> z)) \<squnion> u"
     using 25 54 109 662 by metis
   have 755: "\<And>x y z . (x \<sqinter> - y) \<squnion> (z \<squnion> x) = z \<squnion> x"
     using 32 91 116 by metis
   have 757: "\<And>x y z . x \<squnion> (x \<sqinter> (- y \<sqinter> - z)) = x"
     using 13 103 116 by metis
   have 930: "\<And>x y z . (- (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> y)) \<squnion> (- (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> z)) = bot"
     using 9 20 29 58 by metis
   have 1091: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
     using 9 29 30 65 by metis
   have 1092: "\<And>x y . - (x \<squnion> y) \<sqinter> y = bot"
     using 29 30 65 1091 by metis
   have 1113: "\<And>u x y z . - (x \<squnion> ((y \<squnion> z) \<sqinter> u)) \<sqinter> (x \<squnion> (z \<sqinter> u)) = bot"
     using 29 46 65 1091 by metis
   have 1117: "\<And>x y z . - (x \<squnion> y) \<sqinter> (x \<squnion> (- z \<sqinter> y)) = bot"
     using 29 65 94 1092 by metis
   have 1128: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<sqinter> (x \<squnion> y) = bot"
     using 8 1091 by metis
   have 1129: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
     using 17 29 1091 by metis
   have 1155: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
     using 66 103 123 132 by metis
   have 1578: "\<And>x y z . - (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> y) = bot"
     using 82 1091 by metis
   have 1594: "\<And>x y z . - (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> z) = bot"
     using 29 930 1578 by metis
   have 2094: "\<And>x y z . - (x \<squnion> (y \<sqinter> (z \<squnion> top))) \<sqinter> (x \<squnion> y) = bot"
     using 83 1128 by metis
   have 2097: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
     using 14 19 1129 by metis
   have 2124: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
     using 9 2097 by metis
   have 2135: "\<And>x y . - - ((top \<squnion> x) \<sqinter> y) \<sqinter> y = y"
     using 36 2097 by metis
   have 2136: "\<And>x y . - - ((x \<squnion> top) \<sqinter> y) \<sqinter> y = y"
     using 37 2097 by metis
   have 2137: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
     using 9 288 2097 by metis
   have 2138: "\<And>x y . - x \<sqinter> - (x \<squnion> y) = - (x \<squnion> y)"
     using 315 2097 by metis
   have 2151: "\<And>x y . - x \<squnion> - (x \<squnion> y) = - x"
     using 9 132 373 2097 by metis
   have 2191: "\<And>x y . - - x \<sqinter> (- y \<sqinter> x) = - y \<sqinter> x"
     using 88 2124 by metis
   have 2201: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
     using 9 288 2124 by metis
   have 2202: "\<And>x y . - x \<sqinter> - (y \<squnion> x) = - (y \<squnion> x)"
     using 315 2124 by metis
   have 2320: "\<And>x y . - (x \<sqinter> (y \<squnion> top)) = - x"
     using 83 373 2151 by metis
   have 2343: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
     using 88 2201 by metis
   have 2546: "\<And>x y z . - x \<squnion> ((- - x \<sqinter> - y) \<squnion> z) = - x \<squnion> (- y \<squnion> z)"
     using 111 116 by metis
   have 2706: "\<And>x y z . - x \<squnion> (y \<squnion> - - ((top \<squnion> z) \<sqinter> - x)) = y \<squnion> - - ((top \<squnion> z) \<sqinter> - x)"
     using 755 2135 by metis
   have 2810: "\<And>x y . - x \<sqinter> - ((y \<squnion> top) \<sqinter> x) = - ((y \<squnion> top) \<sqinter> x)"
     using 315 2136 by metis
   have 3022: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
     using 9 132 2343 by metis
   have 3133: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
     using 14 42 3022 by metis
   have 3134: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
     using 14 43 3022 by metis
   have 3961: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
     using 14 136 2137 by metis
   have 4644: "\<And>x y z . - (x \<sqinter> - y) \<sqinter> (x \<sqinter> - (y \<squnion> z)) = bot"
     using 1594 2151 by metis
   have 5495: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> - (x \<squnion> z) = bot"
     using 421 2138 by metis
   have 9413: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
     using 9 103 182 319 by metis
   have 9519: "\<And>x y z . - - (- x \<sqinter> y) \<sqinter> - - (x \<sqinter> z) = bot"
     using 373 5495 by metis
   have 11069: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> (- x \<sqinter> - z) = - (- - x \<sqinter> y)"
     using 316 757 by metis
   have 12370: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
     using 132 1155 by metis
   have 12376: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
     using 127 132 1155 by metis
   have 12383: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
     using 132 1155 2124 by metis
   have 12393: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
     using 1155 3133 9413 by metis
   have 12407: "\<And>x y . - - x \<sqinter> - - (x \<squnion> y) = - - x"
     using 1155 2138 by metis
   have 12639: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
     using 88 12383 by metis
   have 24647: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
     using 19 12393 by metis
   have 28269: "\<And>x y z . - - (x \<sqinter> y) \<squnion> - (- x \<sqinter> z) = - (- x \<sqinter> z)"
     using 373 404 by metis
   have 28338: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
     using 123 405 12370 by metis
   have 28422: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
     using 13 3134 12393 28338 by metis
   have 28485: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
     using 2097 3961 12393 28422 by metis
   have 30411: "\<And>x y . - x \<sqinter> (x \<squnion> (x \<sqinter> y)) = bot"
     using 9 82 2094 2320 by metis
   have 30469: "\<And>x . - x \<sqinter> (x \<squnion> - - x) = bot"
     using 9 123 132 30411 by metis
   have 37513: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> - (y \<squnion> x) = bot"
     using 2202 4644 by metis
   have 52421: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 144 24647 28485 by metis
   have 52520: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
     using 13 12376 12393 12639 28485 52421 by metis
   have 52533: "\<And>x y z . - - (x \<squnion> (y \<sqinter> (z \<squnion> top))) \<sqinter> (x \<squnion> y) = x \<squnion> y"
     using 15 49 2094 52421 by metis
   have 61101: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> z = - x \<squnion> (- y \<squnion> z)"
     using 111 2546 12370 52520 by metis
   have 61156: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
     using 419 52520 by metis
   have 61162: "\<And>x y . - (x \<squnion> (x \<sqinter> y)) = - x"
     using 15 49 2138 30411 52520 by metis
   have 61163: "\<And>x . - (x \<squnion> - - x) = - x"
     using 15 49 2138 30469 52520 by metis
   have 61229: "\<And>x y z . - x \<sqinter> (- - y \<sqinter> - (x \<sqinter> z)) = - x \<sqinter> - - y"
     using 13 15 49 132 9519 52520 61156 by metis
   have 61311: "\<And>x y . - x \<squnion> - y = - (- - y \<sqinter> x)"
     using 119 11069 61101 by metis
   have 61391: "\<And>x y . - (- x \<sqinter> - - y) = - (- x \<sqinter> y)"
     using 13 28269 61156 61229 61311 by metis
   have 61420: "\<And>x y . - (- - x \<sqinter> y) = - (- - y \<sqinter> x)"
     using 13 134 2191 61156 61311 by metis
   have 61454: "\<And>x y . - (x \<squnion> - (- y \<sqinter> - x)) = - y \<sqinter> - x"
     using 9 132 3133 61156 61162 by metis
   have 61648: "\<And>x y . - x \<sqinter> (x \<squnion> (- y \<sqinter> - - x)) = bot"
     using 1117 61163 by metis
   have 62434: "\<And>x y . - (- - x \<sqinter> y) \<sqinter> x = - y \<sqinter> x"
     using 43 61311 by metis
   have 63947: "\<And>x y . - (- x \<sqinter> y) \<sqinter> - (- y \<squnion> x) = bot"
     using 37513 61391 by metis
   have 64227: "\<And>x y . - (x \<squnion> (- y \<sqinter> - - x)) = - x"
     using 15 49 2138 52520 61648 by metis
   have 64239: "\<And>x y . - (x \<squnion> (- - x \<squnion> y)) = - (x \<squnion> y)"
     using 9 25 12407 64227 by metis
   have 64241: "\<And>x y . - (x \<squnion> (- - x \<sqinter> - y)) = - x"
     using 28485 64227 by metis
   have 64260: "\<And>x y . - (x \<squnion> - - (x \<sqinter> y)) = - x"
     using 420 64241 by metis
   have 64271: "\<And>x y . - (- x \<squnion> (y \<squnion> - - (y \<sqinter> x))) = - (- x \<squnion> y)"
     using 9 25 42 64260 by metis
   have 64281: "\<And>x y . - (- x \<squnion> y) = - (y \<squnion> - - ((top \<squnion> y) \<sqinter> - x))"
     using 9 25 157 2706 64260 by metis
   have 64282: "\<And>x y . - (x \<squnion> - - ((x \<squnion> top) \<sqinter> y)) = - (x \<squnion> - - y)"
     using 9 25 132 536 2810 28485 61311 64260 by metis
   have 65110: "\<And>x y . - ((- x \<sqinter> y) \<squnion> (- y \<squnion> x)) = bot"
     using 9 14 49 37513 63947 by metis
   have 65231: "\<And>x y . - (x \<squnion> ((- x \<sqinter> y) \<squnion> - y)) = bot"
     using 9 25 65110 by metis
   have 65585: "\<And>x y . - (x \<squnion> - y) = - - y \<sqinter> - x"
     using 61311 61454 64239 by metis
   have 65615: "\<And>x y . - x \<sqinter> - ((x \<squnion> top) \<sqinter> y) = - y \<sqinter> - x"
     using 132 28485 64282 65585 by metis
   have 65616: "\<And>x y . - (- x \<squnion> y) = - y \<sqinter> - ((top \<squnion> y) \<sqinter> - x)"
     using 132 28485 64281 65585 by metis
   have 65791: "\<And>x y . - x \<sqinter> - ((top \<squnion> x) \<sqinter> - y) = - - y \<sqinter> - x"
     using 89 132 12376 28485 64271 65585 65615 65616 by metis
   have 65933: "\<And>x y . - (- x \<squnion> y) = - - x \<sqinter> - y"
     using 65616 65791 by metis
   have 66082: "\<And>x y z . - (x \<squnion> (y \<squnion> - z)) = - - z \<sqinter> - (x \<squnion> y)"
     using 8 65585 by metis
   have 66204: "\<And>x y . - - x \<sqinter> - (y \<squnion> (- y \<sqinter> x)) = bot"
     using 65231 66082 by metis
   have 66281: "\<And>x y z . - (x \<squnion> (- y \<squnion> z)) = - - y \<sqinter> - (x \<squnion> z)"
     using 25 65933 by metis
   have 67527: "\<And>x y . - - (x \<squnion> (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 49 62434 66204 by metis
   have 67762: "\<And>x y . - (- - x \<sqinter> (y \<squnion> (- y \<sqinter> x))) = - x"
     using 61420 67527 by metis
   have 68018: "\<And>x y z . - (x \<squnion> y) \<sqinter> (x \<squnion> (y \<sqinter> (z \<squnion> top))) = bot"
     using 8 83 1113 2320 by metis
   have 71989: "\<And>x y z . - (x \<squnion> (y \<sqinter> (z \<squnion> top))) = - (x \<squnion> y)"
     using 9 29 52533 67762 68018 by metis
   have 71997: "\<And>x y z . - ((x \<sqinter> (y \<squnion> top)) \<squnion> z) = - (x \<squnion> z)"
     using 17 2320 71989 by metis
   have 72090: "\<And>x y z . - (x \<squnion> ((x \<sqinter> y) \<squnion> z)) = - (x \<squnion> z)"
     using 10 14 705 71997 by metis
   have 72139: "\<And>x y . - (x \<squnion> y) = - x \<sqinter> - y"
     using 25 123 132 2138 65933 66281 72090 by metis
   show ?thesis
     using 72139 by metis
 qed
 
 lemma l15:
   "--(x \<squnion> y) = --x \<squnion> --y"
   by (simp add: l11 l12 l4)
 
 lemma l13_var:
   "- - (- x \<sqinter> y) = - x \<sqinter> - - y"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     by (simp add: pad2)
   have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 7 by metis
   have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 10: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 11: "\<And>x . x \<squnion> x = x"
     by simp
   have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 12 by metis
   have 14: "\<And>x . top \<sqinter> x = x"
     by simp
   have 15: "\<And>x . x \<sqinter> top = x"
     by simp
   have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 16 by metis
   have 19: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 20: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 22: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
     using 4 5 by metis
   have 23: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
     using 9 22 by metis
   have 24: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
     using 4 6 by metis
   have 25: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 8 9 by metis
   have 26: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 9 23 25 by metis
   have 29: "\<And>x . bot \<squnion> x = x"
     using 9 10 by metis
   have 30: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 8 11 by metis
   have 34: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
     using 13 17 by metis
   have 35: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
     using 13 17 by metis
   have 38: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 8 19 by metis
   have 41: "- top = bot"
     using 15 20 by metis
   have 42: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 17 20 29 by metis
   have 43: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 9 17 20 29 by metis
   have 45: "\<And>x . - bot \<squnion> - - x = - bot"
     using 9 20 24 by metis
   have 49: "- bot = top"
     using 19 29 41 by metis
   have 50: "\<And>x . top \<squnion> - - x = top"
     using 45 49 by metis
   have 62: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
     using 9 15 19 25 26 by metis
   have 65: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
     using 9 20 26 29 by metis
   have 66: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
     using 11 24 26 by metis
   have 69: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
     using 9 15 26 30 50 by metis
   have 81: "\<And>x . top \<squnion> - x = top"
     using 9 19 30 by metis
   have 88: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
     using 14 17 81 by metis
   have 101: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
     using 25 69 by metis
   have 103: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 9 62 101 by metis
   have 123: "\<And>x . - - x \<sqinter> x = x"
     using 14 19 42 by metis
   have 127: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
     using 13 123 by metis
   have 130: "\<And>x . - x \<squnion> - - - x = - x"
     using 9 24 123 by metis
   have 132: "\<And>x . - - - x = - x"
     using 9 103 123 130 by metis
   have 136: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
     using 42 132 by metis
   have 144: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
     using 20 29 34 by metis
   have 182: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
     using 17 35 123 by metis
   have 288: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 24 38 81 by metis
   have 315: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 14 42 288 by metis
   have 319: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 9 24 315 by metis
   have 387: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
     using 127 315 by metis
   have 405: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
     using 13 387 by metis
   have 419: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
     using 315 387 by metis
   have 1091: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
     using 9 29 30 65 by metis
   have 1129: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
     using 17 29 1091 by metis
   have 1155: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
     using 66 103 123 132 by metis
   have 2097: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
     using 14 19 1129 by metis
   have 2124: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
     using 9 2097 by metis
   have 2137: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
     using 9 288 2097 by metis
   have 2201: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
     using 9 288 2124 by metis
   have 2343: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
     using 88 2201 by metis
   have 3022: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
     using 9 132 2343 by metis
   have 3133: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
     using 14 42 3022 by metis
   have 3134: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
     using 14 43 3022 by metis
   have 3961: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
     using 14 136 2137 by metis
   have 9413: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
     using 9 103 182 319 by metis
   have 12370: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
     using 132 1155 by metis
   have 12376: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
     using 127 132 1155 by metis
   have 12383: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
     using 132 1155 2124 by metis
   have 12393: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
     using 1155 3133 9413 by metis
   have 12639: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
     using 88 12383 by metis
   have 24647: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
     using 19 12393 by metis
   have 28338: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
     using 123 405 12370 by metis
   have 28422: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
     using 13 3134 12393 28338 by metis
   have 28485: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
     using 2097 3961 12393 28422 by metis
   have 52421: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
     using 14 144 24647 28485 by metis
   have 52520: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
     using 13 12376 12393 12639 28485 52421 by metis
   have 61156: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
     using 419 52520 by metis
   show ?thesis
     using 61156 by metis
 qed
 
 text \<open>Theorem 25.1\<close>
 
 subclass subset_boolean_algebra_2
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: il_associative)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x y. x \<squnion> - (y \<squnion> - y) = x"
     using il_bot_unit l12 l6 by auto
   show "\<And>x y. - (x \<squnion> y) = - (- - x \<squnion> - - y)"
     by (metis l15 l4)
   show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
     by (smt l11 l15 il_inf_right_dist_sup il_unit_bot l6 l7)
 qed
 
 lemma aa_test:
   "p = --p \<Longrightarrow> test p"
   by (metis ppa_ppd.d_closed)
 
 lemma test_aa_increasing:
   "test p \<Longrightarrow> p \<le> --p"
   by (simp add: ppa_ppd.d_increasing_sub_identity test_sub_identity)
 
 lemma "test p \<Longrightarrow> - - (p \<sqinter> x) \<le> p" nitpick [expect=genuine] oops
 lemma "test p \<Longrightarrow> --p \<le> p" nitpick [expect=genuine] oops
 
 end
 
 class pa_algebra = pa_semiring + minus +
   assumes pa_minus_def: "-x - -y = -(--x \<squnion> -y)"
 begin
 
 subclass subset_boolean_algebra_2_extended
 proof
   show "bot = (THE x. \<forall>z. x = - (z \<squnion> - z))"
     using l12 l6 by auto
   thus "top = - (THE x. \<forall>z. x = - (z \<squnion> - z))"
     using l2 by blast
   show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
     by (metis l12 l4)
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: pa_minus_def)
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: il_less_eq)
   show "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
     by (simp add: il_less_eq less_le_not_le)
 qed
 
 lemma "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)" nitpick [expect=genuine] oops
 
 end
 
 subsection \<open>Antidomain Semirings\<close>
 
 text \<open>Definition 24\<close>
 
 class a_semiring = ppa_semiring +
   assumes ad3: "-(x \<sqinter> y) \<le> -(x \<sqinter> --y)"
 begin
 
 lemma l16:
   "- - x \<le> - (- x \<sqinter> y)"
 proof -
   have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
     by (simp add: il_less_eq)
   have 3: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
     by (simp add: il_associative)
   have 4: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
     using 3 by metis
   have 5: "\<And>x y . x \<squnion> y = y \<squnion> x"
     by (simp add: il_commutative)
   have 6: "\<And>x . x \<squnion> bot = x"
     by (simp add: il_bot_unit)
   have 7: "\<And>x . x \<squnion> x = x"
     by simp
   have 8: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
     using 1 by metis
   have 9: "\<And>x y . x \<le> y \<or> x \<squnion> y \<noteq> y"
     using 1 by metis
   have 10: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
     by (simp add: il_inf_associative)
   have 11: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
     using 10 by metis
   have 12: "\<And>x . top \<sqinter> x = x"
     by simp
   have 13: "\<And>x . x \<sqinter> top = x"
     by simp
   have 14: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
     by (simp add: il_sub_inf_right_isotone_var)
   have 15: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
     by (simp add: il_inf_right_dist_sup)
   have 16: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
     using 15 by metis
   have 17: "\<And>x . bot \<sqinter> x = bot"
     by simp
   have 18: "\<And>x . - x \<squnion> - - x = top"
     by simp
   have 19: "\<And>x . - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   have 20: "\<And>x y . - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
     by (simp add: ad3)
   have 22: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
     using 4 5 by metis
   have 25: "\<And>x . bot \<squnion> x = x"
     using 5 6 by metis
   have 26: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
     using 4 7 by metis
   have 33: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
     using 5 8 14 22 by metis
   have 47: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
     using 4 18 by metis
   have 48: "\<And>x y . - - x \<squnion> (y \<squnion> - x) = y \<squnion> top"
     using 4 5 18 by metis
   have 51: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
     using 11 17 19 by metis
   have 52: "- top = bot"
     using 13 19 by metis
   have 56: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
     using 16 19 25 by metis
   have 57: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
     using 5 16 19 25 by metis
   have 58: "\<And>x y . - (x \<sqinter> y) \<squnion> - (x \<sqinter> - - y) = - (x \<sqinter> - - y)"
     using 8 20 by metis
   have 60: "\<And>x . - x \<le> - - - x"
     using 12 20 by metis
   have 69: "- bot = top"
     using 18 25 52 by metis
   have 74: "\<And>x y . x \<le> x \<squnion> y"
     using 9 26 by metis
   have 78: "\<And>x . top \<squnion> - x = top"
     using 5 18 26 by metis
   have 80: "\<And>x y . x \<le> y \<squnion> x"
     using 5 74 by metis
   have 86: "\<And>x y z . x \<squnion> y \<le> x \<squnion> (z \<squnion> y)"
     using 22 80 by metis
   have 95: "\<And>x . - x \<squnion> - - - x = - - - x"
     using 8 60 by metis
   have 143: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
     using 5 13 26 33 78 by metis
   have 370: "\<And>x y z . x \<squnion> (y \<sqinter> - z) \<le> x \<squnion> y"
     using 86 143 by metis
   have 907: "\<And>x . - x \<sqinter> - x = - x"
     using 12 18 57 by metis
   have 928: "\<And>x y . - x \<sqinter> (- x \<sqinter> y) = - x \<sqinter> y"
     using 11 907 by metis
   have 966: "\<And>x y . - (- x \<sqinter> - - (x \<sqinter> y)) = top"
     using 51 58 69 78 by metis
   have 1535: "\<And>x . - x \<squnion> - - - - x = top"
     using 47 78 95 by metis
   have 1630: "\<And>x y z . (x \<squnion> y) \<sqinter> - z \<le> (x \<sqinter> - z) \<squnion> y"
     using 16 370 by metis
   have 2422: "\<And>x . - x \<sqinter> - - - x = - - - x"
     using 12 57 1535 by metis
   have 6567: "\<And>x y . - x \<sqinter> - - (x \<sqinter> y) = bot"
     using 12 19 966 by metis
   have 18123: "\<And>x . - - - x = - x"
     using 95 143 2422 by metis
   have 26264: "\<And>x y . - x \<le> (- y \<sqinter> - x) \<squnion> - - y"
     using 12 18 1630 by metis
   have 26279: "\<And>x y . - - (x \<sqinter> y) \<le> - - x"
     using 25 6567 26264 by metis
   have 26307: "\<And>x y . - - (- x \<sqinter> y) \<le> - x"
     using 928 18123 26279 by metis
   have 26339: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
     using 5 8 26307 by metis
   have 26564: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
     using 5 48 78 18123 26339 by metis
   have 26682: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
     using 12 56 26564 by metis
   have 26864: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
     using 18123 26279 26682 by metis
   show ?thesis
     using 26864 by metis
 qed
 
 text \<open>Theorem 25.2\<close>
 
 subclass pa_semiring
 proof
   show "\<And>x y. - - x \<le> - (- x \<sqinter> y)"
     by (rule l16)
 qed
 
 lemma l17:
   "-(x \<sqinter> y) = -(x \<sqinter> --y)"
   by (simp add: ad3 order.antisym l14)
 
 lemma a_complement_inf_double_complement:
   "-(x \<sqinter> --y) = -(x \<sqinter> y)"
   using l17 by auto
 
 sublocale a_d: d_semiring_var where d = "\<lambda>x . --x"
 proof
   show "\<And>x y. - - (x \<sqinter> - - y) \<le> - - (x \<sqinter> y)"
     using l17 by auto
   show "- - bot = bot"
     by (simp add: l1 l2)
 qed
 
 lemma "test p \<Longrightarrow> - - (p \<sqinter> x) \<le> p"
   by (fact a_d.d2)
 
 end
 
 class a_algebra = a_semiring + minus +
   assumes a_minus_def: "-x - -y = -(--x \<squnion> -y)"
 begin
 
 subclass pa_algebra
 proof
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: a_minus_def)
 qed
 
 text \<open>Theorem 25.4\<close>
 
 subclass subset_boolean_algebra_4_extended
 proof
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: il_inf_associative)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: il_inf_right_dist_sup)
   show "\<And>x. - x \<sqinter> x = bot"
     by (simp add: a_inf_complement_bot)
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)"
     using l17 by auto
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     by (simp add: il_sub_inf_right_isotone)
 qed
 
 end
 
 context subset_boolean_algebra_4_extended
 begin
 
 subclass il_semiring
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sup_assoc)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x. x \<squnion> bot = x"
     by simp
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: sba3_inf_associative)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: sba3_inf_right_dist_sup)
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x. bot \<sqinter> x = bot"
     by (simp add: inf_left_zero)
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     by (simp add: inf_right_isotone)
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_le_not_le)
 qed
 
 subclass a_semiring
 proof
   show "\<And>x. - x \<sqinter> x = bot"
     by (simp add: sba3_inf_complement_bot)
   show "\<And>x. - x \<squnion> - - x = top"
     by simp
   show "\<And>x y. - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
     by (simp add: sba3_complement_inf_double_complement)
 qed
 
 sublocale sba4_a: a_algebra
 proof
   show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
     by (simp add: sub_minus_def)
 qed
 
 end
 
 context stone_algebra
 begin
 
 text \<open>Theorem 25.3\<close>
 
 subclass il_semiring
 proof
   show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
     by (simp add: sup_assoc)
   show "\<And>x y. x \<squnion> y = y \<squnion> x"
     by (simp add: sup_commute)
   show "\<And>x. x \<squnion> x = x"
     by simp
   show "\<And>x. x \<squnion> bot = x"
     by simp
   show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
     by (simp add: inf.sup_monoid.add_assoc)
   show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
     by (simp add: inf_sup_distrib2)
   show "\<And>x. top \<sqinter> x = x"
     by simp
   show "\<And>x. x \<sqinter> top = x"
     by simp
   show "\<And>x. bot \<sqinter> x = bot"
     by simp
   show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
     using inf.sup_right_isotone by blast
   show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
     by (simp add: le_iff_sup)
   show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_le_not_le)
 qed
 
 subclass a_semiring
 proof
   show "\<And>x. - x \<sqinter> x = bot"
     by simp
   show "\<And>x. - x \<squnion> - - x = top"
     by simp
   show "\<And>x y. - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
     by simp
 qed
 
 end
 
 end
 
diff --git a/thys/Suppes_Theorem/Suppes_Theorem.thy b/thys/Suppes_Theorem/Suppes_Theorem.thy
--- a/thys/Suppes_Theorem/Suppes_Theorem.thy
+++ b/thys/Suppes_Theorem/Suppes_Theorem.thy
@@ -1,597 +1,597 @@
 chapter \<open> Suppes' Theorem \label{sec:suppes-theorem} \<close>
 
 theory Suppes_Theorem
   imports Probability_Logic
 begin
 
 no_notation FuncSet.funcset (infixr "\<rightarrow>" 60)
 
 text \<open> An elementary completeness theorem for inequalities for probability logic
        is due to Patrick Suppes @{cite suppesProbabilisticInferenceConcept1966}. \<close>
 
 text \<open> A consequence of this Suppes' theorem is an elementary form of \<^emph>\<open>collapse\<close>,
        which asserts that inequalities for probabilities are logically
        equivalent to the more restricted class of \<^emph>\<open>Dirac measures\<close> as
        defined in \S\ref{sec:dirac-measures}. \<close>
 
 section \<open> Suppes' List Theorem \label{sec:suppes-theorem-for-lists} \<close>
 
 text \<open> We first establish Suppes' theorem for lists of propositions. This
        is done by establishing our first completeness theorem using
        \<^emph>\<open>Dirac measures\<close>. \<close>
 
 text \<open> First, we use the result from \S\ref{sec:basic-probability-inequality-results}
        that shows \<open>\<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>\<close> implies \<open>\<P> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<P> \<psi>)\<close>.
        This can be understood as a \<^emph>\<open>soundness\<close> result. \<close>
 
 text \<open> To show completeness, assume \<open>\<not> \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>\<close>. From this
        obtain a maximally consistent \<^term>\<open>\<Omega>\<close> such that \<open>\<phi> \<rightarrow> \<Squnion> \<Psi> \<notin> \<Omega>\<close>. 
        We then define \<^term>\<open>\<delta> \<chi> = (if (\<chi> \<in> \<Omega>) then 1 else 0)\<close> and 
        show \<^term>\<open>\<delta>\<close> is a  \<^emph>\<open>Dirac measure\<close> such that \<open>\<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)\<close>. \<close>
 
 lemma (in classical_logic) dirac_list_summation_completeness:
   "(\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
 proof -
   {
     fix \<delta> :: "'a \<Rightarrow> real"
     assume "\<delta> \<in> dirac_measures"
     from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" "\<bottom>" "\<delta>"
       unfolding dirac_measures_def
       by auto
     assume "\<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
     hence "\<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)"
       using implication_list_summation_inequality
       by auto
   }
   moreover {
     assume "\<not> \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
     from this obtain \<Omega> where \<Omega>:
       "MCS \<Omega>"
       "\<phi> \<in> \<Omega>"
       "\<Squnion> \<Psi> \<notin> \<Omega>"
       by (meson
             insert_subset
             formula_consistent_def
             formula_maximal_consistency
             formula_maximally_consistent_extension
             formula_maximally_consistent_set_def_def
             set_deduction_base_theory
             set_deduction_reflection
             set_deduction_theorem)
     hence"\<forall> \<psi> \<in> set \<Psi>. \<psi> \<notin> \<Omega>"
       using arbitrary_disjunction_exclusion_MCS by blast
     define \<delta> where "\<delta> = (\<lambda> \<chi> . if \<chi>\<in>\<Omega> then (1 :: real) else 0)"
     from \<open>\<forall> \<psi> \<in> set \<Psi>. \<psi> \<notin> \<Omega>\<close> have "(\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>) = 0"
       unfolding \<delta>_def
       by (induct \<Psi>, simp, simp)
     hence "\<not> \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)"
       unfolding \<delta>_def
       by (simp add: \<Omega>(2))
     hence
       "\<exists> \<delta> \<in> dirac_measures. \<not> (\<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>))"
       unfolding \<delta>_def
       using \<Omega>(1) MCS_dirac_measure by auto
   }
   ultimately show ?thesis by blast
 qed
 
 theorem (in classical_logic) list_summation_completeness:
   "(\<forall> \<P> \<in> probabilities. \<P> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<P> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs
   hence "\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)"
     unfolding dirac_measures_def probabilities_def
     by blast
   thus ?rhs
     using dirac_list_summation_completeness by blast
 next
   assume ?rhs
   show ?lhs
   proof
     fix \<P> :: "'a \<Rightarrow> real"
     assume "\<P> \<in> probabilities"
     from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" \<bottom> \<P>
       unfolding probabilities_def
       by auto
     show "\<P> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<P> \<psi>)"
       using \<open>?rhs\<close> implication_list_summation_inequality
       by simp
   qed
 qed
 
 text \<open> The collapse theorem asserts that to prove an inequalities for all 
        probabilities in probability logic, one only needs to consider the 
        case of functions which take on values of 0 or 1. \<close>
 
 lemma (in classical_logic) suppes_collapse:
   "(\<forall> \<P> \<in> probabilities. \<P> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<P> \<psi>))
       = (\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>))"
   by (simp add:
         dirac_list_summation_completeness
         list_summation_completeness)
 
 lemma (in classical_logic) probability_member_neg:
   fixes \<P>
   assumes "\<P> \<in> probabilities"
   shows "\<P> (\<sim> \<phi>) = 1 - \<P> \<phi>"
 proof -
   from assms interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" \<bottom> \<P>
     unfolding probabilities_def
     by auto
   show ?thesis
     by (simp add: complementation)
 qed
 
 text \<open> Suppes' theorem has a philosophical interpretation.
        It asserts that if \<^term>\<open>\<Psi> :\<turnstile> \<phi>\<close>, then our \<^emph>\<open>uncertainty\<close>
        in \<^term>\<open>\<phi>\<close> is bounded above by our uncertainty in \<^term>\<open>\<Psi>\<close>.
        Here the uncertainty in the proposition \<^term>\<open>\<phi>\<close> is \<open>1 - \<P> \<phi>\<close>.
        Our uncertainty in \<^term>\<open>\<Psi>\<close>, on the other hand, is
        \<open>\<Sum>\<psi>\<leftarrow>\<Psi>. 1 - \<P> \<psi>\<close>. \<close>
 
 theorem (in classical_logic) suppes_list_theorem:
   "\<Psi> :\<turnstile> \<phi> = (\<forall> \<P> \<in> probabilities. (\<Sum>\<psi>\<leftarrow>\<Psi>. 1 - \<P> \<psi>) \<ge> 1 - \<P> \<phi>)"
 proof -
   have
     "\<Psi> :\<turnstile> \<phi> = (\<forall> \<P> \<in> probabilities. (\<Sum>\<psi> \<leftarrow> \<^bold>\<sim> \<Psi>. \<P> \<psi>) \<ge> \<P> (\<sim> \<phi>))"
     using
       list_summation_completeness
       weak_biconditional_weaken
       contra_list_curry_uncurry
       list_deduction_def
     by blast
   moreover have
     "\<forall> \<P> \<in> probabilities. (\<Sum>\<psi> \<leftarrow> (\<^bold>\<sim> \<Psi>). \<P> \<psi>) = (\<Sum>\<psi> \<leftarrow> \<Psi>. \<P> (\<sim> \<psi>))"
     by (induct \<Psi>, auto)
   ultimately show ?thesis
     using probability_member_neg
     by (induct \<Psi>, simp+)
 qed
 
 section \<open> Suppes' Set Theorem \<close>
 
 text \<open> Suppes theorem also obtains for \<^emph>\<open>sets\<close>. \<close>
 
 lemma (in classical_logic) dirac_set_summation_completeness:
   "(\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<in> set \<Psi>. \<delta> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
   by (metis
         dirac_list_summation_completeness
         modus_ponens
         arbitrary_disjunction_remdups
         biconditional_left_elimination
         biconditional_right_elimination
         hypothetical_syllogism
         sum.set_conv_list)
 
 theorem (in classical_logic) set_summation_completeness:
   "(\<forall> \<delta> \<in> probabilities. \<delta> \<phi> \<le> (\<Sum>\<psi>\<in> set \<Psi>. \<delta> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
   by (metis
         dirac_list_summation_completeness
         dirac_set_summation_completeness
         list_summation_completeness
         sum.set_conv_list)
 
 lemma (in classical_logic) suppes_set_collapse:
   "(\<forall> \<P> \<in> probabilities. \<P> \<phi> \<le> (\<Sum>\<psi> \<in> set \<Psi>. \<P> \<psi>))
       = (\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi> \<in> set \<Psi>. \<delta> \<psi>))"
   by (simp add:
         dirac_set_summation_completeness
         set_summation_completeness)
 
 text \<open> In our formulation of logic, there is not reason that \<open>\<sim> a = \<sim> b\<close>
        while \<^term>\<open>a \<noteq> b\<close>.  As a consequence the Suppes theorem
        for sets presented below is different than the one given in
        \S\ref{sec:suppes-theorem-for-lists}. \<close>
 
 theorem (in classical_logic) suppes_set_theorem:
   "\<Psi> :\<turnstile> \<phi>
      = (\<forall> \<P> \<in> probabilities. (\<Sum>\<psi> \<in> set (\<^bold>\<sim> \<Psi>). \<P> \<psi>) \<ge> 1 - \<P> \<phi>)"
 proof -
   have "\<Psi> :\<turnstile> \<phi>
           = (\<forall> \<P> \<in> probabilities. (\<Sum>\<psi> \<in> set (\<^bold>\<sim> \<Psi>). \<P> \<psi>) \<ge> \<P> (\<sim> \<phi>))"
     using
       contra_list_curry_uncurry
       list_deduction_def
       set_summation_completeness
       weak_biconditional_weaken
     by blast
   thus ?thesis
     using probability_member_neg
     by (induct \<Psi>, auto)
 qed
 
 section \<open> Converse Suppes' Theorem \<close>
 
 text \<open> A formulation of the converse of Suppes' theorem obtains
        for lists/sets of \<^emph>\<open>logically disjoint\<close> propositions. \<close>
 
 lemma (in probability_logic) exclusive_sum_list_identity:
   assumes "\<turnstile> \<Coprod> \<Phi>"
   shows "\<P> (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)"
   using assms
 proof (induct \<Phi>)
   case Nil
   then show ?case
     by (simp add: gaines_weatherson_antithesis)
 next
   case (Cons \<phi> \<Phi>)
   assume "\<turnstile> \<Coprod> (\<phi> # \<Phi>)"
   hence "\<turnstile> \<sim> (\<phi> \<sqinter> \<Squnion> \<Phi>)" "\<turnstile> \<Coprod> \<Phi>" by simp+
   hence "\<P> (\<Squnion>(\<phi> # \<Phi>)) = \<P> \<phi> + \<P> (\<Squnion> \<Phi>)"
         "\<P> (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)"
     using Cons.hyps probability_additivity by auto
   hence "\<P> (\<Squnion>(\<phi> # \<Phi>)) = \<P> \<phi> + (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)" by auto
   thus ?case by simp
 qed
 
 lemma sum_list_monotone:
   fixes f :: "'a \<Rightarrow> real"
   assumes "\<forall> x. f x \<ge> 0"
      and  "set \<Phi> \<subseteq> set \<Psi>"
      and  "distinct \<Phi>"
    shows "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
   using assms
 proof -
   assume "\<forall> x. f x \<ge> 0"
   have "\<forall>\<Phi>. set \<Phi> \<subseteq> set \<Psi>
              \<longrightarrow> distinct \<Phi>
              \<longrightarrow> (\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
   proof (induct \<Psi>)
     case Nil
     then show ?case by simp
   next
     case (Cons \<psi> \<Psi>)
     {
       fix \<Phi>
       assume "set \<Phi> \<subseteq> set (\<psi> # \<Psi>)"
          and "distinct \<Phi>"
       have "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>'\<leftarrow>(\<psi> # \<Psi>). f \<psi>')"
       proof -
         {
           assume "\<psi> \<notin> set \<Phi>"
           with \<open>set \<Phi> \<subseteq> set (\<psi> # \<Psi>)\<close> have "set \<Phi> \<subseteq> set \<Psi>" by auto
           hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
             using Cons.hyps \<open>distinct \<Phi>\<close> by auto
           moreover have "f \<psi> \<ge> 0" using \<open>\<forall> x. f x \<ge> 0\<close> by metis
           ultimately have ?thesis by simp
         }
         moreover
         {
           assume "\<psi> \<in> set \<Phi>"
           hence "set \<Phi> = insert \<psi> (set (removeAll \<psi> \<Phi>))"
             by auto
           with \<open>set \<Phi> \<subseteq> set (\<psi> # \<Psi>)\<close> have "set (removeAll \<psi> \<Phi>) \<subseteq> set \<Psi>"
             by (metis
                   insert_subset
                   list.simps(15)
                   set_removeAll
                   subset_insert_iff)
           moreover from \<open>distinct \<Phi>\<close> have "distinct (removeAll \<psi> \<Phi>)"
             by (meson distinct_removeAll)
           ultimately have "(\<Sum>\<phi>\<leftarrow>(removeAll \<psi> \<Phi>). f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
             using Cons.hyps
             by simp
           moreover from \<open>\<psi> \<in> set \<Phi>\<close> \<open>distinct \<Phi>\<close>
           have "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) = f \<psi> + (\<Sum>\<phi>\<leftarrow>(removeAll \<psi> \<Phi>). f \<phi>)"
             using distinct_remove1_removeAll sum_list_map_remove1
             by fastforce
           ultimately have ?thesis using \<open>\<forall> x. f x \<ge> 0\<close>
             by simp
         }
         ultimately show ?thesis by blast
       qed
     }
     thus ?case by blast
   qed
   moreover assume "set \<Phi> \<subseteq> set \<Psi>" and "distinct \<Phi>"
   ultimately show ?thesis by blast
 qed
 
 lemma count_remove_all_sum_list:
   fixes f :: "'a \<Rightarrow> real"
   shows "real (count_list xs x) * f x + (\<Sum>x'\<leftarrow>(removeAll x xs). f x')
            = (\<Sum>x\<leftarrow>xs. f x)"
   by (induct xs, simp, simp, metis combine_common_factor mult_cancel_right1)
 
 lemma (in classical_logic) dirac_exclusive_implication_completeness:
   "(\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>) = (\<turnstile> \<Coprod> \<Phi> \<and>  \<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>)"
 proof -
   {
     fix \<delta>
     assume "\<delta> \<in> dirac_measures"
     from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" "\<bottom>" "\<delta>"
       unfolding dirac_measures_def
       by simp
     assume "\<turnstile> \<Coprod> \<Phi>" "\<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>"
     hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>"
       using exclusive_sum_list_identity monotonicity by fastforce
   }
   moreover
   {
     assume "\<not> \<turnstile> \<Coprod> \<Phi>"
     hence "(\<exists> \<phi> \<in> set \<Phi>. \<exists> \<psi> \<in> set \<Phi>.
               \<phi> \<noteq> \<psi> \<and> \<not> \<turnstile> \<sim> (\<phi> \<sqinter> \<psi>)) \<or> (\<exists> \<phi> \<in> duplicates \<Phi>. \<not> \<turnstile> \<sim> \<phi>)"
       using exclusive_equivalence set_deduction_base_theory by blast
     hence "\<not> (\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>)"
     proof (elim disjE)
       assume "\<exists> \<phi> \<in> set \<Phi>. \<exists> \<chi> \<in> set \<Phi>. \<phi> \<noteq> \<chi> \<and> \<not> \<turnstile> \<sim> (\<phi> \<sqinter> \<chi>)"
       from this obtain \<phi> and \<chi>
         where \<phi>\<chi>_properties:
           "\<phi> \<in> set \<Phi>"
           "\<chi> \<in> set \<Phi>"
           "\<phi> \<noteq> \<chi>"
           "\<not> \<turnstile> \<sim> (\<phi> \<sqinter> \<chi>)"
         by blast
       from this obtain \<Omega> where \<Omega>: "MCS \<Omega>" "\<sim> (\<phi> \<sqinter> \<chi>) \<notin> \<Omega>"
         by (meson
               insert_subset
               formula_consistent_def
               formula_maximal_consistency
               formula_maximally_consistent_extension
               formula_maximally_consistent_set_def_def
               set_deduction_base_theory
               set_deduction_reflection
               set_deduction_theorem)
       let ?\<delta> = "\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0"
       from \<Omega> have "\<phi> \<in> \<Omega>" "\<chi> \<in> \<Omega>"
         by (metis
               formula_maximally_consistent_set_def_implication
               maximally_consistent_set_def
               conjunction_def
               negation_def)+
       with \<phi>\<chi>_properties have
           "(\<Sum>\<phi>\<leftarrow>[\<phi>, \<chi>]. ?\<delta> \<phi>) = 2"
           "set [\<phi>, \<chi>] \<subseteq> set \<Phi>"
           "distinct [\<phi>, \<chi>]"
           "\<forall>\<phi>. ?\<delta> \<phi> \<ge> 0"
         by simp+
       hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<ge> 2" using sum_list_monotone by metis
       hence "\<not> (\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<le> ?\<delta> (\<psi>)" by auto
       thus ?thesis
         using \<Omega>(1) MCS_dirac_measure
         by auto
     next
       assume "\<exists> \<phi> \<in> duplicates \<Phi>. \<not> \<turnstile> \<sim> \<phi>"
       from this obtain \<phi> where \<phi>: "\<phi> \<in> duplicates \<Phi>" "\<not> \<turnstile> \<sim> \<phi>"
         using
           exclusive_equivalence [where \<Gamma>="{}"]
           set_deduction_base_theory
         by blast
       from \<phi> obtain \<Omega> where \<Omega>: "MCS \<Omega>" "\<sim> \<phi> \<notin> \<Omega>"
         by (meson
               insert_subset
               formula_consistent_def
               formula_maximal_consistency
               formula_maximally_consistent_extension
               formula_maximally_consistent_set_def_def
               set_deduction_base_theory
               set_deduction_reflection
               set_deduction_theorem)
       hence "\<phi> \<in> \<Omega>"
         using negation_def by auto
       let ?\<delta> = "\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0"
       from \<phi> have "count_list \<Phi> \<phi> \<ge> 2"
         using duplicates_alt_def [where xs="\<Phi>"]
         by blast
       hence "real (count_list \<Phi> \<phi>) * ?\<delta> \<phi> \<ge> 2" using \<open>\<phi> \<in> \<Omega>\<close> by simp
       moreover
       {
         fix \<Psi>
         have "(\<Sum>\<phi>\<leftarrow>\<Psi>. ?\<delta> \<phi>) \<ge> 0" by (induct \<Psi>, simp, simp)
       }
       moreover have "(0::real)
                           \<le> (\<Sum>a\<leftarrow>removeAll \<phi> \<Phi>. if a \<in> \<Omega> then 1 else 0)"
         using \<open>\<And>\<Psi>. 0 \<le> (\<Sum>\<phi>\<leftarrow>\<Psi>. if \<phi> \<in> \<Omega> then 1 else 0)\<close>
         by presburger
       ultimately have "real (count_list \<Phi> \<phi>) * ?\<delta> \<phi>
                             + (\<Sum> \<phi> \<leftarrow> (removeAll \<phi> \<Phi>). ?\<delta> \<phi>) \<ge> 2"
         using \<open>2 \<le> real (count_list \<Phi> \<phi>) * (if \<phi> \<in> \<Omega> then 1 else 0)\<close>
         by linarith
       hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<ge> 2" by (metis count_remove_all_sum_list)
       hence "\<not> (\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<le> ?\<delta> (\<psi>)" by auto
       thus ?thesis
         using \<Omega>(1) MCS_dirac_measure
         by auto
     qed
   }
   moreover
   {
     assume "\<not> \<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>"
     from this obtain \<Omega> \<phi>
       where
         \<Omega>: "MCS \<Omega>"
         and \<psi>: "\<psi> \<notin> \<Omega>"
         and \<phi>: "\<phi> \<in> set \<Phi>" "\<phi> \<in> \<Omega>"
       by (meson
             insert_subset
             formula_consistent_def
             formula_maximal_consistency
             formula_maximally_consistent_extension
             formula_maximally_consistent_set_def_def
             arbitrary_disjunction_exclusion_MCS
             set_deduction_base_theory
             set_deduction_reflection
             set_deduction_theorem)
     let ?\<delta> = "\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0"
     from \<phi> have "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<ge> 1"
     proof (induct \<Phi>)
       case Nil
       then show ?case by simp
     next
       case (Cons \<phi>' \<Phi>)
       obtain f :: "real list \<Rightarrow> real" where f:
         "\<forall>rs. f rs \<in> set rs \<and> \<not> 0 \<le> f rs \<or> 0 \<le> sum_list rs"
-        using sum_list_nonneg by moura
+        using sum_list_nonneg by metis
       moreover have "f (map ?\<delta> \<Phi>) \<notin> set (map ?\<delta> \<Phi>) \<or> 0 \<le> f (map ?\<delta> \<Phi>)"
         by fastforce
       ultimately show ?case
         by (simp, metis Cons.hyps Cons.prems(1) \<phi>(2) set_ConsD)
     qed
     hence "\<not> (\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<le> ?\<delta> (\<psi>)" using \<psi> by auto
     hence "\<not> (\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>)"
       using \<Omega>(1) MCS_dirac_measure
       by auto
   }
   ultimately show ?thesis by blast
 qed
 
 theorem (in classical_logic) exclusive_implication_completeness:
   "(\<forall> \<P> \<in> probabilities. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>) \<le> \<P> \<psi>) = (\<turnstile> \<Coprod> \<Phi> \<and>  \<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>)"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs
   thus ?rhs
     by (meson
           dirac_exclusive_implication_completeness
           dirac_measures_subset
           subset_eq)
 next
   assume ?rhs
   show ?lhs
   proof
     fix \<P> :: "'a \<Rightarrow> real"
     assume "\<P> \<in> probabilities"
     from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" \<bottom> \<P>
       unfolding probabilities_def
       by simp
     show "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>) \<le> \<P> \<psi>"
       using
         \<open>?rhs\<close>
         exclusive_sum_list_identity
         monotonicity
       by fastforce
   qed
 qed
 
 lemma (in classical_logic) dirac_inequality_completeness:
   "(\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> \<delta> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
 proof -
   have "\<turnstile> \<Coprod> [\<phi>]"
     by (simp add: conjunction_right_elimination negation_def)
   hence "(\<turnstile> \<Coprod> [\<phi>] \<and>  \<turnstile> \<Squnion> [\<phi>] \<rightarrow> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
     by (metis
           arbitrary_disjunction.simps(1)
           arbitrary_disjunction.simps(2)
           disjunction_def implication_equivalence
           negation_def
           weak_biconditional_weaken)
   thus ?thesis
     using dirac_exclusive_implication_completeness [where \<Phi>="[\<phi>]"]
     by auto
 qed
 
 section \<open> Implication Inequality Completeness \<close>
 
 text \<open> The following theorem establishes the converse of
        \<open>\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<P> \<phi> \<le> \<P> \<psi>\<close>, which was
        proved in \S\ref{sec:prob-logic-alt-def}. \<close>
 
 theorem (in classical_logic) implication_inequality_completeness:
   "(\<forall> \<P> \<in> probabilities. \<P> \<phi> \<le> \<P> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
 proof -
   have "\<turnstile> \<Coprod> [\<phi>]"
     by (simp add: conjunction_right_elimination negation_def)
   hence "(\<turnstile> \<Coprod> [\<phi>] \<and>  \<turnstile> \<Squnion> [\<phi>] \<rightarrow> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
     by (metis
           arbitrary_disjunction.simps(1)
           arbitrary_disjunction.simps(2)
           disjunction_def implication_equivalence
           negation_def
           weak_biconditional_weaken)
   thus ?thesis
     using exclusive_implication_completeness [where \<Phi>="[\<phi>]"]
     by simp
 qed
 
 section \<open> Characterizing Logical Exclusiveness In Probability Logic \<close>
 
 text \<open> Finally, we can say that \<open>\<P> (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)\<close> if and only
        if the propositions in \<^term>\<open>\<Phi>\<close> are mutually exclusive (i.e. \<open>\<turnstile> \<Coprod> \<Phi>\<close>).
        This result also obtains for sets. \<close>
 
 lemma (in classical_logic) dirac_exclusive_list_summation_completeness:
   "(\<forall> \<delta> \<in> dirac_measures. \<delta> (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>)) = \<turnstile> \<Coprod> \<Phi>"
   by (metis
         antisym_conv
         dirac_exclusive_implication_completeness
         dirac_list_summation_completeness
         trivial_implication)
 
 theorem (in classical_logic) exclusive_list_summation_completeness:
   "(\<forall> \<P> \<in> probabilities. \<P> (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)) = \<turnstile> \<Coprod> \<Phi>"
   by (metis
         antisym_conv
         exclusive_implication_completeness
         list_summation_completeness
         trivial_implication)
 
 lemma (in classical_logic) dirac_exclusive_set_summation_completeness:
   "(\<forall> \<delta> \<in> dirac_measures. \<delta> (\<Squnion> \<Phi>) = (\<Sum>\<phi> \<in> set \<Phi>. \<delta> \<phi>))
       = \<turnstile> \<Coprod> (remdups \<Phi>)"
   by (metis
         (mono_tags)
         eq_iff
         dirac_exclusive_implication_completeness
         dirac_set_summation_completeness
         trivial_implication
         set_remdups
         sum.set_conv_list    eq_iff
         dirac_exclusive_implication_completeness
         dirac_set_summation_completeness
         trivial_implication
         set_remdups
         sum.set_conv_list
         antisym_conv)
 
 theorem (in classical_logic) exclusive_set_summation_completeness:
   "(\<forall> \<P> \<in> probabilities.
         \<P> (\<Squnion> \<Phi>) = (\<Sum>\<phi> \<in> set \<Phi>. \<P> \<phi>)) = \<turnstile> \<Coprod> (remdups \<Phi>)"
   by (metis
         (mono_tags, opaque_lifting)
         antisym_conv
         exclusive_list_summation_completeness
         exclusive_implication_completeness
         implication_inequality_completeness
         set_summation_completeness
         order.refl
         sum.set_conv_list)
 
 lemma (in probability_logic) exclusive_list_set_inequality:
   assumes "\<turnstile> \<Coprod> \<Phi>"
   shows "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>) = (\<Sum>\<phi>\<in>set \<Phi>. \<P> \<phi>)"
 proof -
   have "distinct (remdups \<Phi>)" using distinct_remdups by auto
   hence "duplicates (remdups \<Phi>) = {}"
     by (induct "\<Phi>", simp+)
   moreover have "set (remdups \<Phi>) = set \<Phi>"
     by (induct "\<Phi>", simp, simp add: insert_absorb)
   moreover have "(\<forall>\<phi> \<in> duplicates \<Phi>. \<turnstile> \<sim> \<phi>)
                \<and> (\<forall> \<phi> \<in> set \<Phi>. \<forall> \<psi> \<in> set \<Phi>. (\<phi> \<noteq> \<psi>) \<longrightarrow> \<turnstile> \<sim> (\<phi> \<sqinter> \<psi>))"
     using
       assms
       exclusive_elimination1
       exclusive_elimination2
       set_deduction_base_theory
     by blast
   ultimately have
     "(\<forall>\<phi>\<in>duplicates (remdups \<Phi>). \<turnstile> \<sim> \<phi>)
    \<and> (\<forall> \<phi> \<in> set (remdups \<Phi>). \<forall> \<psi> \<in> set (remdups \<Phi>).
           (\<phi> \<noteq> \<psi>) \<longrightarrow> \<turnstile> \<sim> (\<phi> \<sqinter> \<psi>))"
     by auto
   hence "\<turnstile> \<Coprod> (remdups \<Phi>)"
     by (meson exclusive_equivalence set_deduction_base_theory)
   hence "(\<Sum>\<phi>\<in>set \<Phi>. \<P> \<phi>) = \<P> (\<Squnion> \<Phi>)"
     by (metis
           arbitrary_disjunction_remdups
           biconditional_equivalence
           exclusive_sum_list_identity
           sum.set_conv_list)
   moreover have "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>) = \<P> (\<Squnion> \<Phi>)"
     by (simp add: assms exclusive_sum_list_identity)
   ultimately show ?thesis by metis
 qed
 
 notation FuncSet.funcset (infixr "\<rightarrow>" 60)
 
 end
diff --git a/thys/Virtual_Substitution/ExecutiblePolyProps.thy b/thys/Virtual_Substitution/ExecutiblePolyProps.thy
--- a/thys/Virtual_Substitution/ExecutiblePolyProps.thy
+++ b/thys/Virtual_Substitution/ExecutiblePolyProps.thy
@@ -1,1081 +1,1071 @@
 text "Executable Polynomial Properties"
 theory ExecutiblePolyProps
   imports
     Polynomials.MPoly_Type_Univariate
     MPolyExtension
 begin
 
 text \<open>(Univariate) Polynomial hiding\<close>
 
 lifting_update poly.lifting
 lifting_forget poly.lifting
 
 text \<open>\<close>
 
 subsection "Lemmas with Monomial and Monomials"
 
 lemma of_nat_monomial: "of_nat p = monomial p 0"
   by (auto simp: poly_mapping_eq_iff lookup_of_nat fun_eq_iff lookup_single)
 
 lemma of_nat_times_monomial: "of_nat p * monomial c i = monomial (p*c) i"
   by (auto simp: poly_mapping_eq_iff prod_fun_def fun_eq_iff of_nat_monomial
       lookup_single mult_single)
 
 lemma monomial_adds_nat_iff: "monomial p i adds c \<longleftrightarrow> lookup c i \<ge> p" for p::"nat"
   apply (auto simp: adds_def lookup_add)
   by (metis add.left_commute nat_le_iff_add remove_key_sum single_add)
 
 lemma update_minus_monomial: "Poly_Mapping.update k i (m - monomial i k) = Poly_Mapping.update k i m"
   by (auto simp: poly_mapping_eq_iff lookup_update update.rep_eq fun_eq_iff lookup_minus
       lookup_single)
 
 lemma monomials_Var: "monomials (Var x::'a::zero_neq_one mpoly) = {Poly_Mapping.single x 1}"
   by transfer (auto simp: Var\<^sub>0_def)
 
 lemma monomials_Const: "monomials (Const x) = (if x = 0 then {} else {0})"
   by transfer' (auto simp: Const\<^sub>0_def)
 
 lemma coeff_eq_zero_iff: "MPoly_Type.coeff c p = 0 \<longleftrightarrow> p \<notin> monomials c"
   by transfer (simp add: not_in_keys_iff_lookup_eq_zero)
 
 lemma monomials_1[simp]: "monomials 1 = {0}"
   by transfer auto
 
 lemma monomials_and_monoms: 
   shows "(k \<in> monomials m) = (\<exists> (a::nat). a \<noteq> 0 \<and> (monomials (MPoly_Type.monom k a)) \<subseteq> monomials m)"
 proof - 
   show ?thesis using monomials_monom by auto
 qed
 
 lemma mult_monomials_dir_one:
   shows "monomials (p*q) \<subseteq> {a+b | a b . a \<in> monomials p \<and> b \<in> monomials q}"
   using monomials_and_monoms mult_monom
   by (simp add: keys_mult monomials.rep_eq times_mpoly.rep_eq) 
 
 lemma monom_eq_zero_iff[simp]: "MPoly_Type.monom a b = 0 \<longleftrightarrow> b = 0"
   by (metis MPolyExtension.coeff_monom MPolyExtension.monom_zero)
 
 lemma update_eq_plus_monomial:
   "v \<ge> lookup m k \<Longrightarrow> Poly_Mapping.update k v m = m + monomial (v - lookup m k) k"
   for v n::nat
   by transfer auto
 
 lemma coeff_monom_mult':
   "MPoly_Type.coeff ((MPoly_Type.monom m' a) * q) (m'm)  = a * MPoly_Type.coeff q (m'm - m')"
   if *: "m'm = m' + (m'm - m')"
   by (subst *) (rule More_MPoly_Type.coeff_monom_mult)
 
 lemma monomials_zero[simp]: "monomials 0 = {}"
   by transfer auto
 
 lemma in_monomials_iff: "x \<in> monomials m \<longleftrightarrow> MPoly_Type.coeff m x \<noteq> 0"
   using coeff_eq_zero_iff[of m x] by auto
 
 lemma monomials_monom_mult: "monomials (MPoly_Type.monom mon a * q) = (if a = 0 then {} else (+) mon ` monomials q)"
   for q::"'a::semiring_no_zero_divisors mpoly"
   apply auto
   subgoal by transfer' (auto elim!: in_keys_timesE)
   subgoal by (simp add: in_monomials_iff More_MPoly_Type.coeff_monom_mult)
   done
 
 subsection "Simplification Lemmas for Const 0 and Const 1"
 lemma add_zero : "P + Const 0 = P"
 proof -
   have h:"P + 0 = P" using add_0_right by auto
   show ?thesis unfolding Const_def using h by (simp add: Const\<^sub>0_zero zero_mpoly.abs_eq)
 qed
 
 (* example *)
 lemma add_zero_example : "((Var 0)^2 - (Const 1)) + Const 0 = ((Var 0)^2 - (Const 1))"
 proof -
   show ?thesis by (simp add : add_zero)
 qed
 
 lemma mult_zero_left : "Const 0 * P = Const 0"
 proof -
   have h:"0*P = 0" by simp
   show ?thesis unfolding Const_def using h by (simp add: Const\<^sub>0_zero zero_mpoly_def)
 qed
 
 lemma mult_zero_right : "P * Const 0 = Const 0"
   by (metis mult_zero_left mult_zero_right)
 
 lemma mult_one_left : "Const 1 * (P :: real mpoly) = P"
   by (simp add: Const.abs_eq Const\<^sub>0_one one_mpoly_def)
 
 lemma mult_one_right : "(P::real mpoly) * Const 1 = P"
   by (simp add: Const.abs_eq Const\<^sub>0_one one_mpoly_def)
 
 
 subsection "Coefficient Lemmas"
 lemma coeff_zero[simp]: "MPoly_Type.coeff 0 x = 0"
   by transfer auto
 
 lemma coeff_sum: "MPoly_Type.coeff (sum f S) x = sum (\<lambda>i. MPoly_Type.coeff (f i) x) S"
   apply (induction S rule: infinite_finite_induct) 
     apply (auto)
   by (metis More_MPoly_Type.coeff_add)
 
 lemma coeff_mult_Var: "MPoly_Type.coeff (x * Var i ^ p) c = (MPoly_Type.coeff x (c - monomial p i) when lookup c i \<ge> p)"
   by transfer'
     (auto simp: Var\<^sub>0_def pprod.monomial_power lookup_times_monomial_right
       of_nat_times_monomial monomial_adds_nat_iff)
 
 lemma lookup_update_self[simp]: "Poly_Mapping.update i (lookup m i) m = m"
   by (auto simp: lookup_update intro!: poly_mapping_eqI)
 
 lemma coeff_Const: "MPoly_Type.coeff (Const p) m = (p when m = 0)"
   by transfer' (auto simp: Const\<^sub>0_def lookup_single)
 
 lemma coeff_Var: "MPoly_Type.coeff (Var p) m = (1 when m = monomial 1 p)"
   by transfer' (auto simp: Var\<^sub>0_def lookup_single when_def)
 
 subsection "Miscellaneous"
 lemma update_0_0[simp]: "Poly_Mapping.update x 0 0 = 0"
   by (metis lookup_update_self lookup_zero)
 
 lemma mpoly_eq_iff: "p = q \<longleftrightarrow> (\<forall>m. MPoly_Type.coeff p m = MPoly_Type.coeff q m)"
   by transfer (auto simp: poly_mapping_eqI)
 
 lemma power_both_sides :
   assumes Ah : "(A::real) \<ge>0"
   assumes Bh : "(B::real) \<ge>0"
   shows "(A\<le>B) = (A^2\<le>B^2)"
   using Ah Bh by (meson power2_le_imp_le power_mono)
 
 lemma in_list_induct_helper: 
   assumes "set(xs)\<subseteq>X"
   assumes  "P []"
   assumes "(\<And>x. x\<in>X \<Longrightarrow> ( \<And>xs. P xs \<Longrightarrow> P (x # xs)))"
   shows "P xs" using assms(1)
 proof(induction xs)
   case Nil
   then show ?case using assms by auto
 next
   case (Cons a xs)
   then show ?case using assms(3) by auto
 qed
 
 theorem in_list_induct [case_names Nil Cons]: 
   assumes  "P []"
   assumes "(\<And>x. x\<in>set(xs) \<Longrightarrow> ( \<And>xs. P xs \<Longrightarrow> P (x # xs)))"
   shows "P xs"
   using in_list_induct_helper[of xs "set(xs)" P] using assms by auto
 
 subsubsection "Keys and vars"
 
 lemma inKeys_inVars : "a\<noteq>0 \<Longrightarrow> x \<in> keys m \<Longrightarrow> x \<in> vars(MPoly_Type.monom m a)"
   by(simp add: vars_def)
 
 lemma notInKeys_notInVars : "x \<notin> keys m \<Longrightarrow> x \<notin> vars(MPoly_Type.monom m a)"
   by(simp add: vars_def)
 
 lemma lookupNotIn : "x \<notin> keys m \<Longrightarrow> lookup m x = 0"
   by (simp add: in_keys_iff)
 
 subsection "Degree Lemmas"
 
 lemma degree_le_iff: "MPoly_Type.degree p x \<le> k \<longleftrightarrow> (\<forall>m\<in>monomials p. lookup m x \<le> k)"
   by transfer simp
 
 lemma degree_less_iff: "MPoly_Type.degree p x < k \<longleftrightarrow> (k>0 \<and> (\<forall>m\<in>monomials p. lookup m x < k))"
   by (transfer fixing: k) (cases "k = 0"; simp)  
 
 lemma degree_ge_iff: "k > 0 \<Longrightarrow> MPoly_Type.degree p x \<ge> k \<longleftrightarrow> (\<exists>m\<in>monomials p. lookup m x \<ge> k)"
   using Max_ge_iff by (meson degree_less_iff not_less) 
 
 lemma degree_greater_iff: "MPoly_Type.degree p x > k \<longleftrightarrow> (\<exists>m\<in>monomials p. lookup m x > k)"
   by transfer' (auto simp: Max_gr_iff)
 
 lemma degree_eq_iff:
   "MPoly_Type.degree p x = k \<longleftrightarrow> (if k = 0
     then (\<forall>m\<in>monomials p. lookup m x = 0)
     else (\<exists>m\<in>monomials p. lookup m x = k) \<and> (\<forall>m\<in>monomials p. lookup m x \<le> k))"
   by (subst eq_iff) (force simp: degree_le_iff degree_ge_iff intro!: antisym)
 
 declare poly_mapping.lookup_inject[simp del]
 
 lemma lookup_eq_and_update_lemma: "lookup m var = deg \<and> Poly_Mapping.update var 0 m = x \<longleftrightarrow>
   m = Poly_Mapping.update var deg x \<and> lookup x var = 0"
   unfolding poly_mapping_eq_iff
   by (force simp: update.rep_eq fun_eq_iff)
 
 
 lemma degree_const : "MPoly_Type.degree (Const (z::real)) (x::nat) = 0"
   by (simp add: degree_eq_iff monomials_Const)
 
 lemma degree_one : "MPoly_Type.degree (Var x :: real mpoly) x = 1"
   by(simp add: degree_eq_iff monomials_Var)
 
 subsection "Lemmas on treating a multivariate polynomial as univariate "
 lemma coeff_isolate_variable_sparse:
   "MPoly_Type.coeff (isolate_variable_sparse p var deg) x =
   (if lookup x var = 0
   then MPoly_Type.coeff p (Poly_Mapping.update var deg x)
   else 0)"
   apply (transfer fixing: x var deg p)
   unfolding lookup_sum
   unfolding lookup_single
   apply (auto simp: when_def)
    apply (subst sum.inter_filter[symmetric])
   subgoal by simp
   subgoal by (simp add: lookup_eq_and_update_lemma Collect_conv_if)
   by (auto intro!: sum.neutral simp add: lookup_update)
 
 lemma isovarspar_sum: 
   "isolate_variable_sparse (p+q) var deg = 
   isolate_variable_sparse (p) var deg
   + isolate_variable_sparse (q) var deg"
   apply (auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse )
    apply (metis More_MPoly_Type.coeff_add coeff_isolate_variable_sparse)
   by (metis More_MPoly_Type.coeff_add add.comm_neutral coeff_isolate_variable_sparse less_numeral_extra(3))
 
 lemma isolate_zero[simp]: "isolate_variable_sparse 0 var n = 0"
   by transfer' (auto simp: mpoly_eq_iff)
 
 lemma coeff_isolate_variable_sparse_minus_monomial:
   "MPoly_Type.coeff (isolate_variable_sparse mp var i) (m - monomial i var) =
   (if lookup m var \<le> i then MPoly_Type.coeff mp (Poly_Mapping.update var i m) else 0)"
   by (simp add: coeff_isolate_variable_sparse lookup_minus update_minus_monomial)
 
 lemma sum_over_zero: "(mp::real mpoly) = (\<Sum>i::nat \<le>MPoly_Type.degree mp x. isolate_variable_sparse mp x i * Var x^i)"
   by (auto simp add: mpoly_eq_iff coeff_sum coeff_mult_Var if_if_eq_conj not_le
       coeff_isolate_variable_sparse_minus_monomial when_def lookup_update degree_less_iff
       simp flip: eq_iff
       intro!: coeff_not_in_monomials)
 
 lemma const_lookup_zero : "isolate_variable_sparse (Const p ::real mpoly) (x::nat) (0::nat) = Const p"
   by (auto simp: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Const when_def)
     (metis lookup_update_self)
 
 lemma const_lookup_suc : "isolate_variable_sparse (Const p :: real mpoly) x (Suc i) = 0"
   apply(auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Const when_def)
   by (metis lookup_update lookup_zero nat.distinct(1))
 
 lemma isovar_greater_degree : "\<forall>i > MPoly_Type.degree p var. isolate_variable_sparse p var i = 0"
   apply(auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse degree_less_iff)
   by (metis coeff_not_in_monomials less_irrefl_nat lookup_update)
 
 lemma isolate_var_0 : "isolate_variable_sparse (Var x::real mpoly) x 0 = 0"
   apply(auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Var when_def)
   by (metis gr0I lookup_single_eq lookup_update_self n_not_Suc_n)
 
 lemma isolate_var_one : "isolate_variable_sparse (Var x :: real mpoly) x 1 = 1"
   by (auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Var coeff_eq_zero_iff)
     (smt More_MPoly_Type.coeff_monom One_nat_def add_diff_cancel_left' lookup_eq_and_update_lemma
       lookup_single_eq lookup_update_self monom_one plus_1_eq_Suc single_diff single_zero update_minus_monomial)
 
 lemma isovarspase_monom :
   assumes notInKeys : "x \<notin> keys m"
   assumes notZero : "a \<noteq> 0"
   shows "isolate_variable_sparse (MPoly_Type.monom m a) x 0 = (MPoly_Type.monom m a :: real mpoly)"
   using assms
   by (auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_eq_zero_iff in_keys_iff)
     (metis lookup_update_self)
 
 lemma isolate_variable_spase_zero : "lookup m x = 0 \<Longrightarrow>
     insertion (nth L) ((MPoly_Type.monom m a)::real mpoly) = 0 \<Longrightarrow>
     a \<noteq> 0 \<Longrightarrow> insertion (nth L) (isolate_variable_sparse (MPoly_Type.monom m a) x 0) = 0"
   by (simp add: isovarspase_monom lookup_eq_zero_in_keys_contradict notInKeys_notInVars)
 
 lemma isovarsparNotIn : "x \<notin> vars (p::real mpoly) \<Longrightarrow> isolate_variable_sparse p x 0 = p"
 proof(induction p rule: mpoly_induct)
   case (monom m a)
   then show ?case
     apply(cases "a=0")
     by (simp_all add: isovarspase_monom vars_monom_keys)
 next
   case (sum p1 p2 m a)
   then show ?case 
     by (simp add: monomials.rep_eq vars_add_monom isovarspar_sum)
 qed
 
 
 lemma degree0isovarspar :
   assumes deg0 : "MPoly_Type.degree (p::real mpoly) x = 0"
   shows "isolate_variable_sparse p x 0 = p"
 proof -
   have h1 : "p = (\<Sum>i::nat \<le>MPoly_Type.degree p x. isolate_variable_sparse p x i * Var x ^ i)"
     using sum_over_zero by auto
   have h2a : "\<forall>f. (\<Sum>i::nat \<le>0. f i) = f 0"
     apply(simp add: sum_def)
     by (metis add.right_neutral comm_monoid_add_class.sum_def finite.emptyI insert_absorb insert_not_empty sum.empty sum.insert)
   have h2 : "p = isolate_variable_sparse p x 0 * Var x ^ 0"
     using deg0 h1 h2a by auto
   show ?thesis using h2
     by auto 
 qed
 
 
 subsection "Summation Lemmas"
 
 lemma summation_normalized :
   assumes nonzero : "(B ::real) \<noteq>0"
   shows "(\<Sum>i = 0..<((n::nat)+1). (f i :: real) * B ^ (n - i)) = (\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * (B^n)"
 proof -
   have h1a : "\<forall>x::real. ((\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * x = (\<Sum>i = 0..<(n+1). ((f i) / (B ^ i)) * x))"  
     apply(induction n )
      apply(auto)
     by (simp add: distrib_right)
   have h1 : "(\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * (B^n) = (\<Sum>i = 0..<(n+1). ((f i) / (B ^ i)) * (B^n))"
     using h1a by auto
   have h2 : "(\<Sum>i = 0..<(n+1). ((f i) / (B ^ i)) * (B^n)) = (\<Sum>i = 0..<(n+1). (f i) * ((B^n) / (B ^ i)))"
     by auto
   have h3 : "(\<Sum>i = 0..<(n+1). (f i) * ((B^n) / (B ^ i))) = (\<Sum>i = 0..<(n+1). (f i) * B ^ (n - i))"
     using add.right_neutral nonzero power_diff by fastforce
   show ?thesis using h1 h2 h3 by auto
 qed
 
 lemma normalize_summation :
   assumes nonzero : "(B::real)\<noteq>0"
   shows "(\<Sum>i = 0..<n+1. f i * B ^ (n - i))= 0
           \<longleftrightarrow>
   (\<Sum>i = 0..<(n::nat)+1. (f i::real) / (B ^ i)) = 0"
 proof - 
   have pow_zero : "\<forall>i. B^(i :: nat)\<noteq>0" using nonzero by(auto)
   have single_division_zero : "\<forall>X. B*(X::real)=0 \<longleftrightarrow> X=0" using nonzero by(auto)
   have h1: "(\<Sum>i = 0..<n+1. (f i) / (B ^ i)) = 0 \<longleftrightarrow> ((\<Sum>i = 0..<n+1. (f i) / (B ^ i)))*B^n = 0"
     using nonzero single_division_zero by(auto)
   have h2: "((\<Sum>i = 0..<n+1. (f i) / (B ^ i))*(B^n)) = ((\<Sum>i = 0..<n+1. (f i) * (B ^ (n- i))))"
     using summation_normalized nonzero by auto
   show ?thesis using h1 h2 by auto
 qed
 
 
 lemma normalize_summation_less :
   assumes nonzero : "(B::real)\<noteq>0"
   shows "(\<Sum>i = 0..<(n+1). (f i) * B ^ (n - i)) * B ^ (n mod 2) < 0
           \<longleftrightarrow>
   (\<Sum>i = 0..<((n::nat)+1). (f i::real) / (B ^ i)) < 0"
 proof - 
   have h1 : "(\<Sum>i = 0..<(n+1). (f i) * B ^ (n - i)) * B ^ (n mod 2) < 0
         \<longleftrightarrow>  (\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * (B^n) * B ^ (n mod 2) < 0"
     using summation_normalized nonzero by auto
   have h2a : "n mod 2 = 0 \<or> n mod 2 = 1" by auto
   have h2b : "n mod 2 = 1 \<Longrightarrow> odd n" by auto
   have h2c : "(B^n) * B ^ (n mod 2) > 0"
     using h2a h2b apply auto
     using nonzero apply presburger
     by (metis even_Suc mult.commute nonzero power_Suc zero_less_power_eq)    
   have h2 : "\<forall>x. ((x * (B^n) * B ^ (n mod 2) < 0) = (x<0))"
     using h2c using mult.assoc by (metis mult_less_0_iff not_square_less_zero) 
   show ?thesis using h1 h2 by auto
 qed
 
 subsection "Additional Lemmas with Vars"
 
 lemma not_in_isovarspar : "isolate_variable_sparse (p::real mpoly) var x = (q::real mpoly) \<Longrightarrow> var\<notin>(vars q)"
   apply(simp add: isolate_variable_sparse_def vars_def)
 proof -
   assume a1: "MPoly (\<Sum>m | m \<in> monomials p \<and> lookup m var = x. monomial (MPoly_Type.coeff p m) (Poly_Mapping.update var 0 m)) = q"
   { fix pp :: "nat \<Rightarrow>\<^sub>0 nat"
     have "isolate_variable_sparse p var x = q"
       using a1 isolate_variable_sparse.abs_eq by blast
     then have "var \<notin> keys pp \<or> pp \<notin> keys (mapping_of q)"
       by (metis (no_types) coeff_def coeff_isolate_variable_sparse in_keys_iff) }
   then show "\<forall>p\<in>keys (mapping_of q). var \<notin> keys p"
     by meson
 qed 
 
 lemma not_in_add : "var\<notin>(vars (p::real mpoly)) \<Longrightarrow> var\<notin>(vars (q::real mpoly)) \<Longrightarrow> var\<notin>(vars (p+q))"
   by (meson UnE in_mono vars_add)
 
 lemma not_in_mult : "var\<notin>(vars (p::real mpoly)) \<Longrightarrow> var\<notin>(vars (q::real mpoly)) \<Longrightarrow> var\<notin>(vars (p*q))"
   by (meson UnE in_mono vars_mult)
 
 lemma not_in_neg : "var\<notin>(vars(p::real mpoly)) \<longleftrightarrow> var\<notin>(vars(-p))"
 proof -
   have h: "var \<notin> (vars (-1::real mpoly))" by (metis add_diff_cancel_right' add_neg_numeral_special(8) isolate_var_one isolate_zero isovarsparNotIn isovarspar_sum not_in_isovarspar)
   show ?thesis using not_in_mult using h by fastforce
 qed
 
 lemma not_in_sub : "var\<notin>(vars (p::real mpoly)) \<Longrightarrow> var\<notin>(vars (q::real mpoly)) \<Longrightarrow> var\<notin>(vars (p-q))"
   using not_in_add not_in_neg by fastforce
 
 
 lemma not_in_pow : "var\<notin>(vars(p::real mpoly)) \<Longrightarrow> var\<notin>(vars(p^i))"
 proof (induction i)
   case 0
   then show ?case using isolate_var_one not_in_isovarspar
     by (metis power_0) 
 next 
   case (Suc i)
   then show ?case using not_in_mult by simp
 qed
 
 lemma not_in_sum_var: "(\<forall>i. var\<notin>(vars(f(i)::real mpoly))) \<Longrightarrow> var\<notin>(vars(\<Sum>i\<in>{0..<(n::nat)}.f(i)))"
 proof (induction n)
   case 0
   then show ?case using isolate_zero not_in_isovarspar by fastforce
 next
   case (Suc n)
   have h1: "(sum f {0..<Suc n}) = (sum f {0..< n}) + (f n)" using sum.atLeast0_lessThan_Suc by blast
   have h2: "var \<notin> vars (f n)" by (simp add: Suc.prems)
   then show ?case using h1 vars_add by (simp add: Suc.IH Suc.prems not_in_add)
 qed
 
 lemma not_in_sum : "(\<forall>i. var\<notin>(vars(f(i)::real mpoly))) \<Longrightarrow> \<forall>(n::nat). var\<notin>(vars(\<Sum>i\<in>{0..<n}.f(i)))"
   using not_in_sum_var by blast
 
 lemma not_contains_insertion_helper : 
   "\<forall>x\<in>keys (mapping_of p). var \<notin> keys x \<Longrightarrow>
          (\<And>k f. (k \<notin> keys f) = (lookup f k = 0)) \<Longrightarrow>
          lookup (mapping_of p) a = 0 \<or>
          (\<Prod>aa. (if aa < length L then L[var := y] ! aa else 0) ^ lookup a aa) =
          (\<Prod>aa. (if aa < length L then L[var := x] ! aa else 0) ^ lookup a aa)"
   apply(cases "lookup (mapping_of p) a = 0") 
    apply auto
   apply(rule Prod_any.cong) 
   apply auto
   using lookupNotIn nth_list_update_neq power_0 by smt
 
 lemma not_contains_insertion : 
   assumes notIn : "var \<notin> vars (p:: real mpoly)"
   assumes exists : "insertion (nth_default 0 (list_update L var x)) p = val"
   shows "insertion (nth_default 0 (list_update L var y)) p = val"
   using notIn exists
   apply(simp add: insertion_def insertion_aux_def insertion_fun_def)
   unfolding vars_def nth_default_def
   using not_in_keys_iff_lookup_eq_zero  
   apply auto
   apply(rule Sum_any.cong) 
   apply simp
   using not_contains_insertion_helper[of p var _ L y x]
 proof -
   fix a :: "nat \<Rightarrow>\<^sub>0 nat"
   assume a1: "\<forall>x\<in>keys (mapping_of p). var \<notin> keys x"
   assume "\<And>k f. ((k::'a) \<notin> keys f) = (lookup f k = 0)"
   then show "lookup (mapping_of p) a = 0 \<or> (\<Prod>n. (if n < length L then L[var := y] ! n else 0) ^ lookup a n) = (\<Prod>n. (if n < length L then L[var := x] ! n else 0) ^ lookup a n)"
     using a1 \<open>\<And>a. \<lbrakk>\<forall>x\<in>keys (mapping_of p). var \<notin> keys x; \<And>k f. (k \<notin> keys f) = (lookup f k = 0)\<rbrakk> \<Longrightarrow> lookup (mapping_of p) a = 0 \<or> (\<Prod>aa. (if aa < length L then L[var := y] ! aa else 0) ^ lookup a aa) = (\<Prod>aa. (if aa < length L then L[var := x] ! aa else 0) ^ lookup a aa)\<close> by blast
 qed
 
 
 subsection "Insertion Lemmas"
 lemma insertion_sum_var : "((insertion f (\<Sum>i\<in>{0..<(n::nat)}.g(i))) = (\<Sum>i\<in>{0..<n}. insertion f (g i)))"
 proof (induction n)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then show ?case by (simp add: insertion_add)
 qed
 
 (* changed to explicitly typecast n as a nat *)
 lemma insertion_sum : "\<forall>(n::nat). ((insertion f (\<Sum>i\<in>{0..<n}.g(i))) = (\<Sum>i\<in>{0..<n}. insertion f (g i)))"
   using insertion_sum_var by blast
 
 
 lemma insertion_sum' : "\<And>(n::nat). ((insertion f (\<Sum>i\<le>n. g(i))) = (\<Sum>i\<le>n. insertion f (g i)))"
   by (metis (no_types, lifting) fun_sum_commute insertion_add insertion_zero sum.cong) 
 
 lemma insertion_pow : "insertion f (p^i) = (insertion f p)^i"
 proof (induction i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then show ?case by (simp add: insertion_mult)
 qed
 
 lemma insertion_neg : "insertion f (-p) = -insertion f p"
   by (metis add.inverse_inverse insertionNegative)
 
 lemma insertion_var : 
   "length L > var \<Longrightarrow> insertion (nth_default 0 (list_update L var x)) (Var var) = x"
   by (auto simp: monomials_Var coeff_Var insertion_code nth_default_def)
 
 lemma insertion_var_zero : "insertion (nth_default 0 (x#xs)) (Var 0) = x" using insertion_var
   by fastforce
 
 lemma notIn_insertion_sub : "x\<notin>vars(p::real mpoly) \<Longrightarrow> x\<notin>vars(q::real mpoly)
                              \<Longrightarrow> insertion f (p-q) = insertion f p - insertion f q"
   by (metis ab_group_add_class.ab_diff_conv_add_uminus insertion_add insertion_neg)
 
 lemma insertion_sub : "insertion f (A-B :: real mpoly) = insertion f A - insertion f B"
   using insertion_neg insertion_add
   by (metis uminus_add_conv_diff)
 
 lemma insertion_four : "insertion ((nth_default 0) xs) 4 = 4"
   by (metis (no_types, lifting) insertion_add insertion_one numeral_plus_numeral one_add_one semiring_norm(2) semiring_norm(6))
 
 lemma insertion_add_ind_basecase:
   "insertion (nth (list_update L var x)) ((\<Sum>i::nat \<le> 0. isolate_variable_sparse p var i * (Var var)^i))
   = (\<Sum>i = 0..<(0+1).  insertion (nth (list_update L var x)) (isolate_variable_sparse p var i * (Var var)^i))"
 proof - 
   have h1: "((\<Sum>i::nat \<le> 0. isolate_variable_sparse p var i * (Var var)^i))
    = (isolate_variable_sparse p var 0 * (Var var)^0)"
     by auto
   show ?thesis using h1
     by auto 
 qed
 
 lemma insertion_add_ind:
   "insertion (nth_default 0 (list_update L var x)) ((\<Sum>i::nat \<le> d. isolate_variable_sparse p var i * (Var var)^i))
   = (\<Sum>i = 0..<(d+1).  insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse p var i * (Var var)^i))"
 proof (induction d)
   case 0
   then show ?case using insertion_add_ind_basecase nth_default_def
     by auto
 next
   case (Suc n)
   then show ?case using insertion_add apply auto
     by (simp add: insertion_add)
 qed
 
 lemma sum_over_degree_insertion :
   assumes lLength : "length L > var"
   assumes deg : "MPoly_Type.degree (p::real mpoly) var = d"
   shows "(\<Sum>i = 0..<(d+1). insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse p var i) * (x^i))
           = insertion (nth_default 0 (list_update L var x)) p"
 proof -
   have h1: "(p::real mpoly) = (\<Sum>i::nat \<le>(MPoly_Type.degree p var). isolate_variable_sparse p var i * (Var var)^i)" using sum_over_zero by auto
   have h2: "insertion (nth_default 0 (list_update L var x)) p = 
     insertion (nth_default 0 (list_update L var x)) ((\<Sum>i::nat \<le> d. isolate_variable_sparse p var i * (Var var)^i))" using h1 deg by auto
   have h3:  "insertion (nth_default 0 (list_update L var x)) p = (\<Sum>i = 0..<(d+1).  insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse p var i * (Var var)^i))"
     using h2 insertion_add_ind nth_default_def
     by simp
   show ?thesis using h3 insertion_var insertion_pow
     by (metis (no_types, lifting) insertion_mult lLength sum.cong)
 qed
 
 
 
 lemma insertion_isovarspars_free :
   "insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse (p::real mpoly) var (i::nat))
   =insertion (nth_default 0 (list_update L var y)) (isolate_variable_sparse (p::real mpoly) var (i::nat))"
 proof -
   have h : "var \<notin> vars(isolate_variable_sparse (p::real mpoly) var (i::nat))"
     by (simp add: not_in_isovarspar)
   then show ?thesis using not_contains_insertion
     by blast 
 qed
 lemma insertion_zero : "insertion f (Const 0 ::real mpoly) = 0"
   by (metis add_cancel_right_right add_zero insertion_zero)
 
 lemma insertion_one : "insertion f (Const 1 ::real mpoly) = 1"
   by (metis insertion_one mult.right_neutral mult_one_left)
 
 lemma insertion_const : "insertion f (Const c::real mpoly) = (c::real)"
   by (auto simp: monomials_Const coeff_Const insertion_code)
 
 
 subsection "Putting Things Together"
 subsubsection "More Degree Lemmas"
 lemma degree_add_leq : 
   assumes h1 : "MPoly_Type.degree a var \<le> x"
   assumes h2 : "MPoly_Type.degree b var \<le> x"
   shows "MPoly_Type.degree (a+b) var \<le> x"
   using degree_eq_iff coeff_add coeff_not_in_monomials
   by (smt (z3) More_MPoly_Type.coeff_add add.left_neutral coeff_eq_zero_iff degree_le_iff h1 h2)
 
 lemma degree_add_less : 
   assumes h1 : "MPoly_Type.degree a var < x"
   assumes h2 : "MPoly_Type.degree b var < x"
   shows "MPoly_Type.degree (a+b) var < x"
-proof -
-  obtain pp :: "nat \<Rightarrow> nat \<Rightarrow> 'a mpoly \<Rightarrow> nat \<Rightarrow>\<^sub>0 nat" where
-    "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> monomials x2 \<and> \<not> lookup v3 x1 < x0) = (pp x0 x1 x2 \<in> monomials x2 \<and> \<not> lookup (pp x0 x1 x2) x1 < x0)"
-    by moura
-  then have f1: "\<forall>m n na. (\<not> MPoly_Type.degree m n < na \<or> 0 < na \<and> (\<forall>p. p \<notin> monomials m \<or> lookup p n < na)) \<and> (MPoly_Type.degree m n < na \<or> \<not> 0 < na \<or> pp na n m \<in> monomials m \<and> \<not> lookup (pp na n m) n < na)"
-    by (metis (no_types) degree_less_iff)
-  then have "0 < x \<and> (\<forall>p. p \<notin> monomials a \<or> lookup p var < x)"
-    using assms(1) by presburger
-  then show ?thesis
-    using f1 by (metis MPolyExtension.coeff_add add.left_neutral assms(2) coeff_eq_zero_iff)
-qed
+  by (metis degree_add_leq h1 h2 linorder_not_le nat_less_le)
 
 lemma degree_sum : "(\<forall>i\<in>{0..n::nat}. MPoly_Type.degree (f i :: real mpoly) var \<le> x) \<Longrightarrow> (MPoly_Type.degree (\<Sum>x\<in>{0..n}. f x) var) \<le> x"
 proof(induction n)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then show ?case by(simp add: degree_add_leq)
 qed
 
 lemma degree_sum_less : "(\<forall>i\<in>{0..n::nat}. MPoly_Type.degree (f i :: real mpoly) var < x) \<Longrightarrow> (MPoly_Type.degree (\<Sum>x\<in>{0..n}. f x) var) < x"
 proof(induction n)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then show ?case by(simp add: degree_add_less)
 qed
 
 
 lemma varNotIn_degree : 
   assumes "var \<notin> vars p"
   shows "MPoly_Type.degree p var = 0"
 proof-
   have "\<forall>m\<in>monomials p. lookup m var = 0"
     using assms unfolding vars_def keys_def
     using monomials.rep_eq by fastforce
   then show ?thesis
     using degree_less_iff by blast
 qed
 
 lemma degree_mult_leq : 
   assumes pnonzero: "(p::real mpoly)\<noteq>0"
   assumes qnonzero: "(q::real mpoly)\<noteq>0"
   shows "MPoly_Type.degree ((p::real mpoly) * (q::real mpoly)) var \<le> (MPoly_Type.degree p var) + (MPoly_Type.degree q var)"
 proof(cases "MPoly_Type.degree (p*q) var =0")
   case True
   then show ?thesis by simp
 next
   case False
   have hp: "\<forall>m\<in>monomials p. lookup m var \<le> MPoly_Type.degree p var" using degree_eq_iff
     by (metis zero_le) 
   have hq: "\<forall>m\<in>monomials q. lookup m var \<le> MPoly_Type.degree q var" using degree_eq_iff
     by (metis zero_le) 
   have hpq: "\<forall>m\<in>{a+b | a b . a \<in> monomials p \<and> b \<in> monomials q}.
       lookup m var \<le> (MPoly_Type.degree p var) + (MPoly_Type.degree q var)"
     by (smt add_le_mono hp hq mem_Collect_eq plus_poly_mapping.rep_eq)
   have h1: "(\<forall>m\<in>monomials (p*q). lookup m var \<le> (MPoly_Type.degree p var) + (MPoly_Type.degree q var))" 
     using mult_monomials_dir_one hpq
     by blast 
   then show ?thesis using h1 degree_eq_iff False
     by (simp add: degree_le_iff)
 qed
 
 lemma degree_exists_monom: 
   assumes "p\<noteq>0"
   shows  "\<exists>m\<in>monomials p. lookup m var = MPoly_Type.degree p var"
 proof(cases "MPoly_Type.degree p var =0")
   case True
   have h1: "\<exists>m\<in>monomials p. lookup m var = 0" unfolding monomials_def
     by (metis True assms(1) aux degree_eq_iff in_keys_iff mapping_of_inject monomials.rep_eq monomials_def zero_mpoly.rep_eq)
   then show ?thesis using h1
     using True by simp
 next
   case False
   then show ?thesis using degree_eq_iff assms(1) apply(auto)
     by (metis degree_eq_iff dual_order.strict_iff_order) 
 qed
 
 lemma degree_not_exists_monom: 
   assumes "p\<noteq>0"
   shows  "\<not> (\<exists> m\<in>monomials p. lookup m var > MPoly_Type.degree p var)"
 proof - 
   show ?thesis using degree_less_iff by blast 
 qed
 
 lemma degree_monom: "MPoly_Type.degree (MPoly_Type.monom x y) v = (if y = 0 then 0 else lookup x v)"
   by (auto simp: degree_eq_iff)
 
 lemma degree_plus_disjoint:
   "MPoly_Type.degree (p + MPoly_Type.monom m c) v = max (MPoly_Type.degree p v) (MPoly_Type.degree (MPoly_Type.monom m c) v)"
   if "m \<notin> monomials p"
   for p::"real mpoly"
   using that
   apply (subst degree_eq_iff)
   apply (auto simp: monomials_add_disjoint)
             apply (auto simp: degree_eq_iff degree_monom)
        apply (metis MPoly_Type.degree_zero degree_exists_monom less_numeral_extra(3))
   using degree_le_iff apply blast
   using degree_eq_iff
      apply (metis max_def neq0_conv)
     apply (metis degree_eq_iff max.coboundedI1 neq0_conv)
    apply (metis MPoly_Type.degree_zero degree_exists_monom max_def zero_le)
   using degree_le_iff max.cobounded1 by blast
 
 subsubsection "More isolate\\_variable\\_sparse lemmas"
 
 lemma isolate_variable_sparse_ne_zeroD:
   "isolate_variable_sparse mp v x \<noteq> 0 \<Longrightarrow> x \<le> MPoly_Type.degree mp v"
   using isovar_greater_degree leI by blast
 
 context includes poly.lifting begin
 lift_definition mpoly_to_nested_poly::"'a::comm_monoid_add mpoly \<Rightarrow> nat \<Rightarrow> 'a mpoly Polynomial.poly" is
   "\<lambda>(mp::'a mpoly) (v::nat) (p::nat). isolate_variable_sparse mp v p"
   \<comment> \<open>note \<^const>\<open>extract_var\<close> nests the other way around\<close>
   unfolding MOST_iff_cofinite
 proof -
   fix mp::"'a mpoly" and v::nat
   have "{p. isolate_variable_sparse mp v p \<noteq> 0} \<subseteq> {0..MPoly_Type.degree mp v}"
     (is "?s \<subseteq> _")
     by (auto dest!: isolate_variable_sparse_ne_zeroD)
   also have "finite \<dots>" by simp
   finally (finite_subset) show "finite ?s" .
 qed
 
 lemma degree_eq_0_mpoly_to_nested_polyI:
   "mpoly_to_nested_poly mp v = 0 \<Longrightarrow> MPoly_Type.degree mp v = 0"
   apply transfer'
   apply (simp add: degree_eq_iff)
   apply transfer'
   apply (auto simp: fun_eq_iff)
 proof -
   fix mpa :: "'a mpoly" and va :: nat and m :: "nat \<Rightarrow>\<^sub>0 nat"
   assume a1: "\<forall>x. (\<Sum>m | m \<in> monomials mpa \<and> lookup m va = x. monomial (MPoly_Type.coeff mpa m) (Poly_Mapping.update va 0 m)) = 0"
   assume a2: "m \<in> monomials mpa"
   have f3: "\<forall>m p. lookup (mapping_of m) p \<noteq> (0::'a) \<or> p \<notin> monomials m"
     by (metis (full_types) coeff_def coeff_eq_zero_iff)
   have f4: "\<forall>n. mapping_of (isolate_variable_sparse mpa va n) = 0"
     using a1 by (simp add: isolate_variable_sparse.rep_eq)
   have "\<forall>p n. lookup 0 (p::nat \<Rightarrow>\<^sub>0 nat) = (0::'a) \<or> (0::nat) = n"
     by simp
   then show "lookup m va = 0"
     using f4 f3 a2 by (metis coeff_def coeff_isolate_variable_sparse lookup_eq_and_update_lemma)
 qed
 
 lemma coeff_eq_zero_mpoly_to_nested_polyD: "mpoly_to_nested_poly mp v = 0 \<Longrightarrow> MPoly_Type.coeff mp 0 = 0"
   apply transfer'
   apply transfer'
   by (metis (no_types) coeff_def coeff_isolate_variable_sparse isolate_variable_sparse.rep_eq lookup_zero update_0_0)
 
 lemma mpoly_to_nested_poly_eq_zero_iff[simp]:
   "mpoly_to_nested_poly mp v = 0 \<longleftrightarrow> mp = 0"
   apply (auto simp: coeff_eq_zero_mpoly_to_nested_polyD degree_eq_0_mpoly_to_nested_polyI)
 proof -
   show "mpoly_to_nested_poly mp v = 0 \<Longrightarrow> mp = 0" 
     apply (frule degree_eq_0_mpoly_to_nested_polyI)
     apply (frule coeff_eq_zero_mpoly_to_nested_polyD)
     apply (transfer' fixing: mp v)
     apply (transfer' fixing: mp v)
     apply (auto simp: fun_eq_iff mpoly_eq_iff intro!: sum.neutral)
   proof -
     fix m :: "nat \<Rightarrow>\<^sub>0 nat"
     assume a1: "\<forall>x. (\<Sum>m | m \<in> monomials mp \<and> lookup m v = x. monomial (MPoly_Type.coeff mp m) (Poly_Mapping.update v 0 m)) = 0"
     assume a2: "MPoly_Type.degree mp v = 0"
     have "\<forall>n. isolate_variable_sparse mp v n = 0"
       using a1 by (simp add: isolate_variable_sparse.abs_eq zero_mpoly.abs_eq)
     then have f3: "\<forall>p. MPoly_Type.coeff mp p = MPoly_Type.coeff 0 p \<or> lookup p v \<noteq> 0"
       by (metis (no_types) coeff_isolate_variable_sparse lookup_update_self)
     then show "MPoly_Type.coeff mp m = 0"
       using a2 coeff_zero
       by (metis coeff_not_in_monomials degree_eq_iff)
   qed
   show "mp = 0 \<Longrightarrow> mpoly_to_nested_poly 0 v = 0" 
     subgoal
       apply transfer'
       apply transfer'
       by (auto simp: fun_eq_iff intro!: sum.neutral)
     done
 qed
 
 lemma isolate_variable_sparse_degree_eq_zero_iff: "isolate_variable_sparse p v (MPoly_Type.degree p v) = 0 \<longleftrightarrow> p = 0"
   apply (transfer')
   apply auto
 proof -
   fix pa :: "'a mpoly" and va :: nat
   assume "(\<Sum>m | m \<in> monomials pa \<and> lookup m va = MPoly_Type.degree pa va. monomial (MPoly_Type.coeff pa m) (Poly_Mapping.update va 0 m)) = 0"
   then have "mapping_of (isolate_variable_sparse pa va (MPoly_Type.degree pa va)) = 0"
     by (simp add: isolate_variable_sparse.rep_eq)
   then show "pa = 0"
     by (metis (no_types) coeff_def coeff_eq_zero_iff coeff_isolate_variable_sparse degree_exists_monom lookup_eq_and_update_lemma lookup_zero)
 qed
 
 lemma degree_eq_univariate_degree: "MPoly_Type.degree p v =
     (if p = 0 then 0 else Polynomial.degree (mpoly_to_nested_poly p v))"
   apply auto
   apply (rule antisym)
   subgoal
     apply (rule Polynomial.le_degree)
     apply auto
     apply transfer'
     by (simp add: isolate_variable_sparse_degree_eq_zero_iff)
   subgoal apply (rule Polynomial.degree_le)
     apply (auto simp: elim!: degree_eq_zeroE)
     apply transfer'
     by (simp add: isovar_greater_degree)
   done
 
 lemma compute_mpoly_to_nested_poly[code]:
   "coeffs (mpoly_to_nested_poly mp v) =
     (if mp = 0 then []
     else map (isolate_variable_sparse mp v) [0..<Suc(MPoly_Type.degree mp v)])"
   unfolding coeffs_def unfolding mpoly_to_nested_poly_eq_zero_iff degree_eq_univariate_degree apply auto
   subgoal by transfer' (rule refl)
   by transfer' (rule refl)
 
 end
 
 lemma isolate_variable_sparse_monom: "isolate_variable_sparse (MPoly_Type.monom m a) v i =
   (if a = 0 \<or> lookup m v \<noteq> i then 0 else MPoly_Type.monom (Poly_Mapping.update v 0 m) a)"
 proof -
   have *: "{x. x = m \<and> lookup x v = i} = (if lookup m v = i then {m} else {})"
     by auto
   show ?thesis
     by (transfer' fixing: m a v i) (simp add:*)
 qed
 
 
 
 lemma isolate_variable_sparse_monom_mult:
   "isolate_variable_sparse (MPoly_Type.monom m a * q) v n =
     (if n \<ge> lookup m v
     then MPoly_Type.monom (Poly_Mapping.update v 0 m) a * isolate_variable_sparse q v (n - lookup m v)
     else 0)"
   for q::"'a::semiring_no_zero_divisors mpoly"
   apply (auto simp: MPoly_Type.mult_monom)
   subgoal
     apply transfer'
     subgoal for mon v i a q
       apply (auto simp add: monomials_monom_mult sum_distrib_left)
       apply (rule sum.reindex_bij_witness_not_neutral[where
             j="\<lambda>a. a - mon"
             and i="\<lambda>a. mon + a"
             and S'="{}"
             and T'="{}"
             ])
               apply (auto simp: lookup_add)
       apply (auto simp: poly_mapping_eq_iff fun_eq_iff single.rep_eq Poly_Mapping.mult_single)
       apply (auto simp: when_def More_MPoly_Type.coeff_monom_mult)
       by (auto simp: lookup_update lookup_add split: if_splits)
     done
   subgoal
     apply transfer'
     apply (auto intro!: sum.neutral simp: monomials_monom_mult )
     apply (rule poly_mapping_eqI)
     apply (auto simp: lookup_single when_def)
     by (simp add: lookup_add)
   done
 
 lemma isolate_variable_sparse_mult:
   "isolate_variable_sparse (p * q) v n = (\<Sum>i\<le>n. isolate_variable_sparse p v i * isolate_variable_sparse q v (n - i))"
   for p q::"'a::semiring_no_zero_divisors mpoly"
 proof (induction p rule: mpoly_induct)
   case (monom m a)
   then show ?case
     by (cases "a = 0")
       (auto simp add: mpoly_eq_iff coeff_sum coeff_mult if_conn if_distrib if_distribR
         isolate_variable_sparse_monom isolate_variable_sparse_monom_mult
         cong: if_cong)
 next
   case (sum p1 p2 m a)
   then show ?case
     by (simp add: distrib_right isovarspar_sum sum.distrib)
 qed
 
 subsubsection "More Miscellaneous"
 lemma var_not_in_Const : "var\<notin>vars (Const x :: real mpoly)"
   unfolding vars_def keys_def
   by (smt UN_iff coeff_def coeff_isolate_variable_sparse const_lookup_zero keys_def lookup_eq_zero_in_keys_contradict) 
 
 lemma mpoly_to_nested_poly_mult:
   "mpoly_to_nested_poly (p * q) v = mpoly_to_nested_poly p v * mpoly_to_nested_poly q v"
   for p q::"'a::{comm_semiring_0, semiring_no_zero_divisors} mpoly"
   by (auto simp: poly_eq_iff coeff_mult mpoly_to_nested_poly.rep_eq isolate_variable_sparse_mult)
 
 lemma get_if_const_insertion : 
   assumes "get_if_const (p::real mpoly) = Some r"
   shows "insertion f p = r"
 proof-
   have "Set.is_empty (vars p)"
     apply(cases "Set.is_empty (vars p)")
      apply(simp) using assms by(simp)
   then have "(MPoly_Type.coeff p 0) = r"
     using assms by simp
   then show ?thesis
     by (metis Set.is_empty_def \<open>Set.is_empty (vars p)\<close> empty_iff insertion_irrelevant_vars insertion_trivial)
 qed
 
 subsubsection "Yet more Degree Lemmas"
 lemma degree_mult:
   fixes p q::"'a::{comm_semiring_0, ring_1_no_zero_divisors} mpoly"
   assumes "p \<noteq> 0"
   assumes "q \<noteq> 0"
   shows "MPoly_Type.degree (p * q) v = MPoly_Type.degree p v + MPoly_Type.degree q v"
   using assms
   by (auto simp add: degree_eq_univariate_degree mpoly_to_nested_poly_mult Polynomial.degree_mult_eq)
 
 lemma degree_eq:
   assumes "(p::real mpoly) = (q:: real mpoly)"
   shows "MPoly_Type.degree p x = MPoly_Type.degree q x"
   by (simp add: assms)
 
 lemma degree_var_i : "MPoly_Type.degree (((Var x)^i:: real mpoly)) x = i"
 proof (induct i)
   case 0
   then show ?case using degree_const
     by simp
 next
   case (Suc i)
   have multh: "(Var x)^(Suc i) = ((Var x)^i::real mpoly) * (Var x:: real mpoly)"
     using power_Suc2 by blast
   have deg0h: "MPoly_Type.degree 0 x = 0"
     by simp
   have deg1h: "MPoly_Type.degree (Var x::real mpoly) x = 1"
     using degree_one
     by blast 
   have nonzeroh1: "(Var x:: real mpoly) \<noteq> 0" 
     using degree_eq deg0h deg1h by auto 
   have nonzeroh2: "((Var x)^i:: real mpoly) \<noteq> 0" 
     using degree_eq deg0h Suc.hyps
     by (metis one_neq_zero power_0) 
   have sumh: "(MPoly_Type.degree (((Var x)^i:: real mpoly) * (Var x:: real mpoly)) x) = (MPoly_Type.degree ((Var x)^i::real mpoly) x) + (MPoly_Type.degree (Var x::real mpoly) x)"
     using degree_mult[where p = "(Var x)^i::real mpoly", where q = "Var x::real mpoly"]  nonzeroh1 nonzeroh2
     by blast 
   then show ?case using sumh deg1h
     by (metis Suc.hyps Suc_eq_plus1 multh) 
 qed
 
 
 lemma degree_less_sum: 
   assumes "MPoly_Type.degree (p::real mpoly) var = n"
   assumes "MPoly_Type.degree (q::real mpoly) var = m"
   assumes "m < n"
   shows "MPoly_Type.degree (p + q) var = n"
 proof - 
   have h1: "n > 0"
     using assms(3) neq0_conv by blast
   have h2: "(\<exists>m\<in>monomials p. lookup m var = n) \<and> (\<forall>m\<in>monomials p. lookup m var \<le> n)"
     using degree_eq_iff assms(1)
     by (metis degree_ge_iff h1 order_refl)
   have h3: "(\<exists>m\<in>monomials (p + q). lookup m var = n)"
     using h2
     by (metis MPolyExtension.coeff_add add.right_neutral assms(2) assms(3) coeff_eq_zero_iff degree_not_exists_monom) 
   have h4: "(\<forall>m\<in>monomials (p + q). lookup m var \<le> n)"
     using h2 assms(3) assms(2)
     using degree_add_leq degree_le_iff dual_order.strict_iff_order by blast
   show ?thesis using degree_eq_iff h3 h4
     by (metis assms(3) gr_implies_not0) 
 qed
 
 lemma degree_less_sum': 
   assumes "MPoly_Type.degree (p::real mpoly) var = n"
   assumes "MPoly_Type.degree (q::real mpoly) var = m"
   assumes "n < m"
   shows "MPoly_Type.degree (p + q) var = m" using degree_less_sum[OF assms(2) assms(1) assms(3)]
   by (simp add: add.commute) 
 
 (* Result on the degree of the derivative  *)
 
 lemma nonzero_const_is_nonzero: 
   assumes "(k::real) \<noteq> 0"
   shows "((Const k)::real mpoly) \<noteq> 0"
   by (metis MPoly_Type.insertion_zero assms insertion_const)
 
 lemma degree_derivative : 
   assumes "MPoly_Type.degree p x > 0"
   shows "MPoly_Type.degree p x = MPoly_Type.degree (derivative x p) x + 1"
 proof -
   define f where "f i = (isolate_variable_sparse p x (i+1) * (Var x)^(i) * (Const (i+1)))" for i
   define n where "n = MPoly_Type.degree p x-1"
   have d : "\<exists>m\<in>monomials p. lookup m x = n+1"
     using n_def degree_eq_iff assms
     by (metis add.commute less_not_refl2 less_one linordered_semidom_class.add_diff_inverse)    
   have h1a : "\<forall>i. MPoly_Type.degree (isolate_variable_sparse p x i) x = 0"
     by (simp add: not_in_isovarspar varNotIn_degree)
   have h1b : "\<forall>i::nat. MPoly_Type.degree ((Var x)^i:: real mpoly) x = i"
     using degree_var_i by auto
   have h1c1 : "\<forall>i. (Var(x)^(i)::real mpoly)\<noteq>0"
     by (metis MPoly_Type.degree_zero h1b power_0 zero_neq_one)
   fix i
   have h1c1var: "((Var x)^i:: real mpoly) \<noteq> 0" using h1c1 by blast
   have h1c2 : "((Const ((i::nat) + 1))::real mpoly)\<noteq>0"
     using nonzero_const_is_nonzero
     by auto 
   have h1c3: "(isolate_variable_sparse p x (n + 1)) \<noteq> 0" using d
     by (metis One_nat_def Suc_pred add.commute assms isolate_variable_sparse_degree_eq_zero_iff n_def not_gr_zero not_in_isovarspar plus_1_eq_Suc varNotIn_degree)
   have h3: "(isolate_variable_sparse p x (i+1) = 0) \<longrightarrow> (MPoly_Type.degree (f i) x) = 0"
     by (simp add: f_def)
   have degh1: "(MPoly_Type.degree (((Const ((i::nat)+1))::real mpoly)*(Var x)^i) x) = 
     ((MPoly_Type.degree ((Const (i+1))::real mpoly) x) + (MPoly_Type.degree ((Var x)^i:: real mpoly) x))"
     using h1c2 h1c1var degree_mult[where p="((Const ((i::nat)+1))::real mpoly)", where q="((Var x)^i:: real mpoly)"]
     by blast
   then have degh2: "(MPoly_Type.degree (((Const ((i::nat)+1))::real mpoly)*(Var x)^i) x) = i" 
     using degree_var_i degree_const
     by simp 
   have nonzerohyp: "(((Const ((i::nat)+1))::real mpoly)*(Var x)^i) \<noteq> 0"
   proof (induct i)
     case 0
     then show ?case
       by (simp add: nonzero_const_is_nonzero) 
   next
     case (Suc i)
     then show ?case using degree_eq degh2
       by (metis Suc_eq_plus1 h1c1 mult_eq_0_iff nat.simps(3) nonzero_const_is_nonzero of_nat_eq_0_iff)
   qed
   have h4a1: "(isolate_variable_sparse p x (i+1) \<noteq> 0) \<longrightarrow> (MPoly_Type.degree (isolate_variable_sparse p x (i+1) * ((Var x)^(i) * (Const (i+1)))::real mpoly) x = 
       (MPoly_Type.degree (isolate_variable_sparse p x (i+1):: real mpoly) x) + (MPoly_Type.degree (((Const (i+1)) *  (Var x)^(i))::real mpoly) x))"
     using nonzerohyp degree_mult[where p = "(isolate_variable_sparse p x (i+1))::real mpoly", where q = "((Const (i+1)) *  (Var x)^(i)):: real mpoly", where v = "x"]
     by (simp add: mult.commute)
   have h4: "(isolate_variable_sparse p x (i+1) \<noteq> 0) \<longrightarrow> (MPoly_Type.degree (f i) x) = i"
     using h4a1 f_def degh2 h1a
     by (metis (no_types, lifting) degh1 degree_const h1b mult.commute mult.left_commute of_nat_1 of_nat_add)
   have h5: "(MPoly_Type.degree (f i) x) \<le> i" using h3 h4 by auto
   have h6: "(MPoly_Type.degree (f n) x) = n" using h1c3 h4
     by (smt One_nat_def add.right_neutral add_Suc_right degree_const degree_mult divisors_zero f_def h1a h1b h1c1 mult.commute nonzero_const_is_nonzero of_nat_1 of_nat_add of_nat_neq_0) 
   have h7a: "derivative x p = (\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. isolate_variable_sparse p x (i+1) * (Var x)^i * (Const (i+1)))" using derivative_def by auto
   have h7b: "(\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. isolate_variable_sparse p x (i+1) * (Var x)^i * (Const (i+1))) = (\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. (f i))" using f_def
     by (metis Suc_eq_plus1 add.commute semiring_1_class.of_nat_simps(2)) 
   have h7c: "derivative x p = (\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. (f i))" using h7a h7b by auto
   have h7: "derivative x p = (\<Sum>i\<in>{0..n}. (f i))" using n_def h7c
     by blast 
   have h8: "n > 0 \<longrightarrow> ((MPoly_Type.degree (\<Sum>i\<in>{0..(n-1)}. (f i)) x) < n)"
   proof (induct n)
     case 0
     then show ?case
       by blast 
   next
     case (Suc n)
     then show ?case using h5 degree_less_sum
       by (smt add_cancel_right_right atLeastAtMost_iff degree_const degree_mult degree_sum_less degree_var_i diff_Suc_1 f_def h1a le_imp_less_Suc mult.commute mult_eq_0_iff)
   qed 
   have h9a: "n = 0 \<longrightarrow> MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = n" using h6
     by auto   
   have h9b: "n > 0 \<longrightarrow> MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = n" 
   proof - 
     have h9bhyp: "n > 0 \<longrightarrow> (MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = MPoly_Type.degree ((\<Sum>i\<in>{0..(n-1)}. (f i)) + (f n)) x)"
       by (metis Suc_diff_1 sum.atLeast0_atMost_Suc)
     have h9bhyp2: "n > 0 \<longrightarrow> ((MPoly_Type.degree ((\<Sum>i\<in>{0..(n-1)}. (f i)) + (f n)) x) = n)" 
       using h6 h8 degree_less_sum
       by (simp add: add.commute) 
     then show ?thesis using h9bhyp2 h9bhyp
       by linarith
   qed
   have h9:  "MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = n" using h9a h9b
     by blast 
   have h10: "MPoly_Type.degree (derivative x p) x = n" using h9 h7
     by simp
   show ?thesis using h10 n_def
     using assms by linarith
 qed
 
 
 lemma express_poly :
   assumes h : "MPoly_Type.degree (p::real mpoly) var = 1 \<or> MPoly_Type.degree p var = 2"
   shows "p =
      (isolate_variable_sparse p var 2)*(Var var)^2
     +(isolate_variable_sparse p var 1)*(Var var)
     +(isolate_variable_sparse p var 0)"
 proof-
   have h1a: "MPoly_Type.degree p var = 1 \<longrightarrow> p =
     isolate_variable_sparse p var 0 + 
     isolate_variable_sparse p var 1 * Var var"
     using sum_over_zero[where mp="p",where x="var"]
     by auto
   have h1b: "MPoly_Type.degree p var = 1 \<longrightarrow> isolate_variable_sparse p var 2 = 0"
     using isovar_greater_degree
     by (simp add: isovar_greater_degree)
   have h1: "MPoly_Type.degree p var = 1 \<longrightarrow> p =
     isolate_variable_sparse p var 0 + 
     isolate_variable_sparse p var 1 * Var var
     + isolate_variable_sparse p var 2 * (Var var)^2" using h1a h1b by auto
   have h2a: "MPoly_Type.degree p var = 2 \<longrightarrow> p = (\<Sum>i::nat \<le> 2. isolate_variable_sparse p var i * Var var^i)"
     using sum_over_zero[where mp="p", where x="var"] by auto
   have h2b: "(\<Sum>i::nat \<le> 2. isolate_variable_sparse p var i * Var var^i) =
    (\<Sum>i::nat \<le> 1. isolate_variable_sparse p var i * Var var^i) +
    isolate_variable_sparse p var 2 * (Var var)^2" apply auto
     by (simp add: numerals(2))
   have h2:  "MPoly_Type.degree p var = 2 \<longrightarrow> p =
     isolate_variable_sparse p var 0 + 
     isolate_variable_sparse p var 1 * Var var + 
     isolate_variable_sparse p var 2 * (Var var)^2"
     using h2a h2b by auto
   have h3: "isolate_variable_sparse p var 0 + 
     isolate_variable_sparse p var 1 * Var var + 
     isolate_variable_sparse p var 2 * (Var var)^2 = 
     isolate_variable_sparse p var 2 * (Var var)^2 +
     isolate_variable_sparse p var 1 * Var var + 
     isolate_variable_sparse p var 0" by (simp add: add.commute)
 
   show ?thesis using h h1 h2 h3 by presburger
 qed
 
 lemma degree_isovarspar : "MPoly_Type.degree (isolate_variable_sparse (p::real mpoly) x i) x = 0"
   using not_in_isovarspar varNotIn_degree by blast 
 
 
 end                           
diff --git a/thys/Virtual_Substitution/NegInfinityUni.thy b/thys/Virtual_Substitution/NegInfinityUni.thy
--- a/thys/Virtual_Substitution/NegInfinityUni.thy
+++ b/thys/Virtual_Substitution/NegInfinityUni.thy
@@ -1,632 +1,578 @@
 theory NegInfinityUni
   imports UniAtoms NegInfinity QE
 begin
 
 fun allZero' :: "real * real * real \<Rightarrow> atomUni fmUni" where
   "allZero' (a,b,c) = AndUni(AndUni(AtomUni(EqUni(0,0,a))) (AtomUni(EqUni(0,0,b)))) (AtomUni(EqUni(0,0,c)))"
 
 lemma convert_allZero : 
   assumes "convert_poly var p (xs'@x#xs) = Some p'"
   assumes "length xs' = var"
   shows "eval (allZero p var) (xs'@x#xs) = evalUni (allZero' p') x"
 proof(cases p')
   case (fields a b c)
   then show ?thesis proof(cases "MPoly_Type.degree p var = 0")
     case True
     then show ?thesis
       using assms fields
       by(simp add:eval_list_conj isovar_greater_degree)
   next
     case False
     then have nonzero : "MPoly_Type.degree p var \<noteq> 0" by auto
     then show ?thesis
     proof(cases "MPoly_Type.degree p var = 1")
       case True
       then show ?thesis
         using assms fields
         apply(simp add:eval_list_conj isovar_greater_degree)
         by (metis)
     next
       case False
       then have degree2 : "MPoly_Type.degree p var = 2" using degree_convert_eq[OF assms(1)] nonzero by auto
       then show ?thesis
         using assms
         apply(simp add:eval_list_conj isovar_greater_degree)
         using insertion_isovarspars_free list_update_code(2)
         apply auto
         by (metis One_nat_def Suc_1 less_2_cases less_Suc_eq numeral_3_eq_3)
     qed
   qed
 qed
 
 
 
 fun alternateNegInfinity' :: "real * real * real \<Rightarrow> atomUni fmUni" where
   "alternateNegInfinity' (a,b,c) = 
 OrUni(AtomUni(LessUni(0,0,a)))(
 AndUni(AtomUni(EqUni(0,0,a))) (
   OrUni(AtomUni(LessUni(0,0,-b)))(
   AndUni(AtomUni(EqUni(0,0,b)))(
     AtomUni(LessUni(0,0,c))
   ))
 ))
 "
 
 lemma convert_alternateNegInfinity : 
   assumes "convert_poly var p (xs'@x#xs) = Some X"
   assumes "length xs' = var"
   shows "eval (alternateNegInfinity p var) (xs'@x#xs) = evalUni (alternateNegInfinity' X) x"
 proof(cases X)
   case (fields a b c)
   then show ?thesis proof(cases "MPoly_Type.degree p var = 0")
     case True
     then show ?thesis
       using assms
       apply (simp add: isovar_greater_degree)
       apply auto
       apply (metis aEval.simps(2) eval.simps(1) eval_and eval_false eval_or  mult_one_left)
       by (metis aEval.simps(2) eval.simps(1) eval_or  mult_one_left)
   next
     case False
     then have nonzero : "MPoly_Type.degree p var \<noteq> 0" by auto
     then show ?thesis
     proof(cases "MPoly_Type.degree p var = 1")
       case True
       have letbind: "eval
      (let a_n = isolate_variable_sparse p var (Suc 0)
       in or (fm.Atom (Less (Const (- 1) * a_n)))
           (and (fm.Atom (Eq a_n))
             (let a_n = isolate_variable_sparse p var 0
              in or (fm.Atom (Less (Const 1 * a_n))) (and (fm.Atom (Eq a_n)) FalseF))))
      (xs'@x#xs) = 
     eval
      (or (fm.Atom (Less (Const (- 1) * (isolate_variable_sparse p var (Suc 0)))))
           (and (fm.Atom (Eq (isolate_variable_sparse p var (Suc 0))))
             (or (fm.Atom (Less (Const 1 * (isolate_variable_sparse p var 0)))) (and (fm.Atom (Eq (isolate_variable_sparse p var 0))) FalseF))))
      (xs'@x#xs)"
         by meson 
       show ?thesis
         using assms True unfolding fields
         by (simp add: isovar_greater_degree letbind eval_or eval_and insertion_mult insertion_const)
     next
       case False
       then have degree2 : "MPoly_Type.degree p var = 2" using degree_convert_eq[OF assms(1)] nonzero by auto
       have "[0..<3] = [0,1,2]"
         by (simp add: upt_rec)
       then have unfold : " (foldl
        (\<lambda>F i. let a_n = isolate_variable_sparse p var i
                in or (fm.Atom (Less ((if i mod 2 = 0 then Const 1 else Const (- 1)) * a_n)))
                    (and (fm.Atom (Eq a_n)) F))
        FalseF [0..<3]) =  
      (let a_n = isolate_variable_sparse p var 2
                in or (fm.Atom (Less ((Const 1) * a_n)))
                    (and (fm.Atom (Eq a_n))
        (let a_n = isolate_variable_sparse p var (Suc 0)
       in or (fm.Atom (Less (Const (- 1) * a_n)))
           (and (fm.Atom (Eq a_n))
             (let a_n = isolate_variable_sparse p var 0
              in or (fm.Atom (Less (Const 1 * a_n))) (and (fm.Atom (Eq a_n)) FalseF))))))" 
         by auto
       have letbind : "eval
      (foldl
        (\<lambda>F i. let a_n = isolate_variable_sparse p var i
                in or (fm.Atom (Less ((if i mod 2 = 0 then Const 1 else Const (- 1)) * a_n)))
                    (and (fm.Atom (Eq a_n)) F))
        FalseF [0..<3]) (xs'@x#xs) = 
       eval
      
 (or (fm.Atom (Less ( Const 1 * (isolate_variable_sparse p var 2))))
                    (and (fm.Atom (Eq (isolate_variable_sparse p var 2)))
 (or (fm.Atom (Less (Const (- 1) * (isolate_variable_sparse p var (Suc 0)))))
           (and (fm.Atom (Eq (isolate_variable_sparse p var (Suc 0))))
             (or (fm.Atom (Less (Const 1 * (isolate_variable_sparse p var 0)))) (and (fm.Atom (Eq (isolate_variable_sparse p var 0))) FalseF))))))
 (xs'@x#xs)" apply (simp add:unfold) by metis
       show ?thesis
         using degree2 assms unfolding fields by (simp add: isovar_greater_degree eval_or eval_and letbind insertion_mult insertion_const)
     qed
   qed
 qed
 
 
 
 fun substNegInfinityUni :: "atomUni \<Rightarrow> atomUni fmUni" where
   "substNegInfinityUni (EqUni p) = allZero' p " |
   "substNegInfinityUni (LessUni p) = alternateNegInfinity' p"|
   "substNegInfinityUni (LeqUni p) = OrUni (alternateNegInfinity' p) (allZero' p)"|
   "substNegInfinityUni (NeqUni p) = negUni (allZero' p)"
 
 
 lemma convert_substNegInfinity : 
   assumes "convert_atom var A (xs'@x#xs) = Some(A')"
   assumes "length xs' = var"
   shows "eval (substNegInfinity var A) (xs'@x#xs) = evalUni (substNegInfinityUni A') x"
   using assms
 proof(cases A)
   case (Less p)
   have "\<exists>X. convert_poly var p (xs' @ x # xs) = Some X" using assms Less apply(cases "MPoly_Type.degree p var < 3") by (simp_all)
   then obtain X where X_def: "convert_poly var p (xs' @ x # xs) = Some X" by auto
   then have A' : "A' = LessUni X" using assms Less apply(cases "MPoly_Type.degree p var < 3") by (simp_all)
   show ?thesis unfolding Less substNegInfinity.simps
     unfolding convert_alternateNegInfinity[OF X_def assms(2)] A'
     apply(cases X) by simp
 next
   case (Eq p)
   then show ?thesis using assms convert_allZero by auto
 next
   case (Leq p)
   define p' where "p' = (case convert_poly var p (xs'@x#xs) of Some p' \<Rightarrow> p')"
   have A'_simp :  "A' = LeqUni p'"
     using assms Leq
     using p'_def by auto 
   have allZ : "eval (allZero p var) (xs'@x#xs) = evalUni (allZero' p') x" using convert_allZero
     using Leq assms p'_def by auto 
   have altNeg : "eval (alternateNegInfinity p var) (xs'@x#xs) = evalUni (alternateNegInfinity' p') x" using convert_alternateNegInfinity
     using Leq assms p'_def by auto
   show ?thesis
     unfolding Leq substNegInfinity.simps eval_Or A'_simp substNegInfinityUni.simps evalUni.simps
     using allZ altNeg by auto
 next
   case (Neq p)
   then show ?thesis using assms convert_allZero convert_neg by auto
 qed
 
 lemma change_eval_eq:
   fixes x y:: "real"
   assumes "((aEvalUni (EqUni(a,b,c)) x \<noteq> aEvalUni (EqUni(a,b,c)) y) \<and> x < y)"
   shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
   using assms by auto
 lemma change_eval_lt:
   fixes x y:: "real"
   assumes "((aEvalUni (LessUni (a,b,c)) x \<noteq> aEvalUni (LessUni (a,b,c)) y) \<and> x < y)"
   shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
 proof - 
   let ?p = "[:c, b, a:]"
   have "sign ?p x \<noteq> sign ?p y"
     using assms unfolding sign_def 
     apply (simp add: distrib_left mult.commute mult.left_commute power2_eq_square)
     by linarith
   then have "(\<exists>w \<in> (root_list ?p). x \<le> w \<and> w \<le> y)" using changes_sign 
       assms by auto
   then obtain w where w_prop: "w \<in> (root_list ?p) \<and> x \<le> w \<and> w \<le> y" by auto
   then have "a*w^2 + b*w + c = 0" unfolding root_list_def 
     using add.commute distrib_right mult.assoc mult.commute power2_eq_square
     using quadratic_poly_eval by force
   then show ?thesis using w_prop by auto
 qed
 
 lemma no_change_eval_lt:
   fixes x y:: "real"
   assumes "x < y"
   assumes "\<not>(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
   shows "((aEvalUni (LessUni (a,b,c)) x = aEvalUni (LessUni (a,b,c)) y))"
   using change_eval_lt
   using assms(1) assms(2) by blast 
 
 
 lemma change_eval_neq:
   fixes x y:: "real"
   assumes "((aEvalUni (NeqUni (a,b,c)) x \<noteq> aEvalUni (NeqUni (a,b,c)) y) \<and> x < y)"
   shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
   using assms by auto 
 
 lemma change_eval_leq:
   fixes x y:: "real"
   assumes "((aEvalUni (LeqUni (a,b,c)) x \<noteq> aEvalUni (LeqUni (a,b,c)) y) \<and> x < y)"
   shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
 proof - 
   let ?p = "[:c, b, a:]"
   have "sign ?p x \<noteq> sign ?p y"
     using assms unfolding sign_def
     apply (simp add: distrib_left mult.commute mult.left_commute power2_eq_square)
     by linarith
   then have "(\<exists>w \<in> (root_list ?p). x \<le> w \<and> w \<le> y)" using changes_sign 
       assms by auto
   then obtain w where w_prop: "w \<in> (root_list ?p) \<and> x \<le> w \<and> w \<le> y" by auto
   then have "a*w^2 + b*w + c = 0" unfolding root_list_def
     using add.commute distrib_right mult.assoc mult.commute power2_eq_square
     using quadratic_poly_eval by force  
   then show ?thesis using w_prop by auto
 qed
 
 lemma change_eval:
   fixes x y:: "real"
   fixes At:: "atomUni" 
   assumes xlt: "x < y"
   assumes noteq: "((aEvalUni At) x \<noteq> aEvalUni (At) y)"
   assumes "getPoly At = (a, b, c)"
   shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
 proof - 
   have four_types: "At = (EqUni (a,b,c)) \<or> At = (LessUni (a,b,c)) \<or> At = (LeqUni (a,b,c)) \<or> At = (NeqUni (a,b,c))"
     using getPoly.elims assms(3) by force 
   have eq_h: "At = (EqUni (a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
     using assms(1) assms(2) change_eval_eq 
     by blast
   have less_h: "At = (LessUni(a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
     using change_eval_lt assms
     by blast
   have leq_h: "At = (LeqUni(a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
     using change_eval_leq assms
     by blast
   have neq_h: "At = (NeqUni(a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
     using change_eval_neq assms
     by blast
   show ?thesis
     using four_types eq_h less_h leq_h neq_h
     by blast 
 qed 
 
 lemma no_change_eval:
   fixes x y:: "real"
   assumes "getPoly At = (a, b, c)"
   assumes "x < y"
   assumes "\<not>(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
   shows  "((aEvalUni At) x = aEvalUni (At) y \<and> x < y)"
   using change_eval
   using assms(1) assms(2) assms(3) by blast 
 
 
 lemma same_eval'' :
   assumes "getPoly At = (a, b, c)"
   assumes nonz: "a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0"
   shows "\<exists>x. \<forall>y<x. (aEvalUni At y = aEvalUni At x)"
 proof - 
   let ?p = "[:c, b, a:]"
   have poly_eval: "\<forall>y. poly ?p y = a*y^2 + b*y + c" 
     by (simp add: distrib_left power2_eq_square) 
   have "?p \<noteq> 0" using nonz by auto
   then have "finite {y. poly ?p y = 0}"
     using poly_roots_finite
     by blast
   then have "finite {y. c + (a * y\<^sup>2 + b * y) = 0} \<Longrightarrow>
     \<forall>y. y * (b + y * a) = a * y\<^sup>2 + b * y \<Longrightarrow>
     finite {y. a * y\<^sup>2 + b * y + c = 0}"
   proof -
     assume a1: "finite {y. c + (a * y\<^sup>2 + b * y) = 0}"
     have "\<forall>x0. c + (a * x0\<^sup>2 + b * x0) = a * x0\<^sup>2 + b * x0 + c"
       by simp
     then show ?thesis
       using a1 by presburger
   qed 
   then have finset: "finite {y. a*y^2 + b*y + c = 0}" 
     using poly_eval
     by (metis \<open>finite {y. poly [:c, b, a:] y = 0}\<close> poly_roots_set_same) 
   then have "\<exists>x. (\<forall>y. a*y^2 + b*y + c = 0 \<longrightarrow> x < y)" 
   proof - 
     let ?l = "sorted_list_of_set {y. a*y^2 + b*y + c = 0}"
     have "\<exists>x. x < ?l ! 0" 
       using infzeros nonz by blast 
     then obtain x where x_prop: "x < ?l! 0" by auto
     then have "\<forall> y. List.member ?l y \<longrightarrow> x < y"
     proof clarsimp
       fix y
       assume "List.member ?l y"
       then have "\<exists>n. n < length ?l \<and> ?l ! n = y"
         by (meson in_set_conv_nth in_set_member)
       then obtain n where n_prop: "n < length ?l \<and> ?l ! n = y"
         by auto
       have h: "\<forall>n < length ?l. ?l ! n \<ge> ?l !0" using sorted_iff_nth_mono
         using sorted_sorted_list_of_set by blast
       then have h: "y \<ge> ?l ! 0" using n_prop by auto
       then show "x < y" using x_prop by auto
     qed
     then show ?thesis
       using finset set_sorted_list_of_set in_set_member
       by (metis (mono_tags, lifting) mem_Collect_eq)
   qed
   then obtain x where x_prop: "(\<forall>y. a*y^2 + b*y + c = 0 \<longrightarrow> x < y)" by auto
   then have same_as: "\<forall>y<x. (aEvalUni At y = aEvalUni At x)"
-    using no_change_eval change_eval assms
-  proof -
-    have f1: "\<forall>x0. (x0 < x) = (\<not> 0 \<le> x0 + - 1 * x)"
-      by auto
-    have f2: "(0 \<le> - 1 * x + v0_0) = (x + - 1 * v0_0 \<le> 0)"
-      by auto
-    have f3: "v0_0 + - 1 * x = - 1 * x + v0_0"
-      by auto
-    have f4: "\<forall>x0 x1 x2 x3. (x3::real) * x0\<^sup>2 + x2 * x0 + x1 = x1 + x3 * x0\<^sup>2 + x2 * x0"
-      by auto
-    have f5: "\<forall>x3 x4 x5. (aEvalUni x3 x5 \<noteq> aEvalUni x3 x4) = ((\<not> aEvalUni x3 x5) = aEvalUni x3 x4)"
-      by fastforce
-    have f6: "\<forall>x0 x1 x2 x3 x4 x5. (x5 < x4 \<and> (\<not> aEvalUni x3 x5) = aEvalUni x3 x4 \<and> getPoly x3 = (x2, x1, x0) \<longrightarrow> (\<exists>v6\<ge>x5. v6 \<le> x4 \<and> x0 + x2 * v6\<^sup>2 + x1 * v6 = 0)) = ((\<not> x5 < x4 \<or> (\<not> aEvalUni x3 x5) \<noteq> aEvalUni x3 x4 \<or> getPoly x3 \<noteq> (x2, x1, x0)) \<or> (\<exists>v6\<ge>x5. v6 \<le> x4 \<and> x0 + x2 * v6\<^sup>2 + x1 * v6 = 0))"
-      by fastforce
-    have f7: "\<forall>x0 x5. ((x0::real) \<le> x5) = (x0 + - 1 * x5 \<le> 0)"
-      by auto
-    have f8: "\<forall>x0 x6. ((x6::real) \<le> x0) = (0 \<le> x0 + - 1 * x6)"
-      by auto
-    have "\<forall>x4 x5. ((x5::real) < x4) = (\<not> x4 + - 1 * x5 \<le> 0)"
-      by auto
-    then have "(\<forall>r ra a rb rc rd. r < ra \<and> aEvalUni a r \<noteq> aEvalUni a ra \<and> getPoly a = (rb, rc, rd) \<longrightarrow> (\<exists>re\<ge>r. re \<le> ra \<and> rb * re\<^sup>2 + rc * re + rd = 0)) = (\<forall>r ra a rb rc rd. (ra + - 1 * r \<le> 0 \<or> (\<not> aEvalUni a r) \<noteq> aEvalUni a ra \<or> getPoly a \<noteq> (rb, rc, rd)) \<or> (\<exists>re. 0 \<le> re + - 1 * r \<and> re + - 1 * ra \<le> 0 \<and> rd + rb * re\<^sup>2 + rc * re = 0))"
-      using f8 f7 f6 f5 f4 by presburger
-    then have f9: "\<forall>r ra a rb rc rd. (ra + - 1 * r \<le> 0 \<or> (\<not> aEvalUni a r) \<noteq> aEvalUni a ra \<or> getPoly a \<noteq> (rb, rc, rd)) \<or> (\<exists>re. 0 \<le> re + - 1 * r \<and> re + - 1 * ra \<le> 0 \<and> rd + rb * re\<^sup>2 + rc * re = 0)"
-      by (meson change_eval)
-    obtain rr :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
-      "\<forall>x0 x1 x2 x4 x5. (\<exists>v6. 0 \<le> v6 + - 1 * x5 \<and> v6 + - 1 * x4 \<le> 0 \<and> x0 + x2 * v6\<^sup>2 + x1 * v6 = 0) = (0 \<le> rr x0 x1 x2 x4 x5 + - 1 * x5 \<and> rr x0 x1 x2 x4 x5 + - 1 * x4 \<le> 0 \<and> x0 + x2 * (rr x0 x1 x2 x4 x5)\<^sup>2 + x1 * rr x0 x1 x2 x4 x5 = 0)"
-      by moura
-    then have f10: "\<forall>r ra a rb rc rd. ra + - 1 * r \<le> 0 \<or> aEvalUni a r = aEvalUni a ra \<or> getPoly a \<noteq> (rb, rc, rd) \<or> r + - 1 * rr rd rc rb ra r \<le> 0 \<and> 0 \<le> ra + - 1 * rr rd rc rb ra r \<and> rd + rb * (rr rd rc rb ra r)\<^sup>2 + rc * rr rd rc rb ra r = 0"
-      using f9 by simp
-    have f11: "(rr c b a x v0_0 + - 1 * x \<le> 0) = (0 \<le> x + - 1 * rr c b a x v0_0)"
-      by force
-    have "\<forall>x0. (x < x0) = (\<not> x0 + - 1 * x \<le> 0)"
-      by auto
-    then have f12: "\<forall>r. c + a * r\<^sup>2 + b * r \<noteq> 0 \<or> \<not> r + - 1 * x \<le> 0"
-      using x_prop by auto
-    obtain rra :: real where
-      "(\<exists>v0. \<not> 0 \<le> v0 + - 1 * x \<and> aEvalUni At v0 \<noteq> aEvalUni At x) = (\<not> 0 \<le> rra + - 1 * x \<and> aEvalUni At rra \<noteq> aEvalUni At x)"
-      by moura
-    then show ?thesis
-      using f12 f11 f10 f3 f2 f1
-    proof -
-      have f1: "\<forall>x0. (x0 < x) = (\<not> 0 \<le> x0 + - 1 * x)"
-        by auto
-      have f2: "(0 \<le> v0_0a + - 1 * x) = (x + - 1 * v0_0a \<le> 0)"
-        by auto
-      have f3: "(rr c b a x v0_0a + - 1 * x \<le> 0) = (0 \<le> x + - 1 * rr c b a x v0_0a)"
-        by auto
-      obtain rrb :: real where
-        "(\<exists>v0. \<not> 0 \<le> v0 + - 1 * x \<and> aEvalUni At v0 \<noteq> aEvalUni At x) = (\<not> 0 \<le> rrb + - 1 * x \<and> aEvalUni At rrb \<noteq> aEvalUni At x)"
-        by blast
-      then show ?thesis
-        using f3 f2 f1 assms(1) f10 f12
-        by smt
-    qed
-  qed
+    using no_change_eval change_eval assms by (smt (verit, ccfv_SIG))
   then show ?thesis by auto
 qed
 
 
 lemma inequality_case : "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) < 0) =
     (a < 0 \<or> a = 0 \<and> (0 < b \<or> b = 0 \<and> c < 0))"
 proof-
   let ?At = "(LessUni (a, b, c))"
   have firsth : "\<And>x. (\<forall>y<x. a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow> a\<le>0)"
   proof -
     fix x
     assume lt: "\<forall>y<x. a * y\<^sup>2 + b * y + c < 0"
     have "\<exists>w. \<forall>y < w. y^2 > (-b/a)*y - c/a"  using ysq_dom_y_plus_coeff[where b = "-b/a", where c = "-c/a"]
       by auto   
     then have gtdomhelp: "a > 0 \<Longrightarrow> \<exists>w. \<forall>y < w. a*y^2 > a*((-b/a)*y - c/a)"
       by auto
     have "\<forall>y. (a > 0 \<longrightarrow> a*((-b/a)*y - c/a) = -b*y - c)"
       by (simp add: right_diff_distrib') 
     then have gtdom: "a > 0 \<Longrightarrow> \<exists>w.\<forall>y < w. a*y^2 > -b*y - c"
       using gtdomhelp
       by simp 
     then have " a > 0 \<Longrightarrow> False"
     proof - 
       assume "a > 0"
       then have "\<exists>w.\<forall>y < w. a*y^2 > -b*y - c" using gtdom by auto
       then obtain w where w_prop: "\<forall>y < w. a*y^2 + b*y + c > 0"
         by fastforce 
       let ?mn = "min w x - 1"
       have gtz: "a*?mn^2 + b*?mn + c > 0" using w_prop
         by auto
       have ltz: "a*?mn^2 + b*?mn + c < 0" using lt by auto
       then show "False" using gtz ltz by auto
     qed
     then show "a \<le> 0"
       by fastforce 
   qed
   have bleq0 : "\<And>x. (\<forall>y<x. b * y + c < 0 \<Longrightarrow> b\<ge>0)"
   proof -
     fix x
     assume lt: "\<forall>y<x. b * y + c < 0"
     have gtdom: "b < 0 \<Longrightarrow> \<exists>w.\<forall>y < w. b*y > - c"
       by (metis mult.commute neg_less_divide_eq)
     then have "b < 0 \<Longrightarrow> False"
     proof - 
       assume "b < 0"
       then have "\<exists>w.\<forall>y < w. b*y > - c" using gtdom by auto
       then obtain w where w_prop: "\<forall>y < w .b*y + c > 0"
         by fastforce 
       let ?mn = "min w x - 1"
       have gtz: "b*?mn + c > 0" using w_prop
         by auto
       have ltz: "b*?mn + c < 0" using lt by auto
       then show "False" using gtz ltz by auto
     qed
     then show "b \<ge> 0"
       by fastforce 
   qed
   have secondh: "\<And>x. (\<forall>y<x. a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow> \<not> a < 0 \<Longrightarrow> \<not> 0 < b \<Longrightarrow> b = 0)"
     using firsth bleq0
     by (metis add.commute add.right_neutral less_eq_real_def mult_zero_class.mult_zero_left) 
   have thirdh : "\<And>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow> \<not> a < 0 \<Longrightarrow> \<not> 0 < b \<Longrightarrow> c < 0"
     using firsth secondh add.commute add.right_neutral infzeros mult_zero_class.mult_zero_left not_numeral_le_zero order_refl
     by (metis less_eq_real_def)
   have fourthh : "a < 0 \<Longrightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0"
   proof - 
     assume aleq: "a < 0"
     have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> y^2 > (-b/a)*y + (-c/a))"
       using ysq_dom_y_plus_coeff[where b = "-b/a", where c = "-c/a"]
       by blast 
     then have hyp:"\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> a*y^2 \<le> a*(-b/a)*y + a*(-c/a))"
       by (metis (no_types, opaque_lifting) \<open>a < 0\<close> distrib_left less_eq_real_def linorder_not_le mult.assoc mult_less_cancel_left)
     have "\<forall>y. a*(-b/a)*y + a*(-c/a) = -b*y -c"
       using \<open>a < 0\<close> by auto
     then have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> a*y^2 \<le> -b*y - c)"
       using hyp by auto
     then have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> a*y^2 + b*y + c \<le> 0)"
       by (metis add.commute add_uminus_conv_diff le_diff_eq mult_minus_left real_add_le_0_iff)
     then obtain w where w_prop: "\<forall>(y::real). (y < w \<longrightarrow> a*y^2 + b*y + c \<le> 0)" by auto
     have "\<exists>x. \<forall>y < x. aEvalUni ?At x = aEvalUni ?At y" using same_eval''
     proof -
       have f1: "\<forall>x0 x1. ((x0::real) < x1) = (\<not> 0 \<le> x0 + - 1 * x1)"
         by linarith
       have "a \<noteq> 0"
         using \<open>a < 0\<close> by force
       then obtain rr :: "atomUni \<Rightarrow> real" where
         "\<forall>r. 0 \<le> r + - 1 * rr (LessUni (a, b, c)) \<or> aEvalUni (LessUni (a, b, c)) r = aEvalUni (LessUni (a, b, c)) (rr (LessUni (a, b, c)))"
         using f1 by (metis getPoly.simps(4) same_eval'')
       then show ?thesis
         using f1 by meson
     qed
     then obtain x where x_prop: "\<forall>y < x. aEvalUni ?At x = aEvalUni ?At y" by auto
     let ?mn = "min x w - 1"
     have "\<forall>y < ?mn.  aEvalUni ?At y = True \<or> aEvalUni ?At y = False"
       using x_prop by auto
     have "\<forall> y < ?mn. aEvalUni ?At y = False \<longrightarrow> a*y^2 + b*y + c \<ge> 0"
       by auto
     then have "\<And>y. \<forall>y<w. a * y\<^sup>2 + b * y + c \<le> 0 \<Longrightarrow>
          y < min x w - 1 \<Longrightarrow>
          \<not> a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow>
          a * y\<^sup>2 + b * y + c = 0"
     proof -
       fix y :: real
       assume a1: "y < min x w - 1"
       assume a2: "\<not> a * y\<^sup>2 + b * y + c < 0"
       assume a3: "\<forall>y<w. a * y\<^sup>2 + b * y + c \<le> 0"
       have "y < w"
         using a1 by linarith
       then show "a * y\<^sup>2 + b * y + c = 0"
         using a3 a2 less_eq_real_def by blast
     qed 
     then have "\<forall> y < ?mn. aEvalUni ?At y = False \<longrightarrow> a*y^2 + b*y + c = 0"
       using w_prop by auto    
     then have "\<forall> y < ?mn. aEvalUni ?At y = False \<Longrightarrow> False" using infzeros aleq
       by (metis power_zero_numeral zero_less_power2)
     then have "\<forall> y < ?mn. aEvalUni ?At y = True"
     proof -
       { fix rr :: real
         have "\<forall>r ra. (ra::real) < r \<or> \<not> ra < r + - 1"
           by linarith
         then have "\<not> rr < min x w - 1 \<or> aEvalUni (LessUni (a, b, c)) rr"
           by (metis (no_types) \<open>\<forall>y<min x w - 1. aEvalUni (LessUni (a, b, c)) y = False \<Longrightarrow> False\<close> ab_group_add_class.ab_diff_conv_add_uminus less_eq_real_def min_less_iff_disj not_le x_prop) }
       then show ?thesis
         by blast
     qed 
     then show ?thesis by auto
   qed
   have fifthh : "b > 0 \<Longrightarrow> \<exists>x. \<forall>y<x. b * y + c < 0"
   proof-
     assume bh : "b > 0"
     show "\<exists>x. \<forall>y<x. b * y + c < 0"
       apply(rule exI[where x="-c/b"])
       apply auto
       using bh
       by (simp add: mult.commute pos_less_minus_divide_eq) 
   qed
   show ?thesis
     apply(auto)
     using firsth apply simp
     using secondh apply simp 
     using thirdh apply simp
     using fourthh apply simp
     using fifthh by simp
 qed
 
 lemma inequality_case_geq : "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) > 0) =
     (a > 0 \<or> a = 0 \<and> (0 > b \<or> b = 0 \<and> c > 0))"
 proof - 
   have s1: "\<forall>y. - 1 * a * y\<^sup>2 + - 1 * b * y + - 1 * c < 0 \<longleftrightarrow>  a * y\<^sup>2 +  b * y +  c > 0"
     by auto
   have s2: "(- 1 * a < 0 \<or> - 1 * a = 0 \<and> (0 < - 1 * b \<or> - 1 * b = 0 \<and> - 1 * c < 0)) \<longleftrightarrow>
    (a > 0 \<or> a = 0 \<and> (0 > b \<or>  b = 0 \<and> c > 0))  "
     by auto
   have "(\<exists>x. \<forall>y<x. - 1 * a * y\<^sup>2 + - 1 * b * y + - 1 * c < 0) =
   (- 1 * a < 0 \<or> - 1 * a = 0 \<and> (0 < - 1 * b \<or> - 1 * b = 0 \<and> - 1 * c < 0))"
     using inequality_case[where a = "-1*a", where b = "-1*b", where c= "-1*c"]
     by auto
   then show ?thesis
     using s1 s2 by auto
 qed
 
 lemma infinity_evalUni_LessUni : "(\<exists>x. \<forall>y<x. aEvalUni (LessUni p) y) = (evalUni (substNegInfinityUni (LessUni p)) x)"
 proof(cases p)
   case (fields a b c)
   show ?thesis 
     unfolding fields  apply simp
     using inequality_case[of a b c] .
 qed
 
 lemma infinity_evalUni_EqUni : "(\<exists>x. \<forall>y<x. aEvalUni (EqUni p) y) = (evalUni (substNegInfinityUni (EqUni p)) x)"
 proof(cases p)
   case (fields a b c)
   show ?thesis
     using infzeros[of _ a b c] by(auto simp add: fields)
 qed
 
 lemma infinity_evalUni_NeqUni : "(\<exists>x. \<forall>y<x. aEvalUni (NeqUni p) y) = (evalUni (substNegInfinityUni (NeqUni p)) x)"
 proof(cases p)
   case (fields a b c)
   show ?thesis
     unfolding fields  apply simp 
     using inequality_case[of a b c] 
     using inequality_case_geq[of a b c]
     by (metis less_numeral_extra(3) linorder_neqE_linordered_idom mult_eq_0_iff)
 
 qed
 
 lemma infinity_evalUni_LeqUni : "(\<exists>x. \<forall>y<x. aEvalUni (LeqUni p) y) = (evalUni (substNegInfinityUni (LeqUni p)) x)"
 proof(cases p)
   case (fields a b c)
   show ?thesis
     unfolding fields  apply simp 
   proof -
     have h1: "((\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)) \<longrightarrow> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0)"
       using less_eq_real_def
       by auto
     have h2: "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<Longrightarrow> ((\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0))"
     proof -
       assume a1: "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0)"
       have "\<not>(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0) \<Longrightarrow> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) " 
       proof - 
         assume a2: "\<not>(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)"
         then have "a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0" by auto
         then have "(a < 0 \<or> a = 0 \<and> (0 < b \<or> b = 0 \<and> c < 0))"
         proof - 
           have x1: "a > 0 \<Longrightarrow> False"
           proof - 
             assume "a > 0"
             then have "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) > 0)" using inequality_case_geq
               by auto
             then  show ?thesis
               using a1 
               by (meson a2 linorder_not_le min_less_iff_conj)  
           qed
           then have x2: "a = 0 \<and> 0 > b \<Longrightarrow> False"
           proof - 
             assume "a = 0 \<and> 0 > b"
             then have "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) > 0)" using inequality_case_geq
               by blast
             then show ?thesis
               using a1
               by (meson a2 linorder_not_le min_less_iff_conj) 
           qed
           then have x3: "a = 0 \<and> b = 0 \<and> c > 0 \<Longrightarrow> False "
             using a1 a2 by auto  
           show ?thesis using x1 x2 x3
             by (meson \<open>a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0\<close> linorder_neqE_linordered_idom) 
         qed
         then show "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)" using inequality_case
           by auto
       qed
       then show ?thesis
         by auto
     qed
     have "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) = (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)"
       using h1 h2 by auto
     then show "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) =
     (a < 0 \<or> a = 0 \<and> (0 < b \<or> b = 0 \<and> c < 0) \<or> a = 0 \<and> b = 0 \<and> c = 0)"
       using inequality_case[of a b c] infzeros[of _ a b c] by auto
   qed
 qed
 
 text "This is the vertical translation for substNegInfinityUni where we represent the virtual
 substution of negative infinity in the univariate case"
 lemma infinity_evalUni :
   shows "(\<exists>x. \<forall>y<x. aEvalUni At y) = (evalUni (substNegInfinityUni At) x)"
 proof(cases At)
   case (LessUni p)
   then show ?thesis using infinity_evalUni_LessUni by auto
 next
   case (EqUni p)
   then show ?thesis using infinity_evalUni_EqUni by auto
 next
   case (LeqUni p)
   then show ?thesis using infinity_evalUni_LeqUni by auto
 next
   case (NeqUni p)
   then show ?thesis using infinity_evalUni_NeqUni by auto
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Virtual_Substitution/QE.thy b/thys/Virtual_Substitution/QE.thy
--- a/thys/Virtual_Substitution/QE.thy
+++ b/thys/Virtual_Substitution/QE.thy
@@ -1,8837 +1,8836 @@
 section "QE lemmas"
 theory QE
   imports Polynomials.MPoly_Type_Univariate
     Polynomials.Polynomials  Polynomials.MPoly_Type_Class_FMap 
     "HOL-Library.Quadratic_Discriminant"
 begin
 
 (* This file may take some time to load *)
 
 subsection "Useful Definitions/Setting Up"
 
 definition sign:: "real Polynomial.poly \<Rightarrow> real \<Rightarrow> int"
   where "sign p x \<equiv> (if poly p x = 0 then 0 else (if poly p x > 0 then 1 else -1))"
 
 definition sign_num:: "real \<Rightarrow> int"
   where "sign_num x \<equiv> (if x = 0 then 0 else (if x > 0 then 1 else -1))"
 
 definition root_list:: "real Polynomial.poly \<Rightarrow> real set"
   where "root_list p \<equiv> ({(x::real). poly p x = 0}::real set)" 
 
 definition root_set:: "(real \<times> real \<times> real) set \<Rightarrow> real set"
   where "root_set les \<equiv> ({(x::real). (\<exists> (a, b, c) \<in> les. a*x^2 + b*x + c = 0)}::real set)" 
 
 definition sorted_root_list_set:: "(real \<times> real \<times> real) set \<Rightarrow> real list"
   where "sorted_root_list_set p \<equiv> sorted_list_of_set (root_set p)" 
 
 definition nonzero_root_set:: "(real \<times> real \<times> real) set \<Rightarrow> real set"
   where "nonzero_root_set les \<equiv> ({(x::real). (\<exists> (a, b, c) \<in> les. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a*x^2 + b*x + c = 0)}::real set)" 
 
 definition sorted_nonzero_root_list_set:: "(real \<times> real \<times> real) set \<Rightarrow> real list"
   where "sorted_nonzero_root_list_set p \<equiv> sorted_list_of_set (nonzero_root_set p)" 
 
 
 (* Important property of sorted lists *)
 lemma sorted_list_prop:
   fixes l::"real list"
   fixes x::"real"
   assumes sorted: "sorted l"
   assumes lengt: "length l > 0"
   assumes xgt: "x > l ! 0"
   assumes xlt: "x \<le> l ! (length l - 1)"
   shows "\<exists>n. (n+1) < (length l) \<and> x \<ge> l !n \<and> x \<le> l ! (n + 1)"
 proof - 
   have "\<not>(\<exists>n. (n+1) < (length l) \<and> x \<ge> l !n \<and> x \<le> l ! (n + 1)) \<Longrightarrow> False"
   proof clarsimp 
     fix n
     assume alln: "\<forall>n. l ! n \<le> x \<longrightarrow> Suc n < length l \<longrightarrow> \<not> x \<le> l ! Suc n"
     have "\<forall>k. (k < length l \<longrightarrow> x > l ! k)" 
     proof clarsimp 
       fix k
       show "k < length l \<Longrightarrow> l ! k < x"
       proof (induct k)
         case 0
         then show ?case using xgt by auto
       next
         case (Suc k)
         then show ?case using alln
           using less_eq_real_def by auto 
       qed
     qed
     then show "False"
       using xlt diff_Suc_less lengt not_less
       by (metis One_nat_def) 
   qed
   then show ?thesis by auto
 qed
 
 
 subsection "Quadratic polynomial properties"
 lemma quadratic_poly_eval: 
   fixes a b c::"real"
   fixes x::"real"
   shows "poly [:c, b, a:] x = a*x^2 + b*x + c"    
 proof - 
   have "x * (b + x * a) = a * x\<^sup>2 + b * x" by (metis add.commute distrib_right mult.assoc mult.commute power2_eq_square)
   then show ?thesis by auto
 qed
 
 lemma poly_roots_set_same:
   fixes a b c:: "real"
   shows "{(x::real). a * x\<^sup>2 + b * x + c = 0} = {x. poly [:c, b, a:] x = 0}"
 proof - 
   have "\<forall>x. a*x^2 + b*x + c = poly [:c, b, a:] x"
   proof clarsimp 
     fix x
     show "a * x\<^sup>2 + b * x = x * (b + x * a)"
       using quadratic_poly_eval[of c b a x] by auto
   qed
   then show ?thesis 
     by auto
 qed
 
 lemma root_set_finite:
   assumes fin: "finite les"
   assumes nex: "\<not>(\<exists> (a, b, c) \<in> les. a = 0 \<and> b = 0 \<and> c = 0 )"
   shows "finite (root_set les)"
 proof - 
   have "\<forall>(a, b, c) \<in> les. finite {(x::real). a*x^2 + b*x + c = 0}" 
   proof clarsimp 
     fix a b c
     assume "(a, b, c) \<in> les"
     then have "[:c, b, a:] \<noteq> 0" using nex by auto
     then have "finite {x. poly [:c, b, a:] x = 0}"
       using poly_roots_finite[where p = "[:c, b, a:]"] by auto
     then show "finite {x. a * x\<^sup>2 + b * x + c = 0}"
       using  poly_roots_set_same by auto
   qed
   then show ?thesis using fin
     unfolding root_set_def by auto
 qed
 
 lemma nonzero_root_set_finite:
   assumes fin: "finite les"
   shows "finite (nonzero_root_set les)"
 proof - 
   have "\<forall>(a, b, c) \<in> les. (a \<noteq> 0 \<or> b \<noteq> 0) \<longrightarrow> finite {(x::real). a*x^2 + b*x + c = 0}" 
   proof clarsimp 
     fix a b c
     assume ins: "(a, b, c) \<in> les"
     assume "a = 0 \<longrightarrow> b \<noteq> 0"
     then have "[:c, b, a:] \<noteq> 0" using ins by auto
     then have "finite {x. poly [:c, b, a:] x = 0}"
       using poly_roots_finite[where p = "[:c, b, a:]"] by auto
     then show "finite {x. a * x\<^sup>2 + b * x + c = 0}"
       using  poly_roots_set_same by auto
   qed
   then show ?thesis using fin
     unfolding nonzero_root_set_def by auto
 qed
 
 lemma discriminant_lemma:
   fixes a b c r::"real"
   assumes aneq: "a \<noteq> 0"
   assumes beq: "b = 2 * a * r"
   assumes root: " a * r^2 - 2 * a * r*r + c = 0"
   shows "\<forall>x. a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> x = -r"
 proof - 
   have "c = a*r^2" using root
     by (simp add: power2_eq_square)
   then have same: "b^2 - 4*a*c = (2 * a * r)^2 - 4*a*(a*r^2)" using beq
     by blast 
   have "(2 * a * r)^2 = 4*a^2*r^2"
     by (simp add: mult.commute power2_eq_square)
   then have "(2 * a * r)^2 - 4*a*(a*(r)^2) = 0"
     using power2_eq_square by auto 
   then have "b^2 - 4*a*c = 0" using same
     by simp 
   then have "\<forall>x. a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> x = -b / (2 * a)"
     using discriminant_zero aneq unfolding discrim_def by auto
   then show ?thesis using beq
     by (simp add: aneq) 
 qed
 
 (* Show a polynomial only changes sign when it passes through a root *)
 lemma changes_sign:
   fixes p:: "real Polynomial.poly"
   shows "\<forall>x::real. \<forall> y::real. ((sign p x \<noteq> sign p y  \<and> x < y) \<longrightarrow> (\<exists>c \<in> (root_list p). x \<le> c \<and> c \<le> y))"
 proof clarsimp
   fix x y
   assume "sign p x \<noteq> sign p y"
   assume "x < y"
   then show "\<exists>c\<in>root_list p. x \<le> c \<and> c \<le> y"
     using poly_IVT_pos[of x y p] poly_IVT_neg[of x y p] 
     by (metis (mono_tags) \<open>sign p x \<noteq> sign p y\<close> less_eq_real_def linorder_neqE_linordered_idom mem_Collect_eq root_list_def sign_def)
 qed
 
 (* Show a polynomial only changes sign if it passes through a root *)
 lemma changes_sign_var:
   fixes a b c x y:: "real"
   shows "((sign_num (a*x^2 + b*x + c) \<noteq> sign_num (a*y^2 + b*y + c)  \<and> x < y) \<Longrightarrow> (\<exists>q. (a*q^2 + b*q + c = 0 \<and> x \<le> q \<and> q \<le> y)))"
 proof  clarsimp
   assume sn: "sign_num (a * x\<^sup>2 + b * x + c) \<noteq> sign_num (a * y\<^sup>2 + b * y + c)"
   assume xy: " x < y"
   let ?p = "[:c, b, a:]"
   have cs: "((sign ?p x \<noteq> sign ?p y  \<and> x < y) \<longrightarrow> (\<exists>c \<in> (root_list ?p). x \<le> c \<and> c \<le> y))"
     using changes_sign[of ?p] by auto
   have "(sign ?p x \<noteq> sign ?p y  \<and> x < y)"
     using sn xy unfolding sign_def sign_num_def using quadratic_poly_eval
     by presburger 
   then have "(\<exists>c \<in> (root_list ?p). x \<le> c \<and> c \<le> y)" 
     using cs 
     by auto 
   then obtain q where "q \<in> root_list ?p \<and> x \<le> q \<and> q \<le> y" 
     by auto
   then have "a*q^2 + b*q + c = 0 \<and> x \<le> q \<and> q \<le> y"
     unfolding root_list_def using quadratic_poly_eval[of c b a q]
     by auto
   then show "\<exists>q. a * q\<^sup>2 + b * q + c = 0 \<and> x \<le> q \<and> q \<le> y"  
     by auto
 qed
 
 subsection "Continuity Properties"
 lemma continuity_lem_eq0:
   fixes p::"real"
   shows "r < p \<Longrightarrow> \<forall>x\<in>{r <..p}. a * x\<^sup>2 + b * x + c = 0 \<Longrightarrow> (a = 0 \<and> b = 0 \<and> c = 0)" 
 proof - 
   assume r_lt: "r < p"
   assume inf_zer: "\<forall>x\<in>{r <..p}. a * x\<^sup>2 + b * x + c = 0"
   have nf: "\<not>finite {r..<p}" using Set_Interval.dense_linorder_class.infinite_Ioo r_lt by auto
   have "\<not>(a = 0 \<and> b = 0 \<and> c = 0) \<Longrightarrow> False"
   proof - 
     assume "\<not>(a = 0 \<and> b = 0 \<and> c = 0)"
     then have "[:c, b, a:] \<noteq> 0" by auto
     then have fin: "finite {x. poly [:c, b, a:] x = 0}" using poly_roots_finite[where p = "[:c, b, a:]"] by auto
     have "{x. a*x^2 + b*x + c = 0} = {x. poly [:c, b, a:] x = 0}" using quadratic_poly_eval by auto
     then have finset: "finite {x. a*x^2 + b*x + c = 0}"  using fin by auto
     have "{r <..p} \<subseteq> {x. a*x^2 + b*x + c = 0}" using inf_zer by blast
     then show "False" using finset nf
       using finite_subset
       by (metis (no_types, lifting) infinite_Ioc_iff r_lt) 
   qed
   then show "(a = 0 \<and> b = 0 \<and> c = 0)" by auto
 qed
 
 lemma continuity_lem_lt0: 
   fixes r:: "real"
   fixes a b c:: "real"
   shows "poly [:c, b, a:] r < 0 \<Longrightarrow>
     \<exists>y'> r. \<forall>x\<in>{r<..y'}. poly [:c, b, a:] x < 0"
 proof - 
   let ?f = "poly [:c,b,a:]"
   assume r_ltz: "poly [:c, b, a:] r < 0"
   then have "[:c, b, a:] \<noteq> 0" by auto
   then have "finite {x. poly [:c, b, a:] x = 0}" using poly_roots_finite[where p = "[:c, b, a:]"]    
     by auto
   then have fin: "finite  {x. x > r \<and> poly [:c, b, a:] x = 0}"
     using finite_Collect_conjI by blast 
   let ?l = "sorted_list_of_set {x. x > r \<and> poly [:c, b, a:] x = 0}"
   show ?thesis proof (cases "length ?l = 0")
     case True
     then have no_zer: "\<not>(\<exists>x>r. poly [:c, b, a:] x = 0)" using sorted_list_of_set_eq_Nil_iff fin by auto
     then have "\<And>y. y > r \<and> y < (r + 1) \<Longrightarrow> poly [:c, b, a:] y < 0 " 
     proof - 
       fix y
       assume "y > r \<and> y < r + 1"
       then show "poly [:c, b, a:] y < 0"
         using r_ltz no_zer poly_IVT_pos[where a = "r", where p = "[:c, b, a:]", where b = "y"]
         by (meson linorder_neqE_linordered_idom)
     qed
     then show ?thesis
       by (metis greaterThanAtMost_iff less_add_one less_eq_real_def linorder_not_le no_zer poly_IVT_pos r_ltz)
   next
     case False
     then have len_nonz: "length (sorted_list_of_set {x. r < x \<and> poly [:c, b, a:] x = 0}) \<noteq> 0"
       by blast 
     then have "\<forall>n \<in> {x. x > r \<and> poly [:c, b, a:] x = 0}. (nth_default 0 ?l 0) \<le> n"
       using fin set_sorted_list_of_set sorted_sorted_list_of_set
       using  in_set_conv_nth leI not_less0 sorted_nth_mono
       by (smt not_less_iff_gr_or_eq nth_default_def)
     then have no_zer: "\<not>(\<exists>x>r. (x < (nth_default 0 ?l 0) \<and> poly [:c, b, a:] x = 0))"
       using sorted_sorted_list_of_set by auto
     then have fa: "\<And>y. y > r \<and> y < (nth_default 0 ?l 0) \<Longrightarrow> poly [:c, b, a:] y < 0 " 
     proof - 
       fix y
       assume "y > r \<and> y < (nth_default 0 ?l 0)"
       then show "poly [:c, b, a:] y < 0"
         using r_ltz no_zer poly_IVT_pos[where a = "r", where p = "[:c, b, a:]", where b = "y"]
         by (meson less_imp_le less_le_trans linorder_neqE_linordered_idom)
     qed
     have "nth_default 0 ?l 0 > r" using fin set_sorted_list_of_set
       using len_nonz length_0_conv length_greater_0_conv mem_Collect_eq nth_mem
       by (metis (no_types, lifting) nth_default_def)
     then have "\<exists>(y'::real). r < y' \<and> y' < (nth_default 0 ?l 0)"
       using dense by blast
     then obtain y' where y_prop:"r < y' \<and>y' < (nth_default 0 ?l 0)" by auto
     then have "\<forall>x\<in>{r<..y'}. poly [:c, b, a:] x < 0"
       using fa by auto
     then show ?thesis using y_prop by blast 
   qed
 qed
 
 lemma continuity_lem_gt0: 
   fixes r:: "real"
   fixes a b c:: "real"
   shows "poly [:c, b, a:] r > 0 \<Longrightarrow>
     \<exists>y'> r. \<forall>x\<in>{r<..y'}. poly [:c, b, a:] x > 0"
 proof -
   assume r_gtz: "poly [:c, b, a:] r > 0 "
   let ?p = "[:-c, -b, -a:]"
   have revpoly: "\<forall>x. -1*(poly [:c, b, a:] x) = poly [:-c, -b, -a:] x"    
     by (metis (no_types, opaque_lifting) Polynomial.poly_minus minus_pCons mult_minus1 neg_equal_0_iff_equal)
   then have "poly ?p r < 0" using r_gtz
     by (metis mult_minus1 neg_less_0_iff_less)
   then have "\<exists>y'> r. \<forall>x\<in>{r<..y'}. poly ?p x < 0" using continuity_lem_lt0
     by blast
   then obtain y' where y_prop: "y' > r \<and> (\<forall>x\<in>{r<..y'}. poly ?p x < 0)" by auto
   then have "\<forall>x\<in>{r<..y'}. poly [:c, b, a:] x > 0 " using revpoly
     using neg_less_0_iff_less by fastforce
   then show ?thesis 
     using y_prop  by blast 
 qed
 
 lemma continuity_lem_lt0_expanded: 
   fixes r:: "real"
   fixes a b c:: "real"
   shows "a*r^2 + b*r + c < 0 \<Longrightarrow>
     \<exists>y'> r. \<forall>x\<in>{r<..y'}. a*x^2 + b*x + c < 0"
   using quadratic_poly_eval continuity_lem_lt0 
   by (simp add: add.commute) 
 
 lemma continuity_lem_gt0_expanded: 
   fixes r:: "real"
   fixes a b c:: "real"
   fixes k::"real"
   assumes kgt: "k > r"
   shows "a*r^2 + b*r + c > 0 \<Longrightarrow>
     \<exists>x\<in>{r<..k}. a*x^2 + b*x + c > 0"
 proof -
   assume "a*r^2 + b*r + c > 0"
   then have "\<exists>y'> r. \<forall>x\<in>{r<..y'}. poly [:c, b, a:] x > 0"
     using continuity_lem_gt0 quadratic_poly_eval[of c b a r] by auto 
   then obtain y' where y_prop: "y' > r \<and> (\<forall>x\<in>{r<..y'}. poly [:c, b, a:] x > 0)" by auto
   then have "\<exists>q. q > r \<and> q < min k y'" using kgt dense
     by (metis min_less_iff_conj)   
   then obtain q where q_prop: "q > r \<and>q < min k y'" by auto
   then have "a*q^2 + b*q + c > 0" using y_prop  quadratic_poly_eval[of c b a q]
     by (metis greaterThanAtMost_iff less_eq_real_def min_less_iff_conj)
   then show ?thesis
     using q_prop by auto
 qed
 
 subsection "Negative Infinity (Limit) Properties"
 
 lemma ysq_dom_y: 
   fixes b:: "real"
   fixes c:: "real"
   shows "\<exists>(w::real). \<forall>(y:: real). (y < w \<longrightarrow> y^2 > b*y)"
 proof - 
   have c1: "b \<ge> 0 ==> \<exists>(w::real). \<forall>(y:: real). (y < w \<longrightarrow> y^2 > b*y)"
   proof - 
     assume "b \<ge> 0"
     then have p1: "\<forall>(y:: real). (y < -1 \<longrightarrow> y*b \<le> 0)"
       by (simp add: mult_nonneg_nonpos2)
     have p2: "\<forall>(y:: real). (y < -1 \<longrightarrow> y^2 > 0)"
       by auto 
     then have h1: "\<forall>(y:: real). (y < -1 \<longrightarrow> y^2 > b*y)"  
       using p1 p2
       by (metis less_eq_real_def less_le_trans mult.commute) 
     then show ?thesis by auto
   qed
   have c2: "b < 0 \<and> b > -1 ==> \<exists>(w::real). \<forall>(y:: real). (y < w \<longrightarrow> y^2 > b*y)"
   proof - 
     assume "b < 0 \<and> b > -1 "
     then have h1: "\<forall>(y:: real). (y < -1 \<longrightarrow> y^2 > b*y)"
       by (simp add: power2_eq_square)  
     then show ?thesis by auto
   qed   
   have c3: "b \<le> -1 ==> \<exists>(w::real). \<forall>(y:: real). (y < w \<longrightarrow> y^2 > b*y)"
   proof - 
     assume "b \<le> -1 "
     then have h1: "\<forall>(y:: real). (y < b \<longrightarrow> y^2 > b*y)"
       by (metis le_minus_one_simps(3) less_irrefl less_le_trans mult.commute mult_less_cancel_left power2_eq_square)
     then show ?thesis by auto
   qed   
   then  show ?thesis using c1 c2 c3
     by (metis less_trans linorder_not_less) 
 qed
 
 lemma ysq_dom_y_plus_coeff: 
   fixes b:: "real"
   fixes c:: "real"
   shows "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> y^2 > b*y + c)"
 proof - 
   have "\<exists>(w::real). \<forall>(y:: real). (y < w \<longrightarrow> y^2 > b*y)" using ysq_dom_y by auto
   then obtain w where w_prop: "\<forall>(y:: real). (y < w \<longrightarrow> y^2 > b*y)" by auto
   have "c \<le> 0 \<Longrightarrow>  \<forall>(y::real). (y < w \<longrightarrow> y^2 > b*y + c)"
     using w_prop by auto 
   then have c1: "c \<le> 0 \<Longrightarrow> \<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> y^2 > b*y + c)" by auto
   have "\<exists>(w::real). \<forall>(y:: real). (y < w \<longrightarrow> y^2 > (b-c)*y)" using ysq_dom_y by auto
   then obtain k where k_prop: "\<forall>(y:: real). (y < k \<longrightarrow> y^2 > (b-c)*y)" by auto
   let ?mn = "min k (-1)"
   have "(c> 0 \<Longrightarrow> (\<forall> y < -1. -c*y > c))" 
   proof - 
     assume cgt: " c> 0"
     show "\<forall>(y::real) < -1. -c*y > c"
     proof clarsimp
       fix y::"real"
       assume "y < -1"
       then have "-y > 1"
         by auto
       then have "c < c*(-y)" using cgt 
         by (metis \<open>1 < - y\<close> mult.right_neutral mult_less_cancel_left_pos)
       then show " c < - (c * y) "
         by auto
     qed
   qed
   then have "(c> 0 \<longrightarrow> (\<forall> y < ?mn. (b-c)*y > b*y + c))" 
     by (simp add: left_diff_distrib) 
   then have c2:  "c > 0 \<Longrightarrow>  \<forall>(y::real). (y < ?mn \<longrightarrow> y^2 > b*y + c)"
     using k_prop
     by force
   then have c2:  "c > 0 \<Longrightarrow> \<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> y^2 > b*y + c)"
     by blast
   show ?thesis using c1 c2
     by fastforce
 qed
 
 lemma ysq_dom_y_plus_coeff_2: 
   fixes b:: "real"
   fixes c:: "real"
   shows "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> y^2 > b*y + c)"
 proof - 
   have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> y^2 > -b*y + c)"
     using ysq_dom_y_plus_coeff[where b = "-b", where c = "c"] by auto
   then obtain w where w_prop: "\<forall>(y::real). (y < w \<longrightarrow> y^2 > -b*y + c)" by auto
   let ?mn = "min w (-1)"
   have "\<forall>(y::real). (y < ?mn \<longrightarrow> y^2 > -b*y + c)" using w_prop by auto
   then have "\<forall>(y::real). (y > (-1*?mn) \<longrightarrow> y^2 > b*y + c)"
     by (metis (no_types, opaque_lifting) minus_less_iff minus_mult_commute mult_1 power2_eq_iff)
   then show ?thesis by auto
 qed
 
 lemma neg_lc_dom_quad: 
   fixes a:: "real"
   fixes b:: "real"
   fixes c:: "real"
   assumes alt: "a < 0"
   shows "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> a*y^2 + b*y + c < 0)"
 proof -
   have "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> y^2 > (-b/a)*y + (-c/a))"
     using ysq_dom_y_plus_coeff_2[where b = "-b/a", where c = "-c/a"] by auto
   then have keyh: "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> a*y^2 < a*((-b/a)*y + (-c/a)))"
     using alt by auto
   have simp1: "\<forall>y. a*((-b/a)*y + (-c/a)) = a*(-b/a)*y + a*(-c/a)"
     using diff_divide_eq_iff by fastforce
   have simp2: "\<forall>y. a*(-b/a)*y + a*(-c/a) = -b*y + a*(-c/a)"
     using assms by auto
   have simp3: "\<forall>y. -b*y + a*(-c/a) = -b*y - c"
     using assms by auto
   then have "\<forall>y. a*((-b/a)*y + (-c/a)) = -b*y - c" using simp1 simp2 simp3 by auto
   then have keyh2: "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> a*y^2 < -b*y-c)"
     using keyh by auto
   have "\<forall>y. a*y^2 < -b*y-c \<longleftrightarrow> a*y^2 + b*y + c < 0" by auto
   then show ?thesis using keyh2 by auto
 qed
 
 lemma pos_lc_dom_quad: 
   fixes a:: "real"
   fixes b:: "real"
   fixes c:: "real"
   assumes alt: "a > 0"
   shows "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> a*y^2 + b*y + c > 0)"
 proof -
   have "-a < 0" using alt
     by simp 
   then have "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> -a*y^2 - b*y - c < 0)"
     using neg_lc_dom_quad[where a = "-a", where b = "-b", where c = "-c"] by auto
   then obtain w where w_prop: "\<forall>(y::real). (y > w \<longrightarrow> -a*y^2 - b*y - c < 0)" by auto
   then have "\<forall>(y::real). (y > w \<longrightarrow> a*y^2 + b*y + c > 0)"
     by auto
   then show ?thesis by auto
 qed
 
 (* lemma interval_infinite: 
   fixes r p::"real"
   assumes "r < p"
   shows "infinite {r<..<p}"
   using Set_Interval.dense_linorder_class.infinite_Ioo using assms by blast 
 *)
 
 subsection "Infinitesimal and Continuity Properties"
 lemma les_qe_inf_helper: 
   fixes q:: "real"
   shows"(\<forall>(d, e, f)\<in>set les. \<exists>y'> q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f < 0) \<Longrightarrow> 
     (\<exists>y'>q. (\<forall>(d, e, f)\<in>set les. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f < 0))"
 proof (induct les)
   case Nil
   then show ?case using gt_ex by auto 
 next
   case (Cons z les)
   have "\<forall>a\<in>set les. case a of (d, e, f) \<Rightarrow> \<exists>y'>q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f < 0"
     using  Cons.prems by auto
   then have " \<exists>y'>q. \<forall>a\<in>set les. case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f < 0"
     using Cons.hyps by auto
   then obtain y1 where y1_prop : "y1>q \<and> (\<forall>a\<in>set les. case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..y1}. d * x\<^sup>2 + e * x + f < 0)"
     by auto
   have "case z of (d, e, f) \<Rightarrow> \<exists>y'>q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f < 0"
     using Cons.prems by auto
   then obtain y2 where y2_prop: "y2>q \<and> (case z of (d, e, f) \<Rightarrow> (\<forall>x\<in>{q<..y2}. d * x\<^sup>2 + e * x + f < 0))"
     by auto
   let ?y = "min y1 y2"
   have "?y > q \<and> (\<forall>a\<in>set (z#les). case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..?y}. d * x\<^sup>2 + e * x + f < 0)"
     using y1_prop y2_prop
     by force
   then show ?case
     by blast
 qed 
 
 lemma have_inbetween_point_les:
   fixes r::"real"
   assumes "(\<forall>(d, e, f)\<in>set les. \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0)"
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
 proof -
   have "(\<forall>(d, e, f)\<in>set les. \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<Longrightarrow> 
     (\<exists>y'>r. (\<forall>(d, e, f)\<in>set les. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0))"
     using les_qe_inf_helper assms by auto
   then have "(\<exists>y'>r. (\<forall>(d, e, f)\<in>set les. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0))"
     using assms
     by blast 
   then obtain y where y_prop: "y > r \<and>  (\<forall>(d, e, f)\<in>set les. \<forall>x\<in>{r<..y}. d * x\<^sup>2 + e * x + f < 0)"
     by auto
   have "\<exists>q. q >  r \<and>q < y" using y_prop dense by auto
   then obtain q where q_prop: "q > r \<and> q < y" by auto
   then have "(\<forall>(d, e, f)\<in>set les. d*q^2 + e*q + f < 0)"
     using y_prop by auto
   then show ?thesis
     by auto
 qed
 
 lemma one_root_a_gt0: 
   fixes a b c r:: "real"
   shows "\<And>y'. b = 2 * a * r \<Longrightarrow>
           \<not> a < 0 \<Longrightarrow>
           a * r^2 - 2 * a *r*r + c = 0 \<Longrightarrow>
           - r < y' \<Longrightarrow>
           \<exists>x\<in>{-r<..y'}. \<not> a * x\<^sup>2 + 2 * a * r*x + c < 0"
 proof - 
   fix y'
   assume beq: "b = 2 * a * r"
   assume aprop: " \<not> a < 0"
   assume root: " a * r\<^sup>2 - 2 * a *r*r + c = 0"
   assume rootlt: "- r < y'"
   show " \<exists>x\<in>{- r<..y'}. \<not> a * x\<^sup>2 + 2 * a* r*x+ c < 0"
   proof - 
     have h: "a = 0 \<Longrightarrow> (b = 0 \<and> c = 0)" using beq root   
       by auto
     then have aeq: "a = 0 \<Longrightarrow> \<exists>x\<in>{- r<..y'}. \<not> a * x\<^sup>2 + 2 * a*r*x + c < 0"
       using rootlt
       by (metis add.left_neutral continuity_lem_eq0 less_numeral_extra(3) mult_zero_left mult_zero_right) 
     then have alt: "a > 0 \<Longrightarrow> \<exists>x\<in>{- r<..y'}. \<not> a * x\<^sup>2 + 2 * a *r*x + c < 0"
     proof - 
       assume agt: "a > 0"
       then have "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> a*y^2 + b*y + c > 0)"
         using pos_lc_dom_quad by auto
       then obtain w where w_prop: "\<forall>y::real. (y > w \<longrightarrow> a*y^2 + b*y + c > 0)" by auto
       have isroot: "a*(-r)^2 + b*(-r) + c = 0" using root beq by auto
       then have wgteq: "w \<ge> -(r)"
       proof -
         have "w < -r \<Longrightarrow> False"
           using w_prop isroot by auto
         then show ?thesis
           using not_less by blast 
       qed
       then have w1: "w + 1 > -r"
         by auto 
       have w2: "a*(w + 1)^2 + b*(w+1) + c > 0" using w_prop by auto
       have rootiff: "\<forall>x. a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> x = -r" using  discriminant_lemma[where a = "a", where b = "b", where c= "c", where r = "r"]
           isroot agt beq by auto
       have allgt: "\<forall>x > -r. a*x^2 + b*x + c > 0"
       proof clarsimp 
         fix x
         assume "x > -r"
         have xgtw:  "x > w + 1 \<Longrightarrow> a*x^2 + b*x + c > 0 "
           using w1 w2 rootiff  poly_IVT_neg[where a = "w+1", where b = "x", where p = "[:c,b,a:]"] 
             quadratic_poly_eval
           by (metis less_eq_real_def linorder_not_less) 
         have xltw: "x < w + 1 \<Longrightarrow> a*x^2 + b*x + c > 0"
           using w1 w2 rootiff poly_IVT_pos[where a= "x", where b = "w + 1", where p = "[:c,b,a:]"]
             quadratic_poly_eval less_eq_real_def linorder_not_less
           by (metis \<open>- r < x\<close>)
         then show "a*x^2 + b*x + c > 0"
           using w2 xgtw xltw by fastforce 
       qed
       have "\<exists>z. z > -r \<and> z < y'" using rootlt dense[where x = "-r", where y = "y'"] 
         by auto
       then obtain z where z_prop: " z > -r \<and> z  < y'" by auto
       then have "a*z^2 + b*z + c > 0" using allgt by auto
       then show ?thesis using z_prop
         using beq greaterThanAtMost_iff by force 
     qed
     then show ?thesis using aeq alt aprop
       by linarith
   qed
 qed
 
 lemma leq_qe_inf_helper: 
   fixes q:: "real"
   shows"(\<forall>(d, e, f)\<in>set leq. \<exists>y'> q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<Longrightarrow> 
     (\<exists>y'>q. (\<forall>(d, e, f)\<in>set leq. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<le> 0))"
 proof (induct leq)
   case Nil
   then show ?case using gt_ex by auto 
 next
   case (Cons z leq)
   have "\<forall>a\<in>set leq. case a of (d, e, f) \<Rightarrow> \<exists>y'>q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<le> 0"
     using  Cons.prems by auto
   then have " \<exists>y'>q. \<forall>a\<in>set leq. case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<le> 0"
     using Cons.hyps by auto
   then obtain y1 where y1_prop : "y1>q \<and> (\<forall>a\<in>set leq. case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..y1}. d * x\<^sup>2 + e * x + f \<le> 0)"
     by auto
   have "case z of (d, e, f) \<Rightarrow> \<exists>y'>q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<le> 0"
     using Cons.prems by auto
   then obtain y2 where y2_prop: "y2>q \<and> (case z of (d, e, f) \<Rightarrow> (\<forall>x\<in>{q<..y2}. d * x\<^sup>2 + e * x + f \<le> 0))"
     by auto
   let ?y = "min y1 y2"
   have "?y > q \<and> (\<forall>a\<in>set (z#leq). case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..?y}. d * x\<^sup>2 + e * x + f \<le> 0)"
     using y1_prop y2_prop
     by force
   then show ?case
     by blast
 qed 
 
 lemma neq_qe_inf_helper: 
   fixes q:: "real"
   shows"(\<forall>(d, e, f)\<in>set neq. \<exists>y'> q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<Longrightarrow> 
     (\<exists>y'>q. (\<forall>(d, e, f)\<in>set neq. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
 proof (induct neq)
   case Nil
   then show ?case using gt_ex by auto 
 next
   case (Cons z neq)
   have "\<forall>a\<in>set neq. case a of (d, e, f) \<Rightarrow> \<exists>y'>q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0"
     using  Cons.prems by auto
   then have " \<exists>y'>q. \<forall>a\<in>set neq. case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0"
     using Cons.hyps by auto
   then obtain y1 where y1_prop : "y1>q \<and> (\<forall>a\<in>set neq. case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..y1}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
     by auto
   have "case z of (d, e, f) \<Rightarrow> \<exists>y'>q. \<forall>x\<in>{q<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0"
     using Cons.prems by auto
   then obtain y2 where y2_prop: "y2>q \<and> (case z of (d, e, f) \<Rightarrow> (\<forall>x\<in>{q<..y2}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
     by auto
   let ?y = "min y1 y2"
   have "?y > q \<and> (\<forall>a\<in>set (z#neq). case a of (d, e, f) \<Rightarrow> \<forall>x\<in>{q<..?y}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
     using y1_prop y2_prop
     by force
   then show ?case
     by blast
 qed 
 
 
 subsection "Some Casework"
 
 lemma quadratic_shape1a:
   fixes a b c x y::"real"
   assumes agt: "a > 0"
   assumes xyroots: "x < y \<and> a*x^2 + b*x + c = 0 \<and> a*y^2 + b*y + c = 0"
   shows "\<And>z. (z > x \<and> z < y \<Longrightarrow> a*z^2 + b*z + c < 0)"
 proof clarsimp 
   fix z
   assume zgt: "z > x"
   assume zlt: "z < y"
   have frac_gtz: "(1/(2*a)) > 0" using agt
     by simp 
   have xy_prop:"(x = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> y = (-b - sqrt(b^2 - 4*a*c))/(2*a))
     \<or> (y = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> x = (-b - sqrt(b^2 - 4*a*c))/(2*a))" 
     using xyroots agt discriminant_iff unfolding discrim_def by auto   
   have "b^2 - 4*a*c \<ge> 0" using xyroots discriminant_iff
     using assms(1) discrim_def by auto 
   then have pos_discrim: "b^2 - 4*a*c > 0" using xyroots discriminant_zero
     using \<open>0 \<le> b\<^sup>2 - 4 * a * c\<close> assms(1) discrim_def less_eq_real_def linorder_not_less
     by metis
   then have sqrt_gt: "sqrt(b^2 - 4*a*c) > 0"
     using real_sqrt_gt_0_iff by blast 
   then have "(- b - sqrt(b^2 - 4*a*c)) < (- b + sqrt(b^2 - 4*a*c))"
     by auto
   then have "(- b - sqrt(b^2 - 4*a*c))*(1/(2*a)) < (- b + sqrt(b^2 - 4*a*c))*(1/(2*a)) "
     using frac_gtz
     by (simp add: divide_strict_right_mono) 
   then have "(- b - sqrt(b^2 - 4*a*c))/(2*a) < (- b + sqrt(b^2 - 4*a*c))/(2*a)"
     by auto
   then have xandy: "x = (- b - sqrt(b^2 - 4*a*c))/(2*a) \<and> y = (- b + sqrt(b^2 - 4*a*c))/(2*a)"
     using xy_prop xyroots by auto
   let ?mdpt = "-b/(2*a)"
   have xlt: "x < ?mdpt"
     using xandy sqrt_gt using frac_gtz divide_minus_left divide_strict_right_mono sqrt_gt
     by (smt (verit) agt)
   have ylt: "?mdpt < y"
     using xandy sqrt_gt frac_gtz
     by (smt (verit, del_insts) divide_strict_right_mono zero_less_divide_1_iff) 
   have mdpt_val: "a*?mdpt^2 + b*?mdpt + c < 0"
   proof - 
     have firsteq: "a*?mdpt^2 + b*?mdpt + c = (a*b^2)/(4*a^2) - (b^2)/(2*a) + c"
       by (simp add: power2_eq_square) 
     have h1: "(a*b^2)/(4*a^2) = (b^2)/(4*a)"
       by (simp add: power2_eq_square)
     have h2: "(b^2)/(2*a) = (2*b^2)/(4*a)"
       by linarith
     have h3: "c = (4*a*c)/(4*a)"
       using agt by auto 
     have "a*?mdpt^2 + b*?mdpt + c = (b^2)/(4*a) - (2*b^2)/(4*a) + (4*a*c)/(4*a) "
       using firsteq h1 h2 h3
       by linarith 
     then have "a*?mdpt^2 + b*?mdpt + c = (b^2 - 2*b^2 + 4*a*c)/(4*a)"
       by (simp add: diff_divide_distrib)
     then have eq2: "a*?mdpt^2 + b*?mdpt + c = (4*a*c - b^2)/(4*a)"
       by simp
     have h: "4*a*c - b^2 < 0" using pos_discrim by auto
     have "1/(4*a) > 0" using agt by auto
     then have "(4*a*c - b^2)*(1/(4*a)) < 0"
       using h
       using mult_less_0_iff by blast 
     then show ?thesis using eq2 by auto
   qed
   have nex: "\<not> (\<exists>k> x. k < y \<and> poly [:c, b, a:] k = 0)"
     using discriminant_iff agt
     by (metis discrim_def less_irrefl quadratic_poly_eval xandy)
   have nor2: "\<not> (\<exists>x>z. x < - b / (2 * a) \<and> poly [:c, b, a:] x = 0)"
     using nex xlt ylt zgt zlt by auto
   have nor: "\<not> (\<exists>x>- b / (2 * a). x < z \<and> poly [:c, b, a:] x = 0)"
     using nex xlt ylt zgt zlt discriminant_iff agt  by auto 
   then have mdpt_lt: "?mdpt < z \<Longrightarrow> a*z^2 + b*z + c < 0 "
     using mdpt_val zgt zlt xlt ylt poly_IVT_pos[where p = "[:c, b, a:]", where a= "?mdpt", where b = "z"] 
       quadratic_poly_eval[of c b a]
     by (metis \<open>\<not> (\<exists>k>x. k < y \<and> poly [:c, b, a:] k = 0)\<close> linorder_neqE_linordered_idom) 
   have mdpt_gt: "?mdpt > z \<Longrightarrow> a*z^2 + b*z + c < 0 "
     using zgt zlt mdpt_val xlt ylt nor2 poly_IVT_neg[where p = "[:c, b, a:]", where a = "z", where b = "?mdpt"] quadratic_poly_eval[of c b a]
     by (metis linorder_neqE_linordered_idom nex) 
   then show "a*z^2 + b*z + c < 0" 
     using mdpt_lt mdpt_gt mdpt_val by fastforce 
 qed
 
 lemma quadratic_shape1b:
   fixes a b c x y::"real"
   assumes agt: "a > 0"
   assumes xy_roots: "x < y \<and> a*x^2 + b*x + c = 0 \<and> a*y^2 + b*y + c = 0"
   shows "\<And>z. (z > y \<Longrightarrow> a*z^2 + b*z + c > 0)"
 proof - 
   fix z
   assume z_gt :"z > y"
   have nogt: "\<not>(\<exists>w. w > y \<and> a*w^2 + b*w + c = 0)" using xy_roots discriminant_iff
     by (metis agt less_eq_real_def linorder_not_less)
   have "\<exists>(w::real). \<forall>(y::real). (y > w \<longrightarrow> a*y^2 + b*y + c > 0)"
     using agt pos_lc_dom_quad by auto
   then have "\<exists>k > y.  a*k^2 + b*k + c > 0"
     by (metis add.commute agt less_add_same_cancel1 linorder_neqE_linordered_idom pos_add_strict) 
   then obtain k where k_prop: "k > y \<and> a*k^2 + b*k + c > 0" by auto
   have kgt: "k > z \<Longrightarrow> a*z^2 + b*z + c > 0" 
   proof - 
     assume kgt: "k > z"
     then have zneq: "a*z^2 + b*z + c = 0 \<Longrightarrow> False"
       using nogt  using z_gt by blast 
     have znlt: "a*z^2 + b*z + c < 0 \<Longrightarrow> False"
       using kgt k_prop quadratic_poly_eval[of c b a] z_gt  nogt poly_IVT_pos[where a= "z", where b = "k", where p = "[:c, b, a:]"]
       by (metis less_eq_real_def less_le_trans)
     then show "a*z^2 + b*z + c > 0" using zneq znlt
       using linorder_neqE_linordered_idom by blast 
   qed
   have klt: "k < z \<Longrightarrow> a*z^2 + b*z + c > 0" 
   proof - 
     assume klt: "k < z"
     then have zneq: "a*z^2 + b*z + c = 0 \<Longrightarrow> False"
       using nogt using z_gt by blast 
     have znlt: "a*z^2 + b*z + c < 0 \<Longrightarrow> False"
       using klt k_prop quadratic_poly_eval[of c b a] z_gt  nogt poly_IVT_neg[where a= "k", where b = "z", where p = "[:c, b, a:]"]
       by (metis add.commute add_less_cancel_left add_mono_thms_linordered_field(3) less_eq_real_def)
     then show "a*z^2 + b*z + c > 0" using zneq znlt
       using linorder_neqE_linordered_idom by blast 
   qed
   then show "a*z^2 + b*z + c > 0" using k_prop kgt klt
     by fastforce 
 qed
 
 lemma quadratic_shape2a:
   fixes a b c x y::"real"
   assumes "a < 0"
   assumes "x < y \<and> a*x^2 + b*x + c = 0 \<and> a*y^2 + b*y + c = 0"
   shows "\<And>z. (z > x \<and> z < y \<Longrightarrow> a*z^2 + b*z + c > 0)"
   using quadratic_shape1a[where a= "-a", where b = "-b", where c = "-c", where x = "x", where y = "y"]
   using assms(1) assms(2) by fastforce 
 
 lemma quadratic_shape2b:
   fixes a b c x y::"real"
   assumes "a < 0"
   assumes "x < y \<and> a*x^2 + b*x + c = 0 \<and> a*y^2 + b*y + c = 0"
   shows "\<And>z. (z > y \<Longrightarrow> a*z^2 + b*z + c < 0)"
   using quadratic_shape1b[where a= "-a", where b = "-b", where c = "-c", where x = "x", where y = "y"]
   using assms(1) assms(2) by force 
 
 lemma case_d1:
   fixes a b c r::"real"
   shows "b < 2 * a * r \<Longrightarrow>
     a * r^2 - b*r + c = 0 \<Longrightarrow>
     \<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c < 0"
 proof - 
   assume b_lt: "b < 2*a*r"
   assume root: "a*r^2 - b*r + c = 0"
   then have "c = b*r - a*r^2" by auto
   have aeq: "a = 0 \<Longrightarrow> \<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c < 0"
   proof - 
     assume azer: "a = 0"
     then have bltz: "b < 0" using b_lt by auto
     then have "c = b*r" using azer root by auto
     then have eval: "\<forall>x. a*x^2 + b*x + c = b*(x + r)" using azer
       by (simp add: distrib_left) 
     have "\<forall>x > -r. b*(x + r) < 0" 
     proof clarsimp 
       fix x
       assume xgt: "- r < x"
       then have "x + r > 0"
         by linarith 
       then show "b * (x + r) < 0"
         using bltz using mult_less_0_iff by blast 
     qed
     then show ?thesis using eval
       using less_add_same_cancel1 zero_less_one
       by (metis greaterThanAtMost_iff)
   qed
   have aneq: "a \<noteq> 0 \<Longrightarrow>\<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c < 0"
   proof - 
     assume aneq: "(a::real) \<noteq> 0"
     have "b^2 - 4*a*c < 0 \<Longrightarrow> a * r\<^sup>2 + b * r + c \<noteq> 0" using root discriminant_negative[of a b c r] unfolding discrim_def 
       using aneq by auto
     then have " a * r\<^sup>2 + b * r + c \<noteq> 0 \<Longrightarrow>
     a * r\<^sup>2 - b * r + c = 0 \<Longrightarrow>
     b\<^sup>2 < 4 * a * c \<Longrightarrow> False"
     proof -
       assume a1: "a * r\<^sup>2 - b * r + c = 0"
       assume a2: "b\<^sup>2 < 4 * a * c"
       have f3: "(0 \<le> - 1 * (4 * a * c) + (- 1 * b)\<^sup>2) = (4 * a * c + - 1 * (- 1 * b)\<^sup>2 \<le> 0)"
         by simp
       have f4: "(- 1 * b)\<^sup>2 + - 1 * (4 * a * c) = - 1 * (4 * a * c) + (- 1 * b)\<^sup>2"
         by auto
       have f5: "c + a * r\<^sup>2 + - 1 * b * r = a * r\<^sup>2 + c + - 1 * b * r"
         by auto
       have f6: "\<forall>x0 x1 x2 x3. (x3::real) * x0\<^sup>2 + x2 * x0 + x1 = x1 + x3 * x0\<^sup>2 + x2 * x0"
         by simp
       have f7: "\<forall>x1 x2 x3. (discrim x3 x2 x1 < 0) = (\<not> 0 \<le> discrim x3 x2 x1)"
         by auto
       have f8: "\<forall>r ra rb. discrim r ra rb = ra\<^sup>2 + - 1 * (4 * r * rb)"
         using discrim_def by auto
       have "\<not> 4 * a * c + - 1 * (- 1 * b)\<^sup>2 \<le> 0"
         using a2 by simp
       then have "a * r\<^sup>2 + c + - 1 * b * r \<noteq> 0"
         using f8 f7 f6 f5 f4 f3 by (metis (no_types) aneq discriminant_negative)
       then show False
         using a1 by linarith
     qed 
     then have "\<not>(b^2 - 4*a*c < 0)" using root
       using \<open>b\<^sup>2 - 4 * a * c < 0 \<Longrightarrow> a * r\<^sup>2 + b * r + c \<noteq> 0\<close> by auto
     then have discrim: "b\<^sup>2 \<ge> 4 * a * c " by auto
     then have req: "r = (b + sqrt(b^2 - 4*a*c))/(2*a) \<or> r = (b - sqrt(b^2 - 4*a*c))/(2*a)"
       using aneq root discriminant_iff[where a="a", where b ="-b", where c="c", where x="r"] unfolding discrim_def
       by auto
     then have "r = (b - sqrt(b^2 - 4*a*c))/(2*a) \<Longrightarrow> b > 2*a*r"
     proof - 
       assume req: "r = (b - sqrt(b^2 - 4*a*c))/(2*a)"
       then have h1: "2*a*r = 2*a*((b - sqrt(b^2 - 4*a*c))/(2*a))" by auto
       then have h2: "2*a*((b - sqrt(b^2 - 4*a*c))/(2*a)) = b - sqrt(b^2 - 4*a*c)"
         using aneq by auto
       have h3: "sqrt(b^2 - 4*a*c) \<ge> 0" using discrim  by auto
       then have "b - sqrt(b^2 - 4*a*c) < b"
         using b_lt h1 h2 by linarith
       then show ?thesis using req h2 by auto
     qed
     then have req: "r = (b + sqrt(b^2 - 4*a*c))/(2*a)" using req b_lt by auto
     then have discrim2: "b^2 - 4 *a*c > 0" using aneq b_lt  by auto
     then have "\<exists>x y. x \<noteq> y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0"
       using aneq discriminant_pos_ex[of a b c] unfolding discrim_def
       by auto
     then obtain x y where xy_prop: "x < y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0"
       by (meson linorder_neqE_linordered_idom)
     then have "(x = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> y = (-b - sqrt(b^2 - 4*a*c))/(2*a))
 \<or> (y = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> x = (-b - sqrt(b^2 - 4*a*c))/(2*a))" 
       using aneq discriminant_iff unfolding discrim_def by auto   
     then have xy_prop2: "(x = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> y = -r)
     \<or> (y = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> x = -r)" using req
       by (simp add: \<open>x = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> y = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> x = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> minus_divide_left)
         (* When a < 0, -r is the bigger root *)
     have alt: "a < 0 \<Longrightarrow> \<forall>k > -r. a * k^2 + b * k + c < 0"
     proof clarsimp 
       fix k
       assume alt: " a < 0"
       assume "- r < k"
       have alt2: " (1/(2*a)::real) < 0" using alt
         by simp 
       have "(-b - sqrt(b^2 - 4*a*c)) < (-b + sqrt(b^2 - 4*a*c))"
         using discrim2 by auto
       then have "(-b - sqrt(b^2 - 4*a*c))* (1/(2*a)::real) > (-b + sqrt(b^2 - 4*a*c))* (1/(2*a)::real)"
         using alt2
         using mult_less_cancel_left_neg by fastforce 
       then have rgtroot: "-r >  (-b + sqrt(b^2 - 4*a*c))/(2*a)"
         using req  \<open>x = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> y = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> x = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> xy_prop2
         by auto 
       then have "(y = -r \<and> x = (-b + sqrt(b^2 - 4*a*c))/(2*a))"
         using xy_prop xy_prop2 by auto
       then show "a * k^2 + b * k + c < 0"
         using xy_prop \<open>- r < k\<close> alt quadratic_shape2b xy_prop 
         by blast 
     qed
       (* When a > 0, -r is the smaller root *)
     have agt: "a > 0 \<Longrightarrow> \<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c < 0"
     proof - 
       assume agt: "a> 0"
       have alt2: " (1/(2*a)::real) > 0" using agt
         by simp 
       have "(-b - sqrt(b^2 - 4*a*c)) < (-b + sqrt(b^2 - 4*a*c))"
         using discrim2 by auto
       then have "(-b - sqrt(b^2 - 4*a*c))* (1/(2*a)::real) < (-b + sqrt(b^2 - 4*a*c))* (1/(2*a)::real)"
         using alt2
       proof -
         have f1: "- b - sqrt (b\<^sup>2 - c * (4 * a)) < - b + sqrt (b\<^sup>2 - c * (4 * a))"
           by (metis \<open>- b - sqrt (b\<^sup>2 - 4 * a * c) < - b + sqrt (b\<^sup>2 - 4 * a * c)\<close> mult.commute)
         have "0 < a * 2"
           using \<open>0 < 1 / (2 * a)\<close> by auto
         then show ?thesis
           using f1 by (simp add: divide_strict_right_mono mult.commute)
       qed
       then have rlltroot: "-r <  (-b + sqrt(b^2 - 4*a*c))/(2*a)"
         using req \<open>x = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> y = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> x = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> xy_prop2
         by auto
       then have "(x = -r \<and> y = (-b + sqrt(b^2 - 4*a*c))/(2*a))"
         using xy_prop xy_prop2 by auto
       have "\<exists>k. x < k \<and> k < y" using xy_prop dense by auto
       then obtain k where k_prop: "x < k \<and> k < y" by auto
       then have "\<forall>x\<in>{-r<..k}. a * x\<^sup>2 + b * x + c < 0"
         using agt quadratic_shape1a[where a= "a", where b = "b", where c= "c", where x = "x", where y = "y"]
         using \<open>x = - r \<and> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> greaterThanAtMost_iff xy_prop by auto 
       then show "\<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c < 0" 
         using k_prop using \<open>x = - r \<and> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> by blast 
     qed
     show ?thesis
       using alt agt
       by (metis aneq greaterThanAtMost_iff less_add_same_cancel1 linorder_neqE_linordered_idom zero_less_one) 
   qed
   show "\<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c < 0" using aeq aneq
     by blast 
 qed
 
 lemma case_d4:
   fixes a b c r::"real"
   shows "\<And>y'. b \<noteq> 2 * a * r \<Longrightarrow>
           \<not> b < 2 * a * r \<Longrightarrow>
           a *r^2 - b * r + c = 0 \<Longrightarrow>
           -r < y' \<Longrightarrow> \<exists>x\<in>{-r<..y'}. \<not> a * x\<^sup>2 + b * x + c < 0"
 proof - 
   fix y'
   assume bneq: "b \<noteq> 2 * a * r"
   assume bnotless: "\<not> b < 2 * a * r"
   assume root: "a *r^2 - b * r + c = 0"
   assume y_prop: "-r < y'"
   have b_gt: "b > 2*a*r" using bneq bnotless by auto
   have aeq: "a = 0 \<Longrightarrow> \<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c > 0"
   proof - 
     assume azer: "a = 0"
     then have bgt: "b > 0" using b_gt by auto
     then have "c = b*r" using azer root by auto
     then have eval: "\<forall>x. a*x^2 + b*x + c = b*(x + r)" using azer
       by (simp add: distrib_left) 
     have "\<forall>x > -r. b*(x + r) > 0" 
     proof clarsimp 
       fix x
       assume xgt: "- r < x"
       then have "x + r > 0"
         by linarith 
       then show "b * (x + r) > 0"
         using bgt by auto 
     qed
     then show ?thesis using eval 
       using less_add_same_cancel1 zero_less_one
       by (metis greaterThanAtMost_iff) 
   qed
   have aneq: "a \<noteq> 0 \<Longrightarrow>\<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c > 0"
   proof - 
     assume aneq: "a\<noteq>0"  
     {
       assume a1: "a * r\<^sup>2 - b * r + c = 0"
       assume a2: "b\<^sup>2 < 4 * a * c"
       have f3: "(0 \<le> - 1 * (4 * a * c) + (- 1 * b)\<^sup>2) = (4 * a * c + - 1 * (- 1 * b)\<^sup>2 \<le> 0)"
         by simp
       have f4: "(- 1 * b)\<^sup>2 + - 1 * (4 * a * c) = - 1 * (4 * a * c) + (- 1 * b)\<^sup>2"
         by auto
       have f5: "c + a * r\<^sup>2 + - 1 * b * r = a * r\<^sup>2 + c + - 1 * b * r"
         by auto
       have f6: "\<forall>x0 x1 x2 x3. (x3::real) * x0\<^sup>2 + x2 * x0 + x1 = x1 + x3 * x0\<^sup>2 + x2 * x0"
         by simp
       have f7: "\<forall>x1 x2 x3. (discrim x3 x2 x1 < 0) = (\<not> 0 \<le> discrim x3 x2 x1)"
         by auto
       have f8: "\<forall>r ra rb. discrim r ra rb = ra\<^sup>2 + - 1 * (4 * r * rb)"
         using discrim_def by auto
       have "\<not> 4 * a * c + - 1 * (- 1 * b)\<^sup>2 \<le> 0"
         using a2 by simp
       then have "a * r\<^sup>2 + c + - 1 * b * r \<noteq> 0"
         using f8 f7 f6 f5 f4 f3 by (metis (no_types) aneq discriminant_negative)
       then have False
         using a1 by linarith
     } note * = this
     have "b^2 - 4*a*c < 0 \<Longrightarrow> a * r\<^sup>2 + b * r + c \<noteq> 0" using root discriminant_negative[of a b c r] unfolding discrim_def 
       using aneq by auto
     then have "\<not>(b^2 - 4*a*c < 0)" using root * by auto
     then have discrim: "b\<^sup>2 \<ge> 4 * a * c " by auto
     then have req: "r = (b + sqrt(b^2 - 4*a*c))/(2*a) \<or> r = (b - sqrt(b^2 - 4*a*c))/(2*a)"
       using aneq root discriminant_iff[where a="a", where b ="-b", where c="c", where x="r"] unfolding discrim_def
       by auto
     then have "r = (b + sqrt(b^2 - 4*a*c))/(2*a) \<Longrightarrow> b < 2*a*r"
     proof - 
       assume req: "r = (b + sqrt(b^2 - 4*a*c))/(2*a)"
       then have h1: "2*a*r = 2*a*((b + sqrt(b^2 - 4*a*c))/(2*a))" by auto
       then have h2: "2*a*((b + sqrt(b^2 - 4*a*c))/(2*a)) = b + sqrt(b^2 - 4*a*c)"
         using aneq by auto
       have h3: "sqrt(b^2 - 4*a*c) \<ge> 0" using discrim  by auto
       then have "b + sqrt(b^2 - 4*a*c) > b"
         using b_gt h1 h2 by linarith
       then show ?thesis using req h2 by auto
     qed
     then have req: "r = (b - sqrt(b^2 - 4*a*c))/(2*a)" using req b_gt
       using aneq discrim by auto
     then have discrim2: "b^2 - 4 *a*c > 0" using aneq b_gt  by auto
     then have "\<exists>x y. x \<noteq> y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0"
       using aneq discriminant_pos_ex[of a b c] unfolding discrim_def
       by auto
     then obtain x y where xy_prop: "x < y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0"
       by (meson linorder_neqE_linordered_idom)
     then have "(x = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> y = (-b - sqrt(b^2 - 4*a*c))/(2*a))
 \<or> (y = (-b + sqrt(b^2 - 4*a*c))/(2*a) \<and> x = (-b - sqrt(b^2 - 4*a*c))/(2*a))" 
       using aneq discriminant_iff unfolding discrim_def by auto   
     then have xy_prop2: "(x = (-b - sqrt(b^2 - 4*a*c))/(2*a) \<and> y = -r)
     \<or> (y = (-b - sqrt(b^2 - 4*a*c))/(2*a) \<and> x = -r)" using req divide_inverse minus_diff_eq mult.commute mult_minus_right
       by (smt (verit, ccfv_SIG) uminus_add_conv_diff)
         (* When a > 0, -r is the greater root *)
     have agt: "a > 0 \<Longrightarrow> \<forall>k > -r. a * k^2 + b * k + c > 0"
     proof clarsimp 
       fix k
       assume agt: " a > 0"
       assume "- r < k"
       have agt2: " (1/(2*a)::real) > 0" using agt
         by simp 
       have "(-b - sqrt(b^2 - 4*a*c)) < (-b + sqrt(b^2 - 4*a*c))"
         using discrim2 by auto
       then have "(-b - sqrt(b^2 - 4*a*c))* (1/(2*a)::real) < (-b + sqrt(b^2 - 4*a*c))* (1/(2*a)::real)"
         using agt2 by (simp add: divide_strict_right_mono) 
       then have rgtroot: "-r >  (-b - sqrt(b^2 - 4*a*c))/(2*a)"
         using  req \<open>x = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> y = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> x = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> xy_prop2
         by auto 
       then have "(x = (-b - sqrt(b^2 - 4*a*c))/(2*a)) \<and> y = -r"
         using xy_prop xy_prop2 
         by auto
       then show "a * k^2 + b * k + c > 0"
         using \<open>- r < k\<close> xy_prop agt quadratic_shape1b[where a= "a", where b ="b", where c="c", where x = "x", where y = "-r", where z = "k"]    
         by blast 
     qed
       (* When a < 0, -r is the smaller root *)
     have agt2: "a < 0 \<Longrightarrow> \<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c > 0"
     proof - 
       assume alt: "a<0"
       have alt2: " (1/(2*a)::real) < 0" using alt
         by simp 
       have "(-b - sqrt(b^2 - 4*a*c)) < (-b + sqrt(b^2 - 4*a*c))"
         using discrim2 by auto
       then have "(-b - sqrt(b^2 - 4*a*c))* (1/(2*a)::real) > (-b + sqrt(b^2 - 4*a*c))* (1/(2*a)::real)"
         using alt2  using mult_less_cancel_left_neg by fastforce 
       then have rlltroot: "-r < (-b - sqrt(b^2 - 4*a*c))/(2*a)"
         using req 
         using \<open>x = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> y = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> y = (- b + sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<and> x = (- b - sqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> 
           xy_prop2 
         by auto
       then have h: "(x = -r \<and> y = (-b - sqrt(b^2 - 4*a*c))/(2*a))"
         using xy_prop xy_prop2 
         by auto
       have "\<exists>k. x < k \<and> k < y" using xy_prop dense by auto
       then obtain k where k_prop: "x < k \<and> k < y" by auto
       then have "\<forall>x\<in>{-r<..k}. a * x\<^sup>2 + b * x + c > 0"
         using alt quadratic_shape2a[where a= "a", where b = "b", where c= "c", where x = "x", where y = "y"]
           xy_prop  h greaterThanAtMost_iff  by auto 
       then show "\<exists>y'>- r. \<forall>x\<in>{-r<..y'}. a * x\<^sup>2 + b * x + c > 0" 
         using k_prop using h by blast 
     qed
     show ?thesis
       using aneq agt agt2
       by (meson greaterThanAtMost_iff linorder_neqE_linordered_idom y_prop) 
   qed
   show "\<exists>x\<in>{-r<..y'}. \<not> a * x\<^sup>2 + b * x + c < 0" using aneq aeq
     by (metis greaterThanAtMost_iff less_eq_real_def linorder_not_less y_prop)
 qed
 
 lemma one_root_a_lt0:
   fixes a b c r y'::"real"
   assumes alt: "a < 0"
   assumes beq: "b = 2 * a * r"
   assumes root: " a * r^2 - 2*a*r*r + c = 0"
   shows "\<exists>y'>- r. \<forall>x\<in>{- r<..y'}. a * x\<^sup>2 + 2*a*r*x + c < 0"
 proof - 
   have root_iff: "\<forall>x. a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> x = -r" using alt root discriminant_lemma[where r = "r"] beq 
     by auto
   have "a < 0 \<longrightarrow> (\<exists>y. \<forall>x > y. a*x^2 + b*x + c < 0)" using neg_lc_dom_quad 
     by auto
   then obtain k where k_prop: "\<forall>x > k. a*x^2 + b*x + c < 0" using alt by auto
   let ?mx = "max (k+1) (-r + 1)"
   have "a*?mx^2 + b*?mx + c < 0" using k_prop by auto
   then have "\<exists>y > -r. a*y^2 + b*y + c < 0"
     by force
   then obtain z where z_prop: "z > -r \<and> a*z^2 + b*z + c < 0" by auto
   have poly_eval_prop: "\<forall>(x::real). poly [:c, b, a :] x = a*x^2 + b*x + c" 
     using quadratic_poly_eval by auto
   then have nozer: "\<not>(\<exists>x. (x > -r \<and> poly [:c, b, a :] x = 0))" using root_iff 
     by (simp add: add.commute) 
   have poly_z: "poly [:c, b, a:] z < 0" using z_prop poly_eval_prop by auto
   have "\<forall>y > -r. a*y^2 + b*y + c < 0" 
   proof clarsimp 
     fix y
     assume ygt: "- r < y"
     have h1: "y = z \<Longrightarrow> a * y\<^sup>2 + b * y + c < 0" using z_prop by auto
     have h2: "y < z \<Longrightarrow> a * y\<^sup>2 + b * y + c < 0" proof -
       assume ylt: "y < z"
       have notz: "a*y^2 + b*y + c \<noteq> 0" using ygt nozer poly_eval_prop by auto
       have h1: "a *y^2 + b*y + c > 0 \<Longrightarrow> poly [:c, b, a:] y > 0" using poly_eval_prop by auto
       have ivtprop: "poly [:c, b, a:] y > 0 \<Longrightarrow> (\<exists>x. y < x \<and> x < z \<and> poly [:c, b, a:] x = 0)" 
         using ylt poly_z poly_IVT_neg[where a = "y", where b = "z", where p = "[:c, b, a:]"]
         by auto
       then have "a*y^2 + b*y + c > 0 \<Longrightarrow> False" using h1 ivtprop ygt nozer by auto
       then show "a*y^2 + b*y + c < 0" using notz
         using linorder_neqE_linordered_idom by blast 
     qed
     have h3: "y > z \<Longrightarrow> a * y\<^sup>2 + b * y + c < 0" 
     proof -
       assume ygtz: "y > z"
       have notz: "a*y^2 + b*y + c \<noteq> 0" using ygt nozer poly_eval_prop by auto
       have h1: "a *y^2 + b*y + c > 0 \<Longrightarrow> poly [:c, b, a:] y > 0" using poly_eval_prop by auto
       have ivtprop: "poly [:c, b, a:] y > 0 \<Longrightarrow> (\<exists>x. z < x \<and> x < y \<and> poly [:c, b, a:] x = 0)" 
         using ygtz poly_z using poly_IVT_pos by blast 
       then have "a*y^2 + b*y + c > 0 \<Longrightarrow> False" using h1 ivtprop z_prop nozer by auto
       then show "a*y^2 + b*y + c < 0" using notz
         using linorder_neqE_linordered_idom by blast 
     qed
     show "a * y\<^sup>2 + b * y + c < 0" using h1 h2 h3
       using linorder_neqE_linordered_idom by blast
   qed
   then show ?thesis
     using \<open>\<exists>y>- r. a * y\<^sup>2 + b * y + c < 0\<close> beq by auto 
 qed
 
 
 lemma one_root_a_lt0_var:
   fixes a b c r y'::"real"
   assumes alt: "a < 0"
   assumes beq: "b = 2 * a * r"
   assumes root: " a * r^2 - 2*a*r*r + c = 0"
   shows "\<exists>y'>- r. \<forall>x\<in>{- r<..y'}. a * x\<^sup>2 + 2*a*r*x + c \<le> 0"
 proof - 
   have h1: "\<exists>y'>- r. \<forall>x\<in>{- r<..y'}. a * x\<^sup>2 + 2 * a * r * x + c < 0 \<Longrightarrow>
      \<exists>y'>-r. \<forall>x\<in>{- r<..y'}. a * x\<^sup>2 + 2 * a *r * x + c \<le> 0"
     using less_eq_real_def by blast
   then show ?thesis
     using one_root_a_lt0[of a b r] assms by auto
 qed
 
 subsection "More Continuity Properties"
 lemma continuity_lem_gt0_expanded_var: 
   fixes r:: "real"
   fixes a b c:: "real"
   fixes k::"real"
   assumes kgt: "k > r"
   shows "a*r^2 + b*r + c > 0 \<Longrightarrow>
     \<exists>x\<in>{r<..k}. a*x^2 + b*x + c \<ge> 0"
 proof -
   assume a: "a*r^2 + b*r + c > 0  "
   have h: "\<exists>x\<in>{r<..k}. a*x^2 + b*x + c > 0  \<Longrightarrow> \<exists>x\<in>{r<..k}. a*x^2 + b*x + c \<ge> 0"
     using less_eq_real_def by blast 
   have "\<exists>x\<in>{r<..k}. a*x^2 + b*x + c > 0" using a continuity_lem_gt0_expanded[of r k a b c] assms by auto
   then show "\<exists>x\<in>{r<..k}. a*x^2 + b*x + c \<ge> 0"
     using h by auto
 qed
 
 lemma continuity_lem_lt0_expanded_var: 
   fixes r:: "real"
   fixes a b c:: "real"
   shows "a*r^2 + b*r + c < 0 \<Longrightarrow>
     \<exists>y'> r. \<forall>x\<in>{r<..y'}. a*x^2 + b*x + c \<le> 0"
 proof - 
   assume "a*r^2 + b*r + c < 0 "
   then have " \<exists>y'> r. \<forall>x\<in>{r<..y'}. a*x^2 + b*x + c < 0"
     using continuity_lem_lt0_expanded by auto
   then show " \<exists>y'> r. \<forall>x\<in>{r<..y'}. a*x^2 + b*x + c \<le> 0"
     using less_eq_real_def by auto
 qed
 
 lemma nonzcoeffs:
   fixes a b c r::"real"
   shows "a\<noteq>0 \<or> b\<noteq>0 \<or> c\<noteq>0 \<Longrightarrow> \<exists>y'>r. \<forall>x\<in>{r<..y'}. a * x\<^sup>2 + b * x + c \<noteq> 0 "
 proof - 
   assume "a\<noteq>0 \<or> b\<noteq>0 \<or> c\<noteq>0"
   then have fin: "finite {x. a*x^2 + b*x + c = 0}"
     by (metis pCons_eq_0_iff poly_roots_finite poly_roots_set_same) 
       (* then have fin2: "finite {x. a*x^2 + b*x + c = 0 \<and> x > r}"
     using finite_Collect_conjI by blast *)
   let ?s = "{x. a*x^2 + b*x + c = 0}"
   have imp: "(\<exists>q \<in> ?s. q > r) \<Longrightarrow> (\<exists>q \<in> ?s. (q > r \<and> (\<forall>x \<in> ?s. x > r \<longrightarrow> x \<ge> q)))"
   proof - 
     assume asm: "(\<exists>q \<in> ?s. q > r)"
     then have none: "{q. q \<in> ?s \<and> q > r} \<noteq> {}"
       by blast 
     have fin2: "finite {q. q \<in> ?s \<and> q > r}" using fin
       by simp
     have "\<exists>k. k = Min  {q. q \<in> ?s \<and> q > r}" using fin2 none
       by blast
     then obtain k where k_prop: "k =  Min  {q. q \<in> ?s \<and> q > r}" by auto
     then have kp1: "k \<in> ?s \<and> k > r" 
       using Min_in fin2 none
       by blast 
     then  have kp2: "\<forall>x \<in> ?s. x > r \<longrightarrow> x \<ge> k" 
       using Min_le fin2  using k_prop by blast 
     show "(\<exists>q \<in> ?s. (q > r \<and> (\<forall>x \<in> ?s. x > r \<longrightarrow> x \<ge> q)))" 
       using kp1 kp2 by blast
   qed
   have h2: "(\<exists>q \<in> ?s. q > r) \<Longrightarrow> \<exists>y'>r. \<forall>x\<in>{r<..y'}. a * x\<^sup>2 + b * x + c \<noteq> 0" 
   proof - 
     assume "(\<exists>q \<in> ?s. q > r)"
     then obtain q where q_prop: "q \<in> ?s \<and> (q > r \<and> (\<forall>x \<in> ?s. x > r \<longrightarrow> x \<ge> q))"
       using imp by blast 
     then have "\<exists>w. w > r \<and> w < q" using dense
       by blast
     then obtain w where w_prop: "w > r \<and> w < q" by auto
     then have "\<not>(\<exists>x\<in>{r<..w}. x \<in> ?s)"
       using w_prop q_prop by auto
     then have "\<forall>x\<in>{r<..w}. a * x\<^sup>2 + b * x + c \<noteq> 0"
       by blast
     then show "\<exists>y'>r. \<forall>x\<in>{r<..y'}. a * x\<^sup>2 + b * x + c \<noteq> 0"
       using w_prop by blast
   qed
   have h1: "\<not>(\<exists>q \<in> ?s. q > r) \<Longrightarrow> \<exists>y'>r. \<forall>x\<in>{r<..y'}. a * x\<^sup>2 + b * x + c \<noteq> 0"
   proof - 
     assume "\<not>(\<exists>q \<in> ?s. q > r)"
     then have "\<forall>x\<in>{r<..(r+1)}. a * x\<^sup>2 + b * x + c \<noteq> 0"
       using greaterThanAtMost_iff by blast
     then show ?thesis
       using less_add_same_cancel1 less_numeral_extra(1) by blast 
   qed
   then show "\<exists>y'>r. \<forall>x\<in>{r<..y'}. a * x\<^sup>2 + b * x + c \<noteq> 0"
     using h2 by blast
 qed
 
 
 (* Show if there are infinitely many values of x where a*x^2 + b*x + c is 0,
 then the a*x^2 + b*x + c is the zero polynomial *)
 lemma infzeros : 
   fixes y:: "real"
   assumes "\<forall>x::real < (y::real). a * x\<^sup>2 + b * x + c = 0"
   shows "a = 0 \<and> b=0 \<and> c=0"
 proof - 
   let ?A = "{(x::real). x < y}"
   have "\<exists> (n::nat) f. ?A = f ` {i. i < n} \<and> inj_on f {i. i < n} \<Longrightarrow> False"
   proof clarsimp 
     fix n:: "nat" 
     fix f
     assume xlt: "{x. x < y} = f ` {i. i < n}"
     assume injh: "inj_on f {i. i < n}"
     have "?A \<noteq> {}"
       by (simp add: linordered_field_no_lb)
     then have ngtz: "n > 0" 
       using xlt injh using gr_implies_not_zero by auto 
     have cardisn: "card ?A = n" using xlt injh
       by (simp add: card_image) 
     have "\<forall>k::nat. ((y - (k::nat) - 1) \<in> ?A)" 
       by auto
     then have subs: "{k. \<exists>(x::nat). k = y - x - 1 \<and> 0 \<le> x \<and> x \<le> n} \<subseteq> ?A"
       by auto
     have seteq: "(\<lambda>x. y - real x - 1) ` {0..n} ={k. \<exists>(x::nat). k = y - x - 1 \<and> 0 \<le> x \<and> x \<le> n}"
       by auto
     have injf: "inj_on (\<lambda>x. y - real x - 1) {0..n}"
       unfolding inj_on_def by auto
     have "card {k. \<exists>(x::nat). k = y - x - 1 \<and> 0 \<le> x \<and> x \<le> n} = n + 1"
       using  injf seteq card_atMost inj_on_iff_eq_card[where A = "{0..n}", where f = "\<lambda>x. y - x - 1"] 
       by auto
     then have if_fin: "finite ?A \<Longrightarrow> card ?A \<ge> n + 1" 
       using subs card_mono
       by (metis (lifting) card_mono)
     then have if_inf: "infinite ?A \<Longrightarrow> card ?A = 0"
       by (meson card.infinite)
     then show "False" using if_fin if_inf cardisn ngtz by auto
   qed
   then have nfin: "\<not> finite {(x::real). x < y}"
     using finite_imp_nat_seg_image_inj_on by blast
   have "{(x::real). x < y} \<subseteq> {x. a*x^2 + b*x + c = 0}"
     using assms by auto
   then have nfin2: "\<not> finite {x. a*x^2 + b*x + c = 0}"
     using nfin finite_subset by blast 
   {
     fix x
     assume "a * x\<^sup>2 + b * x + c = 0"
     then have f1: "a * (x * x) + x * b + c = 0"
       by (simp add: Groups.mult_ac(2) power2_eq_square)
     have f2: "\<forall>r. c + (r + (c + - c)) = r + c"
       by simp
     have f3: "\<forall>r ra rb. (rb::real) * ra + ra * r = (rb + r) * ra"
       by (metis Groups.mult_ac(2) Rings.ring_distribs(2))
     have "\<forall>r. r + (c + - c) = r"
       by simp
     then have "c + x * (b + x * a) = 0"
       using f3 f2 f1 by (metis Groups.add_ac(3) Groups.mult_ac(1) Groups.mult_ac(2))
   }
   hence "{x. a*x^2 + b*x + c = 0} \<subseteq> {x. poly [:c, b, a:] x = 0}"
     by auto
   then have " \<not> finite {x. poly [:c, b, a:] x = 0}" 
     using nfin2 using finite_subset by blast 
   then have "[:c, b, a:] = 0" 
     using poly_roots_finite[where p = "[:c, b, a:]"]  by auto
   then show ?thesis
     by auto
 qed
 
 
 
 lemma have_inbetween_point_leq:
   fixes r::"real"
   assumes "(\<forall>((d::real), (e::real), (f::real))\<in>set leq. \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)"
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set leq. a * x\<^sup>2 + b * x + c \<le> 0))"
 proof -
   have "(\<forall>(d, e, f)\<in>set leq. \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<Longrightarrow> 
     (\<exists>y'>r. (\<forall>(d, e, f)\<in>set leq. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0))"
     using leq_qe_inf_helper assms by auto
   then have "(\<exists>y'>r. (\<forall>(d, e, f)\<in>set leq. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0))"
     using assms
     by blast 
   then obtain y where y_prop: "y > r \<and>  (\<forall>(d, e, f)\<in>set leq. \<forall>x\<in>{r<..y}. d * x\<^sup>2 + e * x + f \<le> 0)"
     by auto
   have "\<exists>q. q >  r \<and>q < y" using y_prop dense by auto
   then obtain q where q_prop: "q > r \<and> q < y" by auto
   then have "(\<forall>(d, e, f)\<in>set leq. d*q^2 + e*q + f \<le> 0)"
     using y_prop by auto
   then show ?thesis
     by auto
 qed
 
 
 lemma have_inbetween_point_neq:
   fixes r::"real"
   assumes "(\<forall>((d::real), (e::real), (f::real))\<in>set neq. \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set neq. a * x\<^sup>2 + b * x + c \<noteq> 0))"
 proof -
   have "(\<forall>(d, e, f)\<in>set neq. \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<Longrightarrow> 
     (\<exists>y'>r. (\<forall>(d, e, f)\<in>set neq. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
     using neq_qe_inf_helper assms by auto
   then have "(\<exists>y'>r. (\<forall>(d, e, f)\<in>set neq. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
     using assms
     by blast 
   then obtain y where y_prop: "y > r \<and>  (\<forall>(d, e, f)\<in>set neq. \<forall>x\<in>{r<..y}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
     by auto
   have "\<exists>q. q >  r \<and>q < y" using y_prop dense by auto
   then obtain q where q_prop: "q > r \<and> q < y" by auto
   then have "(\<forall>(d, e, f)\<in>set neq. d*q^2 + e*q + f \<noteq> 0)"
     using y_prop by auto
   then show ?thesis
     by auto
 qed
 
 subsection "Setting up and Helper Lemmas"
 subsubsection "The les\\_qe lemma"
 lemma les_qe_forward : 
   shows "(((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0))))) \<Longrightarrow> ((\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)))"
 proof -
   assume big_asm: "(((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0)))))"
   then have big_or: "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> 
                (\<exists>(a', b', c')\<in>set les.
                a' = 0 \<and>
                b' \<noteq> 0 \<and> (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0)) 
         \<or>
         (\<exists>(a', b', c')\<in>set les.
                a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                (\<forall>(d, e, f)\<in>set les.
                    \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                       \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) 
       \<or>
       (\<exists>(a', b', c')\<in>set les.  a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                 (\<forall>(d, e, f)\<in>set les.
                     \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                        \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                           d * x\<^sup>2 + e * x + f < 0)) " 
     by auto
   have h1_helper: "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   proof - 
     show "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))" 
     proof (induct les)
       case Nil
       then show ?case
         by auto
     next
       case (Cons q les) 
       have ind: " \<forall>a\<in>set (q # les). case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c < 0"
         using Cons.prems
         by auto
       then have "case q of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c < 0 "
         by simp      
       then obtain y2 where y2_prop: "case q of (a, ba, c) \<Rightarrow>  (\<forall>y<y2. a * y\<^sup>2 + ba * y + c < 0)"
         by auto
       have "\<forall>a\<in>set les. case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c < 0"
         using ind by simp
       then have " \<exists>y. \<forall>x<y. \<forall>a\<in>set les. case a of (a, ba, c) \<Rightarrow> a * x\<^sup>2 + ba * x + c < 0"
         using Cons.hyps by blast 
       then obtain y1 where y1_prop: "\<forall>x<y1. \<forall>a\<in>set les. case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c < 0"
         by blast
       let ?y = "min y1 y2"
       have "\<forall>x < ?y.  (\<forall>a\<in>set (q #les). case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c < 0)"
         using y1_prop y2_prop 
         by fastforce 
       then show ?case
         by blast 
     qed
   qed
   then have h1: "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<Longrightarrow>(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     by (smt (z3) infzeros less_eq_real_def not_numeral_le_zero)
       (* apply (auto)
     by (metis (lifting) infzeros zero_neq_numeral) *)
   have h2: " (\<exists>(a', b', c')\<in>set les.
                a' = 0 \<and>
                b' \<noteq> 0 \<and> (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0))
     \<Longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   proof -
     assume asm: "(\<exists>(a', b', c')\<in>set les. a' = 0 \<and> b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0))"
     then obtain a' b' c' where abc_prop: "(a', b', c') \<in>set les \<and> a' = 0 \<and> b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0)"
       by auto
     then show "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
       using have_inbetween_point_les by auto
   qed
   have h3: " (\<exists>(a', b', c')\<in>set les.
                a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                (\<forall>(d, e, f)\<in>set les.
                    \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                       \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<Longrightarrow> ((\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)))"
   proof - 
     assume asm: "\<exists>(a', b', c')\<in>set les.  a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                 \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                    \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                       d * x\<^sup>2 + e * x + f < 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set les \<and> a' \<noteq> 0 \<and> 4 * a' * c' \<le> b'\<^sup>2 \<and>
        (\<forall>(d, e, f)\<in>set les.
            \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
               \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)"
       by auto
     then show "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
       using have_inbetween_point_les by auto
   qed
   have h4: "(\<exists>(a', b', c')\<in>set les.  a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                 (\<forall>(d, e, f)\<in>set les.
                     \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                        \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                           d * x\<^sup>2 + e * x + f < 0)) \<Longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   proof - 
     assume asm: "(\<exists>(a', b', c')\<in>set les.  a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0)) "
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set les \<and> a' \<noteq> 0 \<and> 4 * a' * c' \<le> b'\<^sup>2 \<and>
      (\<forall>(d, e, f)\<in>set les.
          \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
             \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)"
       by auto
     then have "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
       using have_inbetween_point_les by auto
     then show ?thesis using asm by auto
   qed 
   show ?thesis using big_or h1 h2 h3 h4
     by blast 
 qed
 
 (*sample points, some starter proofs below in comments *)
 lemma les_qe_backward : 
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<Longrightarrow>
     ((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0))))"
 
 proof - 
   assume havex: "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   then obtain x where x_prop: "\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0" by auto
   have h: "(\<not> (\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and> \<not> (\<exists>(a', b', c')\<in>set les.
            a' = 0 \<and>
            b' \<noteq> 0 \<and>
            (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<and>
         \<not> (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                   \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<and>
         \<not> (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0))) \<Longrightarrow> False"
   proof -
     assume big: "(\<not> (\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and> \<not> (\<exists>(a', b', c')\<in>set les.
            a' = 0 \<and>
            b' \<noteq> 0 \<and>
            (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<and>
         \<not> (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                   \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<and>
         \<not> (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)))"
     have notneginf: "\<not> (\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)" using big by auto
     have notlinroot: "\<not> (\<exists>(a', b', c')\<in>set les.
            a' = 0 \<and>
            b' \<noteq> 0 \<and>
            (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0))" 
       using big by auto
     have notquadroot1: " \<not> (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                   \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0))"
       using big by auto
     have notquadroot2:" \<not> (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0))"
       using big by auto
     have nok: "\<not> (\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))"
     proof - 
       have "(\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<Longrightarrow> False"
       proof - 
         assume "(\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))"
         then obtain k a b c where k_prop: "(a, b, c) \<in> set les \<and>  a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0)"
           by auto
         have azer:  "a = 0 \<Longrightarrow> False"
         proof - 
           assume azer: "a = 0"
           then have "b = 0 \<Longrightarrow> c = 0" using k_prop by auto
           then have bnonz: "b\<noteq> 0"
             using azer x_prop k_prop 
             by auto 
           then have "k = -c/b" using k_prop azer
             by (smt (verit, best) mult_eq_0_iff nonzero_mult_div_cancel_left)
           then have " (\<exists>(a', b', c')\<in>set les.
            a' = 0 \<and> b' \<noteq> 0 \<and> (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0))"
             using k_prop azer bnonz by auto
           then show "False" using notlinroot
             by auto
         qed
         have anonz: "a \<noteq> 0 \<Longrightarrow> False"
         proof - 
           assume anonz: "a \<noteq> 0 "
           let ?r1 = "(- b - sqrt (b^2 - 4 * a * c)) / (2 * a)"
           let ?r2 = "(- b + sqrt (b^2 - 4 * a * c)) / (2 * a)"
           have discr: "4 * a * c \<le> b^2" using anonz k_prop discriminant_negative[of a b c] 
             unfolding discrim_def 
             by fastforce 
           then have "k = ?r1 \<or> k = ?r2" using k_prop discriminant_nonneg[of a b c] unfolding discrim_def
             using anonz
             by auto 
           then have "(\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                   \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) \<or>
            (\<exists>(a', b', c')\<in>set les.
            a' \<noteq> 0 \<and>
            4 * a' * c' \<le> b'\<^sup>2 \<and>
            (\<forall>(d, e, f)\<in>set les.
                \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0))"
             using discr anonz notquadroot1 notquadroot2 k_prop 
             by auto
           then show "False" using  notquadroot1 notquadroot2
             by auto
         qed
         show "False"
           using azer anonz  by auto
       qed
       then show ?thesis by auto
     qed
     have finset: "finite (set les)"
       by blast
     have h1: "(\<exists>(a, b, c)\<in>set les. a = 0 \<and> b = 0 \<and> c = 0)  \<Longrightarrow> False"
       using x_prop by fastforce
     then have h2: "\<not>(\<exists>(a, b, c)\<in>set les. a = 0 \<and> b = 0 \<and> c = 0) \<Longrightarrow> False"
     proof - 
       assume nozer: "\<not>(\<exists>(a, b, c)\<in>set les. a = 0 \<and> b = 0 \<and> c = 0)"
       then have same_set: "root_set (set les) = set (sorted_root_list_set (set les))"
         using root_set_finite finset set_sorted_list_of_set
         by (simp add: nozer root_set_finite sorted_root_list_set_def)
       have xnotin: "x \<notin> root_set (set les)"
         unfolding root_set_def using x_prop by auto
       let ?srl = "sorted_root_list_set (set les)"
       have notinlist: "\<not> List.member ?srl x"
         using xnotin same_set
         by (simp add: in_set_member)
       then have notmem: "\<forall>n < (length ?srl). x \<noteq> nth_default 0 ?srl n"
         using nth_mem same_set xnotin nth_default_def
         by metis  
       show ?thesis 
       proof (induct ?srl)
         case Nil
         then have "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)"
         proof clarsimp 
           fix a b c
           assume noroots: "[] = sorted_root_list_set (set les)"
           assume inset: "(a, b, c) \<in> set les"
           have "{} = root_set (set les)" 
             using noroots same_set 
             by auto 
           then have nozero: "\<not>(\<exists>x. a*x^2  + b*x + c = 0)"
             using inset unfolding root_set_def by auto
           have "\<forall>y<x. a * y\<^sup>2 + b * y + c < 0" 
           proof clarsimp 
             fix y
             assume "y < x"
             then have "sign_num (a*x^2 + b*x + c) = sign_num (a*y^2 + b*y + c)"
               using nozero  by (metis changes_sign_var) 
             then show "a * y\<^sup>2 + b * y + c < 0"
               unfolding sign_num_def using x_prop inset 
               by (smt split_conv) 
           qed
           then show "\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0"
             by auto
         qed
         then show ?case using notneginf by auto
       next
         case (Cons w xa) 
           (* Need to argue that x isn't greater than the largest element of ?srl *)
           (* that if srl has length \<ge> 2, x isn't in between any of the roots of ?srl*)
           (* and that x isn't less than the lowest root in ?srl *)
         then have lengthsrl: "length ?srl > 0" by auto
         have neginf: "x < nth_default 0 ?srl 0 \<Longrightarrow> False"
         proof -
           assume xlt: "x < nth_default 0 ?srl 0"
           have all: "(\<forall>(a, b, c)\<in>set les. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)"
           proof clarsimp 
             fix a b c y
             assume inset: "(a, b, c) \<in> set les"
             assume "y < x"
             have xl: "a*x^2 + b*x + c < 0" using x_prop inset by auto
             have "\<not>(\<exists>q. q < nth_default 0 ?srl 0  \<and> a*q^2 + b*q + c = 0)"
             proof - 
               have "(\<exists>q. q < nth_default 0 ?srl 0  \<and> a*q^2 + b*q + c = 0) \<Longrightarrow> False"
               proof - assume "\<exists>q. q < nth_default 0 ?srl 0  \<and> a*q^2 + b*q + c = 0"
                 then obtain q where q_prop: "q < nth_default 0 ?srl 0 \<and>a*q^2 + b*q + c = 0" by auto
                 then have " q \<in> root_set (set les)" unfolding root_set_def using inset by auto
                 then have "List.member ?srl q" using same_set
                   by (simp add: in_set_member)
                 then have "q \<ge> nth_default 0 ?srl 0"
                   using sorted_sorted_list_of_set[where A = "root_set (set les)"]
                   unfolding sorted_root_list_set_def
                   by (metis \<open>q \<in> root_set (set les)\<close> in_set_conv_nth le_less_linear lengthsrl not_less0 nth_default_nth same_set sorted_nth_mono sorted_root_list_set_def)
                 then show "False" using q_prop by auto
               qed
               then show ?thesis by auto
             qed
             then have "\<not>(\<exists>q. q < x \<and> a*q^2 + b*q + c = 0)" using xlt by auto
             then show " a * y\<^sup>2 + b * y + c < 0" 
               using xl changes_sign_var[where a = "a", where b = "b", where c = "c", where x = "y", where y = "x"]
               unfolding sign_num_def using \<open>y < x\<close> less_eq_real_def zero_neq_numeral 
               by fastforce
           qed
           have "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)"
           proof clarsimp 
             fix a b c
             assume "(a, b, c)\<in>set les"
             then show "\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0" 
               using all by blast 
           qed
           then show "False" using notneginf by auto
         qed
         have "x > nth_default 0 ?srl (length ?srl - 1) \<Longrightarrow> (\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))"
         proof - 
           assume xgt: "x > nth_default 0 ?srl (length ?srl - 1)"
           let ?lg = "nth_default 0 ?srl (length ?srl - 1)"
           have "List.member ?srl ?lg"
             by (metis diff_less in_set_member lengthsrl nth_default_def nth_mem zero_less_one)
           then have "?lg \<in> root_set (set les) "
             using same_set in_set_member[of ?lg ?srl]  by auto
           then have exabc: "\<exists>(a, b, c)\<in>set les. a*?lg^2 + b*?lg + c = 0"
             unfolding root_set_def by auto
           have "(\<forall>(d, e, f)\<in>set les. \<forall>q\<in>{?lg<..x}. d * q^2 + e * q + f < 0)"
           proof clarsimp 
             fix d e f q 
             assume inset: "(d, e, f) \<in> set les"
             assume qgt: "(nth_default 0) (sorted_root_list_set (set les)) (length (sorted_root_list_set (set les)) - Suc 0) < q"
             assume qlt: "q \<le> x"
             have nor: "\<not>(\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?lg)"
             proof - 
               have "(\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?lg) \<Longrightarrow> False "
               proof - 
                 assume "\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?lg"
                 then obtain r where r_prop: "d*r^2 + e*r + f = 0 \<and> r > ?lg" by auto
                 then have "r \<in> root_set (set les)" using inset unfolding root_set_def by auto
                 then have "List.member ?srl r"
                   using same_set in_set_member
                   by (simp add: in_set_member) 
                 then have " r \<le> ?lg" using sorted_sorted_list_of_set nth_default_def
                   by (metis One_nat_def Suc_pred \<open>r \<in> root_set (set les)\<close> in_set_conv_nth lengthsrl lessI less_Suc_eq_le same_set sorted_nth_mono sorted_root_list_set_def)
                 then show "False" using r_prop by auto
               qed
               then show ?thesis by auto
             qed
             then have xltz_helper: "\<not>(\<exists>r. r \<ge> q \<and> d * r^2 + e * r + f = 0)"
               using qgt by auto
             then have xltz: "d*x^2 + e*x + f < 0" using inset x_prop by auto
             show "d * q\<^sup>2 + e * q + f < 0"
               using qlt qgt nor changes_sign_var[of d _ e f _] xltz xltz_helper unfolding sign_num_def
               apply (auto) 
               by smt
           qed
           then have " (\<forall>(d, e, f)\<in>set les. \<exists>y'>?lg. \<forall>x\<in>{?lg<..y'}. d * x\<^sup>2 + e * x + f < 0)"
             using xgt by auto
           then have "(\<exists>(a, b, c)\<in>set les. a*?lg^2 + b*?lg + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>?lg. \<forall>x\<in>{?lg<..y'}. d * x\<^sup>2 + e * x + f < 0))"
             using exabc by auto
           then show "(\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))"
             by auto
         qed
         then have posinf: "x > nth_default 0 ?srl (length ?srl - 1) \<Longrightarrow> False" 
           using nok by auto
         have "(\<exists>n. (n+1) < (length ?srl) \<and> x > (nth_default 0 ?srl) n \<and> x < (nth_default 0 ?srl (n + 1))) \<Longrightarrow> (\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))"
         proof - 
           assume "\<exists>n. (n+1) < (length ?srl) \<and> x > nth_default 0 ?srl n \<and> x < nth_default 0 ?srl (n + 1)"
           then obtain n where n_prop: "(n+1) < (length ?srl) \<and> x > nth_default 0 ?srl n \<and> x < nth_default 0 ?srl (n + 1)" by auto
           let ?elt = "nth_default 0 ?srl n"
           let ?elt2 = "nth_default 0 ?srl (n + 1)"
           have "List.member ?srl ?elt"
             using n_prop nth_default_def
             by (metis add_lessD1 in_set_member nth_mem) 
           then have "?elt \<in> root_set (set les) "
             using same_set in_set_member[of ?elt ?srl]  by auto
           then have exabc: "\<exists>(a, b, c)\<in>set les. a*?elt^2 + b*?elt + c = 0"
             unfolding root_set_def by auto
           then obtain a b c where "(a, b, c)\<in>set les \<and> a*?elt^2 + b*?elt + c = 0"
             by auto
           have xltel2: "x < ?elt2" using n_prop by auto
           have xgtel: "x > ?elt " using n_prop by auto
           have "(\<forall>(d, e, f)\<in>set les. \<forall>q\<in>{?elt<..x}. d * q^2 + e * q + f < 0)"
           proof clarsimp 
             fix d e f q 
             assume inset: "(d, e, f) \<in> set les"
             assume qgt: "nth_default 0 (sorted_root_list_set (set les)) n < q"
             assume qlt: "q \<le> x"
 
             have nor: "\<not>(\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?elt \<and>r < ?elt2)"
             proof - 
               have "(\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?elt \<and> r < ?elt2) \<Longrightarrow> False "
               proof - 
                 assume "\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?elt  \<and> r < ?elt2"
                 then obtain r where r_prop: "d*r^2 + e*r + f = 0 \<and> r > ?elt  \<and> r < ?elt2" by auto
                 then have "r \<in> root_set (set les)" using inset unfolding root_set_def by auto
                 then have "List.member ?srl r"
                   using same_set in_set_member
                   by (simp add: in_set_member) 
                 then have "\<exists>i < (length ?srl). r = nth_default 0 ?srl i"
                   by (metis \<open>r \<in> root_set (set les)\<close> in_set_conv_nth same_set nth_default_def)
                 then obtain i where i_prop: "i < (length ?srl) \<and> r = nth_default 0 ?srl i"
                   by auto
                 have "r > ?elt" using r_prop by auto
                 then  have igt: " i > n" using i_prop sorted_sorted_list_of_set
                   by (smt add_lessD1 leI n_prop nth_default_def sorted_nth_mono sorted_root_list_set_def)
                 have "r < ?elt2" using r_prop by auto
                 then have ilt: " i < n + 1" using i_prop sorted_sorted_list_of_set
                   by (smt leI n_prop nth_default_def sorted_nth_mono sorted_root_list_set_def) 
                 then show "False"  using igt ilt
                   by auto
               qed
               then show ?thesis by auto
             qed
             then have nor: "\<not>(\<exists>r. d * r^2 + e * r + f = 0 \<and> r > ?elt \<and>r \<le> x)"
               using xltel2 xgtel by auto
             then have xltz: "d*x^2 + e*x + f < 0" using inset x_prop by auto
             show "d * q\<^sup>2 + e * q + f < 0"
               using qlt qgt nor changes_sign_var[of d _ e f _] xltz unfolding sign_num_def
               by smt 
           qed
           then have " (\<forall>(d, e, f)\<in>set les. \<exists>y'>?elt. \<forall>x\<in>{?elt<..y'}. d * x\<^sup>2 + e * x + f < 0)"
             using xgtel xltel2 by auto
           then have "(\<exists>(a, b, c)\<in>set les. a*?elt^2 + b*?elt + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>?elt. \<forall>x\<in>{?elt<..y'}. d * x\<^sup>2 + e * x + f < 0))"
             using exabc by auto
           then show "(\<exists>k. \<exists>(a, b, c)\<in>set les. a*k^2 + b*k + c = 0 \<and>
                 (\<forall>(d, e, f)\<in>set les. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))"
             by auto
         qed
         then have inbetw: "(\<exists>n. (n+1) < (length ?srl) \<and> x > nth_default 0 ?srl n \<and> x < nth_default 0 ?srl (n + 1)) \<Longrightarrow> False"
           using nok by auto
         have lenzer: "length xa = 0 \<Longrightarrow> False" 
         proof - 
           assume "length xa = 0"
           have xis: "x > w \<or> x < w"
             using notmem Cons.hyps
             by (smt list.set_intros(1) same_set xnotin) 
           have xgt: "x > w \<Longrightarrow> False"
           proof - 
             assume xgt: "x > w"
             show "False" using posinf Cons.hyps
               by (metis One_nat_def Suc_eq_plus1 \<open>length xa = 0\<close> cancel_comm_monoid_add_class.diff_cancel list.size(4) nth_default_Cons_0 xgt)
           qed
           have xlt: "x < w \<Longrightarrow> False"
           proof - 
             assume xlt: "x < w"
             show "False" using neginf Cons.hyps
               by (metis nth_default_Cons_0 xlt) 
           qed
           show "False" using xis xgt xlt by auto
         qed
         have lengt: "length xa > 0 \<Longrightarrow> False"
         proof - 
           assume "length xa > 0"
           have "x \<ge> nth_default 0 ?srl 0" using neginf
             by fastforce
           then have xgtf: "x > nth_default 0 ?srl 0" using notmem
             using Cons.hyps(2) by fastforce
           have "x \<le> nth_default 0 ?srl (length ?srl - 1)" using posinf by fastforce
           then have "(\<exists>n. (n+1) < (length ?srl) \<and> x \<ge> nth_default 0 ?srl n \<and> x \<le> nth_default 0 ?srl (n + 1))"
             using lengthsrl xgtf notmem sorted_list_prop[where l = ?srl, where x = "x"]
             by (metis add_lessD1 diff_less nth_default_nth sorted_root_list_set_def sorted_sorted_list_of_set zero_less_one)
           then obtain n where n_prop: "(n+1) < (length ?srl) \<and> x \<ge> nth_default 0 ?srl n \<and> x \<le> nth_default 0 ?srl (n + 1)" by auto
           then have "x > nth_default 0 ?srl n \<and> x < nth_default 0 ?srl (n+1)"
             using notmem
             by (metis Suc_eq_plus1 Suc_lessD less_eq_real_def)
           then have "(\<exists>n. (n+1) < (length ?srl) \<and> x > nth_default 0 ?srl n \<and> x < nth_default 0 ?srl (n + 1))"
             using n_prop
             by blast  
           then show "False" using inbetw by auto
         qed
         then show ?case using lenzer lengt by auto
       qed 
     qed
     show "False"
       using h1 h2 by auto
   qed
   then have equiv_false: "\<not>((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> 
                (\<exists>(a', b', c')\<in>set les.
                a' = 0 \<and>
                b' \<noteq> 0 \<and> (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0)) 
         \<or>
         (\<exists>(a', b', c')\<in>set les.
                a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                (\<forall>(d, e, f)\<in>set les.
                    \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                       \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) 
       \<or>
       (\<exists>(a', b', c')\<in>set les.  a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                 (\<forall>(d, e, f)\<in>set les.
                     \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                        \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                           d * x\<^sup>2 + e * x + f < 0))) \<Longrightarrow> False"
     by linarith
   have "\<not>((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0)))) \<Longrightarrow> False"
   proof - 
     assume "\<not>((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0))))"
     then have "\<not>((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> 
                (\<exists>(a', b', c')\<in>set les.
                a' = 0 \<and>
                b' \<noteq> 0 \<and> (\<forall>(d, e, f)\<in>set les. \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0)) 
         \<or>
         (\<exists>(a', b', c')\<in>set les.
                a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                (\<forall>(d, e, f)\<in>set les.
                    \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                       \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}. d * x\<^sup>2 + e * x + f < 0)) 
       \<or>
       (\<exists>(a', b', c')\<in>set les.  a' \<noteq> 0 \<and>
                4 * a' * c' \<le> b'\<^sup>2 \<and>
                 (\<forall>(d, e, f)\<in>set les.
                     \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                        \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                           d * x\<^sup>2 + e * x + f < 0)))"
       by auto
     then show ?thesis
       using equiv_false by auto
   qed
   then show ?thesis
     by blast 
 qed
 
 lemma les_qe : 
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) =
     ((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0))))"
 proof -
   have first: "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<longrightarrow>
     ((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0))))"
     using les_qe_backward by auto
   have second: "((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0)))) \<longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) "
     using les_qe_forward by auto
   have "(\<exists>x. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<longleftrightarrow>
   ((\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or>
      (\<exists>(a', b', c')\<in>set les.
          a' = 0 \<and>
          b' \<noteq> 0 \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- (c' / b'). \<forall>x\<in>{- (c' / b')<..y'}. d * x\<^sup>2 + e * x + f < 0) \<or>
          a' \<noteq> 0 \<and>
          4 * a' * c' \<le> b'\<^sup>2 \<and>
          ((\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a').
                  \<forall>x\<in>{(sqrt (b'\<^sup>2 - 4 * a' * c') - b') / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<or>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' - sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0))))"
     using first second
     by meson 
   then show ?thesis
     by blast
 qed
 
 
 subsubsection "equiv\\_lemma"
 lemma equiv_lemma: 
   assumes big_asm: "(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<or>
   (\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
           
       (\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<or>
      ((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   shows "((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))" 
 proof - 
   let ?t = " ((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   have h1: "(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<Longrightarrow> ?t"
     by auto
   have h2: "(\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<Longrightarrow> ?t" 
     by auto
   have h3: "(\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<Longrightarrow> ?t" 
     by auto
   show ?thesis
     using big_asm h1 h2 h3
     by presburger 
 qed
 
 subsubsection "The eq\\_qe lemma"
 lemma eq_qe_forwards: 
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))  \<Longrightarrow>
     ((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
 proof - 
   let ?big_or = "(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<or>
   (\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
           
       (\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<or>
      ((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   assume asm: "(\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) " 
   then obtain x where x_prop: "(\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)" by auto
   have "\<not> (\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<and>
   \<not> (\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<and>
           \<not> (\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<and>
      \<not> ((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<Longrightarrow> False" 
   proof - 
     assume big_conj: "\<not> (\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<and>
   \<not> (\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<and>
           \<not> (\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<and>
      \<not> ((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     have not_lin: "\<not>(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0))"
       using big_conj by auto
     have not_quad1: "\<not>(\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)))"
       using big_conj by auto
     have not_quad2: "\<not>(\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))"
       using big_conj by auto
     have not_zer: "\<not>((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
       using big_conj by auto
     then have not_zer1: "\<not>(\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<or>
      \<not> (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)" by auto
     have "(\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)" using asm 
       by auto 
     then have "\<not>(\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0)" using not_zer1 by auto
     then have "\<exists> (d, e, f)\<in>set eq. d \<noteq> 0 \<or> e \<noteq> 0 \<or> f \<noteq> 0 "
       by auto
     then obtain d e f where def_prop: "(d, e, f) \<in> set eq \<and> (d \<noteq> 0 \<or> e \<noteq> 0 \<or> f \<noteq> 0)" by auto
     then have eval_at_x: "d*x^2 + e*x + f = 0" using x_prop by auto
     have dnonz: "d \<noteq> 0 \<Longrightarrow> False"
     proof - 
       assume dneq: "d \<noteq> 0"
       then have discr: "-(e^2) + 4 *d *f \<le> 0" using  discriminant_negative[of d e f x] eval_at_x unfolding discrim_def
         by linarith
       let ?r1 = "(- e + - 1 * sqrt (e^2 - 4 *d *f)) / (2 * d)"
       let ?r2 = "(- e + 1 * sqrt (e^2 - 4 *d *f)) / (2 * d)"
       have xis: "x = ?r1 \<or> x = ?r2"
         using dneq discr discriminant_nonneg[of d e f x] eval_at_x unfolding discrim_def
         by auto
       have xr1: "x = ?r1 \<Longrightarrow> False"
         using not_quad2 x_prop discr def_prop dneq by auto
       have xr2: "x = ?r2 \<Longrightarrow> False"
         using not_quad1 x_prop discr def_prop dneq by auto
       show "False" using xr1 xr2 xis by auto
     qed
     then have dz: "d = 0" by auto
     have enonz: "e \<noteq> 0 \<Longrightarrow> False" 
     proof - 
       assume enonz: "e\<noteq> 0"
       then have "x = -f/e" using dz eval_at_x
         by (metis add.commute minus_add_cancel mult.commute mult_zero_class.mult_zero_left nonzero_eq_divide_eq) 
       then show "False"
         using not_lin x_prop enonz dz def_prop by auto
     qed
     then have ez: "e = 0" by auto
     have fnonz: "f \<noteq> 0 \<Longrightarrow> False" using ez dz eval_at_x by auto
     show "False"
       using def_prop dnonz enonz fnonz by auto
   qed
   then have h: "\<not>(?big_or) \<Longrightarrow> False"
     by auto
   then show ?thesis using equiv_lemma
     by presburger
 qed
 
 lemma eq_qe_backwards: "((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<Longrightarrow> 
     (\<exists>x. ((\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)))
     "
 proof - 
   assume "((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   then have bigor: "(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<or>
   (\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
           
       (\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<or>
      ((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     by auto
   have h1: "(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)) \<Longrightarrow>
     (\<exists>(x::real). (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))" 
   proof - 
     assume "(\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0))"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set eq \<and>
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)" by auto
     let ?x = "(-c' /b')::real"
     have "(\<forall>(d, e, f)\<in>set eq. d * ?x\<^sup>2 + e * ?x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * ?x^2 + e * ?x + f < 0)" using abc_prop by auto
     then  show ?thesis using abc_prop by blast 
   qed
   have h2: " (\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<Longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   proof - 
     assume "(\<exists>(a', b', c')\<in>set eq.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)))"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set eq \<and> a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))" by auto
     let ?x = "((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')::real)"
     have anonz: "a' \<noteq> 0" using abc_prop by auto
     then have "\<exists>(q::real). q = ?x" by auto
     then obtain q where q_prop: "q = ?x" by auto
     have "(\<forall>(d, e, f)\<in>set eq. d * (?x)\<^sup>2 + e * (?x) + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set les. d * (?x)\<^sup>2 + e * (?x) + f < 0)"
       using abc_prop by auto
     then have "(\<forall>(d, e, f)\<in>set eq. d * q\<^sup>2 + e * q + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set les. d * q\<^sup>2 + e * q + f < 0)" using q_prop by auto
     then show ?thesis by auto
   qed
   have h3: "(\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)) \<Longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))" 
   proof - 
     assume "(\<exists>(a', b', c')\<in>set eq. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))"
     then obtain a' b' c' where abc_prop: "a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (a', b', c')\<in>set eq \<and> (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0)" by auto
     let ?x = "(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')"
     have anonz: "a' \<noteq> 0" using abc_prop by auto
     then have "\<exists>(q::real). q = ?x" by auto
     then obtain q where q_prop: "q = ?x" by auto
     have "(\<forall>(d, e, f)\<in>set eq. d * (?x)\<^sup>2 + e * (?x) + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set les. d * (?x)\<^sup>2 + e * (?x) + f < 0)"
       using abc_prop by auto
     then have "(\<forall>(d, e, f)\<in>set eq. d * q\<^sup>2 + e * q + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set les. d * q\<^sup>2 + e * q + f < 0)" using q_prop by auto
     then show ?thesis by auto
   qed
   have h4: "((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<Longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
   proof - 
     assume asm: "((\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     then have allzer: "(\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0)" by auto
     have "(\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)" using asm by auto
     then obtain x where x_prop: " \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0" by auto
     then have "\<forall>(d, e, f)\<in>set eq. d*x^2 + e*x + f = 0"
       using allzer by auto
     then show ?thesis using x_prop by auto
   qed
   show ?thesis
     using bigor h1 h2 h3 h4
     by blast 
 qed
 
 
 lemma eq_qe : "(\<exists>x. ((\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))) =
     ((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
 proof - 
   have h1: "(\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<longrightarrow>
     ((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     using eq_qe_forwards by auto
   have h2: "((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<longrightarrow> (\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     using eq_qe_backwards by auto
   have h3: "(\<exists>x. (\<forall>(a, b, c)\<in>set eq. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0)) \<longleftrightarrow>
     ((\<exists>(a', b', c')\<in>set eq.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0))) \<or>
      (\<forall>(d, e, f)\<in>set eq. d = 0 \<and> e = 0 \<and> f = 0) \<and>
      (\<exists>x. \<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
     using h1 h2
     by smt 
   then  show ?thesis
     by (auto) 
 qed
 
 subsubsection "The qe\\_forwards lemma"
 lemma qe_forwards_helper_gen:
   fixes r:: "real"
   assumes f8: "\<not>(\<exists>((a'::real), (b'::real), (c'::real))\<in>set c. 
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          ((\<forall>(d, e, f)\<in>set a. d * r\<^sup>2 + e * r + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * r^2 + e * r + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * r^2 + e * r + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * r^2 + e * r + f \<noteq> 0)))"
   assumes alleqset: "\<forall>x. (\<forall>(d, e, f)\<in>set a. d * x^2 + e * x + f = 0)"
   assumes f5: "\<not>(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f6: "\<not> (\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   assumes f7: "\<not> (\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f10: "\<not>(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f11: "\<not>(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   assumes f12: "\<not>(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   shows "\<not>(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
 proof - 
   have "(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)) \<Longrightarrow> False"
   proof - 
     assume "(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and>
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
       by auto
     have h1: "(\<forall>(d, e, f)\<in>set a. d * r^2 + e * r + f = 0)" 
       using alleqset
       by blast
     have c_prop: "(\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" 
       using abc_prop by auto 
     have h2: "(\<forall>(d, e, f)\<in>set c. d *r^2 + e * r + f \<le> 0)" 
     proof - 
       have c1: "\<exists> (d, e, f) \<in> set c.  d * (r)\<^sup>2 + e * (r) + f > 0 \<Longrightarrow> False"
       proof - 
         assume "\<exists> (d, e, f) \<in> set c.  d * (r)\<^sup>2 + e * (r) + f > 0"
         then obtain d e f where def_prop: "(d, e, f) \<in> set c \<and> d * (r)\<^sup>2 + e * r + f > 0"
           by auto
         have "\<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0"
           using def_prop c_prop   by auto
         then obtain y' where y_prop: " y' >r \<and> (\<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" by auto
         have "\<exists>x\<in>{r<..y'}. d*x^2 + e*x + f > 0"
           using def_prop continuity_lem_gt0_expanded[of "r" y' d e f]
           using y_prop by linarith 
         then show "False" using  y_prop
           by auto  
       qed
       then show ?thesis
         by fastforce 
     qed
     have b_prop: "(\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0)" 
       using abc_prop by auto
     have h3: "(\<forall>(d, e, f)\<in>set b. d * r\<^sup>2 + e * r + f < 0)" 
     proof - 
       have c1: "\<exists> (d, e, f) \<in> set b.  d * r\<^sup>2 + e * r + f > 0 \<Longrightarrow> False"
       proof - 
         assume "\<exists> (d, e, f) \<in> set b.  d * r\<^sup>2 + e * r + f > 0"
         then obtain d e f where def_prop: "(d, e, f) \<in> set b \<and> d * r\<^sup>2 + e * r + f > 0"
           by auto
         then have "\<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0"
           using b_prop by auto
         then obtain y' where y_prop: " y' >r \<and> (\<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0)" by auto
         then have "\<exists>k. k > r \<and> k < y' \<and> d * k^2 + e * k + f < 0" using dense
           by (meson dense greaterThanAtMost_iff less_eq_real_def) 
         then obtain k where k_prop: "k > r \<and> k < y' \<and> d * k^2 + e * k + f < 0" 
           by auto
         then have "\<not>(\<exists>x>r. x < y' \<and> d * x\<^sup>2 + e * x + f = 0)"
           using y_prop by force 
         then show "False" using k_prop def_prop y_prop poly_IVT_neg[of "r" "k" "[:f, e, d:]"] poly_IVT_pos[of "-c'/b'" "k" "[:f, e, d:]"]
           by (smt quadratic_poly_eval)
       qed
       have c2: "\<exists> (d, e, f) \<in> set b.  d * r\<^sup>2 + e * r + f = 0 \<Longrightarrow> False" 
       proof - 
         assume "\<exists> (d, e, f) \<in> set b.  d * r\<^sup>2 + e * r + f = 0"
         then obtain d' e f where def_prop: "(d', e, f) \<in> set b \<and> d' * r\<^sup>2 + e * r + f = 0"
           by auto
         then have same: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (-f/e = r)" 
         proof - 
           assume asm: "(d' = 0 \<and> e \<noteq> 0)" 
           then have " e * r + f = 0" using def_prop 
             by auto
           then show "-f/e = r" using asm
             by (metis (no_types) add.commute diff_0 divide_minus_left minus_add_cancel nonzero_mult_div_cancel_left uminus_add_conv_diff) 
         qed
         let ?r = "-f/e"
         have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> ((d', e, f) \<in> set b \<and> ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
           using same def_prop abc_prop by auto
         then have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
           by auto
         then have f1: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> False" using f5 
           by auto 
         have f2: "(d' = 0 \<and> e = 0 \<and> f = 0) \<Longrightarrow> False" proof - 
           assume "(d' = 0 \<and> e = 0 \<and> f = 0)"
           then have allzer: "\<forall>x. d'*x^2 + e*x + f = 0" by auto
           have "\<exists>y'>r. \<forall>x\<in>{r<..y'}. d' * x\<^sup>2 + e * x + f < 0"
             using b_prop def_prop  by auto
           then obtain y' where y_prop: " y' >r \<and> (\<forall>x\<in>{r<..y'}. d' * x\<^sup>2 + e * x + f < 0)" by auto
           then have "\<exists>k. k > r \<and> k < y' \<and> d' * k^2 + e * k + f < 0" using dense
             by (meson dense greaterThanAtMost_iff less_eq_real_def) 
           then show "False" using allzer
             by auto
         qed
         have f3: "d' \<noteq> 0 \<Longrightarrow> False" 
         proof - 
           assume dnonz: "d' \<noteq> 0"
           have discr: " - e\<^sup>2 + 4 * d' * f \<le> 0"
             using def_prop discriminant_negative[of d' e f] unfolding discrim_def
             using def_prop by fastforce
           then have two_cases: "r = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')
           \<or> r = (- e + 1 * sqrt (e\<^sup>2 - 4 * d' * f)) / (2 * d')"
             using def_prop dnonz discriminant_nonneg[of d' e f] unfolding discrim_def
             by fastforce
           have some_props: "((d', e, f) \<in> set b \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0)"
             using dnonz def_prop discr by auto
           let ?r1 = "(- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           let ?r2 = "(- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           have cf1: "r = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "r = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set b \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f7 by auto
           qed
           have cf2: "r = (- e +  1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "r = (- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set b \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f6 by auto
           qed
           then show "False" using two_cases cf1 cf2 by auto
         qed
           (* discriminant_nonnegative *)
         have eo: "(d' \<noteq> 0) \<or> (d' = 0 \<and> e \<noteq> 0) \<or> (d' = 0 \<and> e = 0 \<and> f = 0)" 
           using def_prop by auto
         then show "False" using f1 f2 f3 by auto
       qed
       show ?thesis using c1 c2
         by fastforce
     qed
     have d_prop: "(\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)" 
       using abc_prop by auto
     have h4: "(\<forall>(d, e, f)\<in>set d. d * r\<^sup>2 + e * r + f \<noteq> 0)"
     proof - 
       have "(\<exists>(d, e, f)\<in>set d. d * r\<^sup>2 + e * r + f = 0) \<Longrightarrow> False"
       proof - 
         assume "\<exists> (d, e, f) \<in> set d.  d * r\<^sup>2 + e * r + f = 0"
         then obtain d' e f where def_prop: "(d', e, f) \<in> set d \<and> d' * r\<^sup>2 + e * r + f = 0"
           by auto
         then have same: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (-f/e = r)" 
         proof - 
           assume asm: "(d' = 0 \<and> e \<noteq> 0)" 
           then have " e * r + f = 0" using def_prop 
             by auto
           then show "-f/e = r" using asm
             by (metis (no_types) add.commute diff_0 divide_minus_left minus_add_cancel nonzero_mult_div_cancel_left uminus_add_conv_diff) 
         qed
         let ?r = "-f/e"
         have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> ((d', e, f) \<in> set d \<and> ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
           using same def_prop abc_prop by auto
         then have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'> -c'/b'. \<forall>x\<in>{ -c'/b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'> -c'/b'. \<forall>x\<in>{ -c'/b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'> -c'/b'. \<forall>x\<in>{ -c'/b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'> -c'/b'. \<forall>x\<in>{ -c'/b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
           by auto
         then have f1: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> False" using f10 
           by auto 
         have f2: "(d' = 0 \<and> e = 0 \<and> f = 0) \<Longrightarrow> False" proof - 
           assume "(d' = 0 \<and> e = 0 \<and> f = 0)"
           then have allzer: "\<forall>x. d'*x^2 + e*x + f = 0" by auto
           have "\<exists>y'> r. \<forall>x\<in>{ r<..y'}. d' * x\<^sup>2 + e * x + f \<noteq> 0"
             using d_prop def_prop 
             by auto
           then obtain y' where y_prop: " y' >r \<and> (\<forall>x\<in>{r<..y'}. d' * x\<^sup>2 + e * x + f \<noteq> 0)" by auto
           then have "\<exists>k. k > r \<and> k < y' \<and> d' * k^2 + e * k + f \<noteq> 0" using dense
             by (meson dense greaterThanAtMost_iff less_eq_real_def) 
           then show "False" using allzer
             by auto
         qed
         have f3: "d' \<noteq> 0 \<Longrightarrow> False" 
         proof - 
           assume dnonz: "d' \<noteq> 0"
           have discr: " - e\<^sup>2 + 4 * d' * f \<le> 0"
             using def_prop discriminant_negative[of d' e f] unfolding discrim_def
             by fastforce
           then have two_cases: "r = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')
           \<or> r = (- e + 1 * sqrt (e\<^sup>2 - 4 * d' * f)) / (2 * d')"
             using def_prop dnonz discriminant_nonneg[of d' e f] unfolding discrim_def
             by fastforce
           have some_props: "((d', e, f) \<in> set d \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0)"
             using dnonz def_prop discr by auto
           let ?r1 = "(- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           let ?r2 = "(- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           have cf1: "r = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "r = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set d \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f12 by auto
           qed
           have cf2: "r = (- e +  1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "r = (- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set d \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f11 by auto
           qed
           then show "False" using two_cases cf1 cf2 by auto
         qed
           (* discriminant_nonnegative *)
         have eo: "(d' \<noteq> 0) \<or> (d' = 0 \<and> e \<noteq> 0) \<or> (d' = 0 \<and> e = 0 \<and> f = 0)" 
           using def_prop by auto
         then show "False" using f1 f2 f3 by auto
       qed
       then show ?thesis by auto
     qed
     have "(\<exists>(a', b', c')\<in>set c. ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * r\<^sup>2 + e * r + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * r\<^sup>2 + e * r + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * r\<^sup>2 + e * r + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * r\<^sup>2 + e * r + f \<noteq> 0))"
       using h1 h2 h3 h4 abc_prop by auto
     then show "False" using f8 by auto
   qed
   then show ?thesis by auto
 qed
 
 
 
 lemma qe_forwards_helper_lin:
   assumes alleqset: "\<forall>x. (\<forall>(d, e, f)\<in>set a. d * x^2 + e * x + f = 0)"
   assumes f5: "\<not>(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f6: "\<not> (\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   assumes f7: "\<not> (\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f8: "\<not>(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
   assumes f10: "\<not>(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f11: "\<not>(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   assumes f12: "\<not>(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   shows "\<not>(\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
 proof - 
   have "(\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)) \<Longrightarrow> False"
   proof - 
     assume "(\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and>
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
       by auto
     then have bnonz: "b'\<noteq>0" by auto
     have h1: "(\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0)" 
       using bnonz alleqset
       by blast
     have c_prop: "(\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" 
       using abc_prop by auto 
     have h2: "(\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0)" 
     proof - 
       have c1: "\<exists> (d, e, f) \<in> set c.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f > 0 \<Longrightarrow> False"
       proof - 
         assume "\<exists> (d, e, f) \<in> set c.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f > 0"
         then obtain d e f where def_prop: "(d, e, f) \<in> set c \<and> d * (- c' / b')\<^sup>2 + e * (- c' / b') + f > 0"
           by auto
         have "\<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0"
           using def_prop c_prop   by auto
         then obtain y' where y_prop: " y' >- c' / b' \<and> (\<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" by auto
         have "\<exists>x\<in>{(-c'/b')<..y'}. d*x^2 + e*x + f > 0"
           using def_prop continuity_lem_gt0_expanded[of "(-c'/b')" y' d e f]
           using y_prop by linarith 
         then show "False" using  y_prop
           by auto  
       qed
       then show ?thesis
         by fastforce 
     qed
     have b_prop: "(\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0)" 
       using abc_prop by auto
     have h3: "(\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0)" 
     proof - 
       have c1: "\<exists> (d, e, f) \<in> set b.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f > 0 \<Longrightarrow> False"
       proof - 
         assume "\<exists> (d, e, f) \<in> set b.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f > 0"
         then obtain d e f where def_prop: "(d, e, f) \<in> set b \<and> d * (- c' / b')\<^sup>2 + e * (- c' / b') + f > 0"
           by auto
         then have "\<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0"
           using b_prop by auto
         then obtain y' where y_prop: " y' >- c' / b' \<and> (\<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0)" by auto
         then have "\<exists>k. k > -c'/b' \<and> k < y' \<and> d * k^2 + e * k + f < 0" using dense
           by (meson dense greaterThanAtMost_iff less_eq_real_def) 
         then obtain k where k_prop: "k > -c'/b' \<and> k < y' \<and> d * k^2 + e * k + f < 0" 
           by auto
         then have "\<not>(\<exists>x>(-c'/b'). x < y' \<and> d * x\<^sup>2 + e * x + f = 0)"
           using y_prop by force 
         then show "False" using k_prop def_prop y_prop poly_IVT_neg[of "-c'/b'" "k" "[:f, e, d:]"] poly_IVT_pos[of "-c'/b'" "k" "[:f, e, d:]"]
           by (smt quadratic_poly_eval)
       qed
       have c2: "\<exists> (d, e, f) \<in> set b.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0 \<Longrightarrow> False" 
       proof - 
         assume "\<exists> (d, e, f) \<in> set b.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0"
         then obtain d' e f where def_prop: "(d', e, f) \<in> set b \<and> d' * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0"
           by auto
         then have same: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (-f/e = -c'/b')" 
         proof - 
           assume asm: "(d' = 0 \<and> e \<noteq> 0)" 
           then have " e * (- c' / b') + f = 0" using def_prop 
             by auto
           then show "-f/e = -c'/b'" using asm 
             by auto
         qed
         let ?r = "-f/e"
         have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> ((d', e, f) \<in> set b \<and> ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
           using same def_prop abc_prop by auto
         then have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
           by auto
         then have f1: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> False" using f5 
           by auto 
         have f2: "(d' = 0 \<and> e = 0 \<and> f = 0) \<Longrightarrow> False" proof - 
           assume "(d' = 0 \<and> e = 0 \<and> f = 0)"
           then have allzer: "\<forall>x. d'*x^2 + e*x + f = 0" by auto
           have "\<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d' * x\<^sup>2 + e * x + f < 0"
             using b_prop def_prop  by auto
           then obtain y' where y_prop: " y' >- c' / b' \<and> (\<forall>x\<in>{- c' / b'<..y'}. d' * x\<^sup>2 + e * x + f < 0)" by auto
           then have "\<exists>k. k > -c'/b' \<and> k < y' \<and> d' * k^2 + e * k + f < 0" using dense
             by (meson dense greaterThanAtMost_iff less_eq_real_def) 
           then show "False" using allzer
             by auto
         qed
         have f3: "d' \<noteq> 0 \<Longrightarrow> False" 
         proof - 
           assume dnonz: "d' \<noteq> 0"
           have discr: " - e\<^sup>2 + 4 * d' * f \<le> 0"
             using def_prop discriminant_negative[of d' e f] unfolding discrim_def
             by fastforce
           then have two_cases: "(- c' / b') = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')
           \<or> (- c' / b') = (- e + 1 * sqrt (e\<^sup>2 - 4 * d' * f)) / (2 * d')"
             using def_prop dnonz discriminant_nonneg[of d' e f] unfolding discrim_def
             by fastforce
           have some_props: "((d', e, f) \<in> set b \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0)"
             using dnonz def_prop discr by auto
           let ?r1 = "(- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           let ?r2 = "(- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           have cf1: "(- c' / b') = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "(- c' / b') = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set b \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f7 by auto
           qed
           have cf2: "(- c' / b') = (- e +  1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "(- c' / b') = (- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set b \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f6 by auto
           qed
           then show "False" using two_cases cf1 cf2 by auto
         qed
           (* discriminant_nonnegative *)
         have eo: "(d' \<noteq> 0) \<or> (d' = 0 \<and> e \<noteq> 0) \<or> (d' = 0 \<and> e = 0 \<and> f = 0)" 
           using def_prop by auto
         then show "False" using f1 f2 f3 by auto
       qed
       show ?thesis using c1 c2
         by fastforce
     qed
     have d_prop: "(\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)" 
       using abc_prop by auto
     have h4: "(\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)"
     proof - 
       have "(\<exists>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<Longrightarrow> False"
         (* begin *)
       proof - 
         assume "\<exists> (d, e, f) \<in> set d.  d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0"
         then obtain d' e f where def_prop: "(d', e, f) \<in> set d \<and> d' * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0"
           by auto
         then have same: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (-f/e = -c'/b')" 
         proof - 
           assume asm: "(d' = 0 \<and> e \<noteq> 0)" 
           then have " e * (- c' / b') + f = 0" using def_prop 
             by auto
           then show "-f/e = -c'/b'" using asm 
             by auto
         qed
         let ?r = "-f/e"
         have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> ((d', e, f) \<in> set d \<and> ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
           using same def_prop abc_prop by auto
         then have "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
           by auto
         then have f1: "(d' = 0 \<and> e \<noteq> 0) \<Longrightarrow> False" using f10 
           by auto 
         have f2: "(d' = 0 \<and> e = 0 \<and> f = 0) \<Longrightarrow> False" proof - 
           assume "(d' = 0 \<and> e = 0 \<and> f = 0)"
           then have allzer: "\<forall>x. d'*x^2 + e*x + f = 0" by auto
           have "\<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d' * x\<^sup>2 + e * x + f \<noteq> 0"
             using d_prop def_prop  by auto
           then obtain y' where y_prop: " y' >- c' / b' \<and> (\<forall>x\<in>{- c' / b'<..y'}. d' * x\<^sup>2 + e * x + f \<noteq> 0)" by auto
           then have "\<exists>k. k > -c'/b' \<and> k < y' \<and> d' * k^2 + e * k + f \<noteq> 0" using dense
             by (meson dense greaterThanAtMost_iff less_eq_real_def) 
           then show "False" using allzer
             by auto
         qed
         have f3: "d' \<noteq> 0 \<Longrightarrow> False" 
         proof - 
           assume dnonz: "d' \<noteq> 0"
           have discr: " - e\<^sup>2 + 4 * d' * f \<le> 0"
             using def_prop discriminant_negative[of d' e f] unfolding discrim_def
             by fastforce
           then have two_cases: "(- c' / b') = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')
           \<or> (- c' / b') = (- e + 1 * sqrt (e\<^sup>2 - 4 * d' * f)) / (2 * d')"
             using def_prop dnonz discriminant_nonneg[of d' e f] unfolding discrim_def
             by fastforce
           have some_props: "((d', e, f) \<in> set d \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0)"
             using dnonz def_prop discr by auto
           let ?r1 = "(- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           let ?r2 = "(- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
           have cf1: "(- c' / b') = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "(- c' / b') = (- e + - 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set d \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r1. \<forall>x\<in>{?r1<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f12 by auto
           qed
           have cf2: "(- c' / b') = (- e +  1 * sqrt (e^2 - 4 * d' * f)) / (2 * d') \<Longrightarrow> False" 
           proof - 
             assume "(- c' / b') = (- e + 1 * sqrt (e^2 - 4 * d' * f)) / (2 * d')"
             then have "(d', e, f) \<in> set d \<and> d' \<noteq> 0 \<and> - e\<^sup>2 + 4 * d' * f \<le> 0 \<and> 
     ((\<forall>(d, e, f)\<in>set a. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
     (\<forall>(d, e, f)\<in>set b. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
     (\<forall>(d, e, f)\<in>set c. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
     (\<forall>(d, e, f)\<in>set d. \<exists>y'>?r2. \<forall>x\<in>{?r2<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
               using abc_prop some_props by auto
             then show "False" using f11 by auto
           qed
           then show "False" using two_cases cf1 cf2 by auto
         qed
           (* discriminant_nonnegative *)
         have eo: "(d' \<noteq> 0) \<or> (d' = 0 \<and> e \<noteq> 0) \<or> (d' = 0 \<and> e = 0 \<and> f = 0)" 
           using def_prop by auto
         then show "False" using f1 f2 f3 by auto
       qed
       then show ?thesis by auto
     qed
     have "(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
       using h1 h2 h3 h4 bnonz abc_prop by auto
     then show "False" using f8 by auto
   qed
   then show ?thesis by auto
 qed
 
 
 
 lemma qe_forwards_helper:
   assumes alleqset: "\<forall>x. (\<forall>(d, e, f)\<in>set a. d * x^2 + e * x + f = 0)"
   assumes f1: "\<not>((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0))"
   assumes f5: "\<not>(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f6: "\<not> (\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   assumes f7: "\<not> (\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f8: "\<not>(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
   assumes f13: "\<not>(\<exists>(a', b', c')\<in>set c.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   assumes f9: "\<not>(\<exists>(a', b', c')\<in>set c.  a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))"
   assumes f10: "\<not>(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   assumes f11: "\<not>(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   assumes f12: "\<not>(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   shows "\<not>(\<exists>x. (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))" 
 proof - 
   have nor: "\<forall>r. \<not>(\<exists>(a', b', c')\<in>set c. 
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          ((\<forall>(d, e, f)\<in>set a. d * r\<^sup>2 + e * r + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * r^2 + e * r + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * r^2 + e * r + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * r^2 + e * r + f \<noteq> 0)))" 
   proof clarsimp
     fix r t u v
     assume inset: "(t, u, v) \<in> set c"
     assume eo: "t = 0 \<longrightarrow> u \<noteq> 0 "
     assume zero_eq: "t*r^2 + u*r + v = 0"
     assume ah: "\<forall>x\<in>set a. case x of (d, e, f) \<Rightarrow> d * r\<^sup>2 + e * r + f = 0"
     assume bh: "\<forall>x\<in>set b. case x of (d, e, f) \<Rightarrow> d * r\<^sup>2 + e * r + f < 0" 
     assume ch: "\<forall>x\<in>set c. case x of (d, e, f) \<Rightarrow> d * r\<^sup>2 + e * r + f \<le> 0"
     assume dh: "\<forall>x\<in>set d. case x of (d, e, f) \<Rightarrow> d * r\<^sup>2 + e * r + f \<noteq> 0"
     have two_cases: "t \<noteq> 0 \<or> (t = 0 \<and> u \<noteq> 0)" using eo by auto
     have c1: "t \<noteq> 0 \<Longrightarrow> False" 
     proof - 
       assume tnonz:  "t \<noteq> 0"
       then have discr_prop: "- u\<^sup>2 + 4 * t * v \<le> 0 "
         using discriminant_negative[of t u v] zero_eq unfolding discrim_def
         by force 
       then have ris: "r =  ((-u + - 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<or>
        r = ((-u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) "
         using tnonz discriminant_nonneg[of t u v] zero_eq unfolding discrim_def by auto 
       let ?r1 = "((-u + - 1 * sqrt (u^2 - 4 * t * v)) / (2 * t))"
       let ?r2 = "((-u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t))" 
       have ris1: "r = ?r1 \<Longrightarrow> False"
       proof - 
         assume "r = ?r1"
         then have "(\<exists>(a', b', c')\<in>set c.  a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))" 
           using inset ah bh ch dh discr_prop tnonz by auto
         then show ?thesis 
           using f9 by auto
       qed
       have ris2: "r = ?r2 \<Longrightarrow> False" 
       proof - 
         assume "r = ?r2"
         then have "(\<exists>(a', b', c')\<in>set c.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))" 
           using inset ah bh ch dh discr_prop tnonz by auto
         then show ?thesis 
           using f13 by auto
       qed
       show "False" using ris ris1 ris2 by auto 
     qed
     have c2: "(t = 0 \<and> u \<noteq> 0) \<Longrightarrow> False" 
     proof - 
       assume asm: "t = 0 \<and> u \<noteq> 0"
       then have "r = -v/u" using zero_eq add.right_neutral  nonzero_mult_div_cancel_left     
         by (metis add.commute divide_divide_eq_right divide_eq_0_iff neg_eq_iff_add_eq_0)
       then have "(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
         using asm inset ah bh ch dh by auto
       then show "False" using f8
         by auto
     qed
     then show "False" using two_cases c1 c2 by auto
   qed
   have keyh: "\<And>r. \<not>(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   proof - 
     fix r
     have h8: "\<not>(\<exists>(a', b', c')\<in>set c. 
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          ((\<forall>(d, e, f)\<in>set a. d * r\<^sup>2 + e * r + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * r^2 + e * r + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * r^2 + e * r + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * r^2 + e * r + f \<noteq> 0)))" 
       using nor by auto
     show "\<not>(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*r^2 + b'*r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>r. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
       using qe_forwards_helper_gen[of c r a b d]
         alleqset  f5 f6 f7 h8 f10 f11 f12 
       by auto
   qed
   have f8a: "\<not>(\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
     using qe_forwards_helper_lin[of a b c d] alleqset f5 f6 f7 f8 f10 f11 f12
     by blast 
   have f13a: "\<not> (\<exists>(a', b', c')\<in>set c. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   proof - 
     have "(\<exists>(a', b', c')\<in>set c. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) \<Longrightarrow> False" 
     proof - 
       assume "(\<exists>(a', b', c')\<in>set c. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
       then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and> a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))" by auto
       let ?r = "(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')"
       have somek: "\<exists>k. k = ?r" by auto
       then obtain k where k_prop: "k = ?r" by auto
       have "(a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> (a'*?r^2 + b'*?r + c' = 0)" 
         using abc_prop discriminant_nonneg[of a' b' c'] 
         unfolding discrim_def apply (auto)
         by (metis (mono_tags, lifting) times_divide_eq_right) 
       then have "(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*?r^2 + b'*?r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
         using abc_prop by auto
       then have "(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*k^2 + b'*k + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
         using k_prop by auto
       then have "\<exists>k. (\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*k^2 + b'*k + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
         by auto 
       then show "False" using keyh by auto
     qed
     then
     show ?thesis
       by auto
   qed
   have f9a: "\<not> (\<exists>(a', b', c')\<in>set c. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))" 
 
   proof - 
     have "(\<exists>(a', b', c')\<in>set c. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)) \<Longrightarrow> False" 
     proof - 
       assume "(\<exists>(a', b', c')\<in>set c. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
       then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and> a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)" by auto
       let ?r = "(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')"
       have somek: "\<exists>k. k = ?r" by auto
       then obtain k where k_prop: "k = ?r" by auto
       have "(a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> (a'*?r^2 + b'*?r + c' = 0)" 
         using abc_prop discriminant_nonneg[of a' b' c'] 
         unfolding discrim_def apply (auto)
         by (metis (mono_tags, lifting) times_divide_eq_right) 
       then have "(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*?r^2 + b'*?r + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>?r. \<forall>x\<in>{?r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
         using abc_prop by auto
       then have "(\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*k^2 + b'*k + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
         using k_prop by auto
       then have "\<exists>k. (\<exists>(a', b', c')\<in>set c.
          ((a'\<noteq> 0 \<or> b'\<noteq> 0) \<and> a'*k^2 + b'*k + c' = 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
         by auto 
       then show "False" using keyh by auto
     qed
     then
     show ?thesis
       by auto
   qed
     (* We need to show that the point is in one of these ranges *)
   have "(\<exists>x. (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)) \<Longrightarrow> False"
   proof - 
     assume "(\<exists>x. (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
     then obtain x where x_prop: "(\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" by auto
     (* Need this sorted_nonzero_root_list_set in case some of the tuples from set c are (0, 0, 0) *)
     let ?srl = "sorted_nonzero_root_list_set (((set b) \<union> (set c))\<union> (set d))"
     have alleqsetvar: "\<forall>(t, u, v) \<in> set a. t = 0 \<and> u = 0 \<and> v = 0"
     proof clarsimp
       fix t u v
       assume "(t, u, v) \<in> set a"
       then have "\<forall>x. t*x^2 + u*x + v = 0" 
         using alleqset by auto 
       then have "\<forall>x\<in>{0<..1}. t * x\<^sup>2 + u * x + v = 0" 
         by auto
       then show "t = 0 \<and> u = 0 \<and> v = 0" 
         using continuity_lem_eq0[of 0 1 t u v] 
         by auto  
     qed
       (* Should violate f1 *)
     have lenzero: "length ?srl = 0 \<Longrightarrow> False"
     proof - 
       assume lenzero: "length ?srl = 0"
       have ina: "(\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0)"
         using alleqsetvar by auto 
       have inb: "(\<forall>(a, b, c)\<in>set b. \<forall>y. a * y\<^sup>2 + b * y + c < 0)"
       proof clarsimp 
         fix t u v y
         assume insetb: "(t, u, v) \<in> set b"
         then have "t * x\<^sup>2 + u * x + v < 0" using x_prop by auto
         then have tuv_prop: "t \<noteq> 0 \<or> u \<noteq> 0 \<or> v \<noteq> 0"
           by auto 
         then have tuzer: "(t = 0 \<and> u = 0) \<Longrightarrow> \<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)"
           by simp
         then have tunonz: "(t \<noteq> 0 \<or> u \<noteq> 0) \<Longrightarrow> \<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)"
         proof - 
           assume tuv_asm: "t \<noteq> 0 \<or> u \<noteq> 0"
           have "\<exists>q. t * q\<^sup>2 + u * q + v = 0 \<Longrightarrow> False"
           proof - 
             assume "\<exists> q. t * q\<^sup>2 + u * q + v = 0"
             then obtain q where "t * q\<^sup>2 + u * q + v = 0" by auto
             then have qin: "q \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
               using insetb tuv_asm tuv_prop by auto
             have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
               unfolding sorted_nonzero_root_list_set_def
               using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                 nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
               by auto
             then have "q \<in> set ?srl" using qin unfolding nonzero_root_set_def
               by auto 
             then have "List.member ?srl q"     
               using in_set_member[of q ?srl]
               by auto
             then show "False"
               using lenzero
               by (simp add: member_rec(2)) 
           qed
           then show ?thesis by auto
         qed
         have nozer: "\<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)" 
           using  tuzer tunonz
           by blast 
         have samesn: "sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
         proof - 
           have "x < y \<Longrightarrow> sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
             using changes_sign_var[of t x u v y] nozer by auto
           have "y < x \<Longrightarrow> sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
             using changes_sign_var[of t y u v x] nozer
           proof -
             assume "y < x"
             then show ?thesis
               using \<open>\<nexists>q. t * q\<^sup>2 + u * q + v = 0\<close> \<open>sign_num (t * y\<^sup>2 + u * y + v) \<noteq> sign_num (t * x\<^sup>2 + u * x + v) \<and> y < x \<Longrightarrow> \<exists>q. t * q\<^sup>2 + u * q + v = 0 \<and> y \<le> q \<and> q \<le> x\<close> by presburger
           qed
           show ?thesis
             using changes_sign_var using \<open>x < y \<Longrightarrow> sign_num (t * x\<^sup>2 + u * x + v) = sign_num (t * y\<^sup>2 + u * y + v)\<close> \<open>y < x \<Longrightarrow> sign_num (t * x\<^sup>2 + u * x + v) = sign_num (t * y\<^sup>2 + u * y + v)\<close> 
             by fastforce 
         qed
           (* changes_sign_var *)
         have "sign_num (t*x^2 + u*x + v) = -1" using insetb unfolding sign_num_def using x_prop 
           by auto 
         then have "sign_num (t*y^2 + u*y + v) = -1" using samesn by auto
         then show "t * y\<^sup>2 + u * y + v < 0" unfolding sign_num_def
           by smt
       qed
       have inc: "(\<forall>(a, b, c)\<in>set c. \<forall>y. a * y\<^sup>2 + b * y + c \<le> 0)"
       proof clarsimp 
         fix t u v y
         assume insetc: "(t, u, v) \<in> set c"
         then have "t * x\<^sup>2 + u * x + v \<le> 0" using x_prop by auto
         then have tuzer: "t = 0 \<and> u = 0 \<Longrightarrow> t*y^2 + u*y + v \<le> 0 " 
         proof - 
           assume tandu: "t = 0 \<and> u = 0"
           then have "v \<le> 0" using insetc x_prop 
             by auto
           then show "t*y^2 + u*y + v \<le> 0" using tandu 
             by auto
         qed
         have tunonz: "t \<noteq> 0 \<or> u \<noteq> 0 \<Longrightarrow> t*y^2 + u*y + v \<le> 0"
         proof - 
           assume tuv_asm: "t \<noteq> 0 \<or> u \<noteq> 0"
           have insetcvar: "t*x^2 + u*x + v < 0" 
           proof - 
             have "t*x^2 + u*x + v = 0 \<Longrightarrow> False" 
             proof -
               assume zer: "t*x^2 + u*x + v = 0"
               then have xin: "x \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
                 using insetc tuv_asm by auto
               have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
                 unfolding sorted_nonzero_root_list_set_def
                 using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                   nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
                 by auto
               then have "x \<in> set ?srl" using xin unfolding nonzero_root_set_def
                 by auto 
               then have "List.member ?srl x"     
                 using in_set_member[of x ?srl]
                 by auto
               then show "False" using lenzero
                 by (simp add: member_rec(2)) 
             qed
             then show ?thesis
               using \<open>t * x\<^sup>2 + u * x + v \<le> 0\<close> by fastforce 
           qed
           then have tunonz: "\<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)"
           proof - 
             have "\<exists>q. t * q\<^sup>2 + u * q + v = 0 \<Longrightarrow> False"
             proof - 
               assume "\<exists> q. t * q\<^sup>2 + u * q + v = 0"
               then obtain q where "t * q\<^sup>2 + u * q + v = 0" by auto
               then have qin: "q \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
                 using insetc tuv_asm by auto
               have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
                 unfolding sorted_nonzero_root_list_set_def
                 using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                   nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
                 by auto
               then have "q \<in> set ?srl" using qin unfolding nonzero_root_set_def
                 by auto 
               then have "List.member ?srl q"     
                 using in_set_member[of q ?srl]
                 by auto
               then show "False"
                 using lenzero
                 by (simp add: member_rec(2)) 
             qed
             then show ?thesis by auto
           qed
           have nozer: "\<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)" 
             using  tuzer tunonz
             by blast 
           have samesn: "sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
           proof - 
             have "x < y \<Longrightarrow> sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
               using changes_sign_var[of t x u v y] nozer by auto
             have "y < x \<Longrightarrow> sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
               using changes_sign_var[of t y u v x] nozer
             proof -
               assume "y < x"
               then show ?thesis
                 using \<open>\<nexists>q. t * q\<^sup>2 + u * q + v = 0\<close> \<open>sign_num (t * y\<^sup>2 + u * y + v) \<noteq> sign_num (t * x\<^sup>2 + u * x + v) \<and> y < x \<Longrightarrow> \<exists>q. t * q\<^sup>2 + u * q + v = 0 \<and> y \<le> q \<and> q \<le> x\<close> by presburger
             qed
             show ?thesis
               using changes_sign_var using \<open>x < y \<Longrightarrow> sign_num (t * x\<^sup>2 + u * x + v) = sign_num (t * y\<^sup>2 + u * y + v)\<close> \<open>y < x \<Longrightarrow> sign_num (t * x\<^sup>2 + u * x + v) = sign_num (t * y\<^sup>2 + u * y + v)\<close> 
               by fastforce 
           qed
             (* changes_sign_var *)
           have "sign_num (t*x^2 + u*x + v) = -1" using insetcvar unfolding sign_num_def using x_prop 
             by auto 
           then have "sign_num (t*y^2 + u*y + v) = -1" using samesn by auto
           then show "t * y\<^sup>2 + u * y + v \<le> 0" unfolding sign_num_def
             by smt
         qed
         then show "t * y\<^sup>2 + u * y + v \<le> 0" 
           using tuzer tunonz
           by blast 
       qed
       have ind: "(\<forall>(a, b, c)\<in>set d. \<forall>y. a * y\<^sup>2 + b * y + c \<noteq> 0)"
       proof clarsimp 
         fix t u v y
         assume insetd: "(t, u, v) \<in> set d"
         assume falseasm: "t * y\<^sup>2 + u * y + v = 0"
         then have snz: "sign_num (t*y^2 + u*y + v) = 0"
           unfolding sign_num_def by auto
         have "t * x\<^sup>2 + u * x + v \<noteq> 0" using insetd x_prop by auto
         then have tuv_prop: "t \<noteq> 0 \<or> u \<noteq> 0 \<or> v \<noteq> 0"
           by auto 
         then have tuzer: "(t = 0 \<and> u = 0) \<Longrightarrow> \<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)"
           by simp
         then have tunonz: "(t \<noteq> 0 \<or> u \<noteq> 0) \<Longrightarrow> \<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)"
         proof - 
           assume tuv_asm: "t \<noteq> 0 \<or> u \<noteq> 0"
           have "\<exists>q. t * q\<^sup>2 + u * q + v = 0 \<Longrightarrow> False"
           proof - 
             assume "\<exists> q. t * q\<^sup>2 + u * q + v = 0"
             then obtain q where "t * q\<^sup>2 + u * q + v = 0" by auto
             then have qin: "q \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
               using insetd tuv_asm tuv_prop by auto
             have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
               unfolding sorted_nonzero_root_list_set_def
               using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                 nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
               by auto
             then have "q \<in> set ?srl" using qin unfolding nonzero_root_set_def
               by auto 
             then have "List.member ?srl q"     
               using in_set_member[of q ?srl]
               by auto
             then show "False"
               using lenzero
               by (simp add: member_rec(2)) 
           qed
           then show ?thesis by auto
         qed
         have nozer: "\<not>(\<exists>q. t * q\<^sup>2 + u * q + v = 0)" 
           using  tuzer tunonz
           by blast 
         have samesn: "sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
         proof - 
           have "x < y \<Longrightarrow> sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
             using changes_sign_var[of t x u v y] nozer by auto
           have "y < x \<Longrightarrow> sign_num (t*x^2 + u*x + v) = sign_num (t*y^2 + u*y + v)"
             using changes_sign_var[of t y u v x] nozer
           proof -
             assume "y < x"
             then show ?thesis
               using \<open>\<nexists>q. t * q\<^sup>2 + u * q + v = 0\<close> \<open>sign_num (t * y\<^sup>2 + u * y + v) \<noteq> sign_num (t * x\<^sup>2 + u * x + v) \<and> y < x \<Longrightarrow> \<exists>q. t * q\<^sup>2 + u * q + v = 0 \<and> y \<le> q \<and> q \<le> x\<close> by presburger
           qed
           show ?thesis
             using changes_sign_var using \<open>x < y \<Longrightarrow> sign_num (t * x\<^sup>2 + u * x + v) = sign_num (t * y\<^sup>2 + u * y + v)\<close> \<open>y < x \<Longrightarrow> sign_num (t * x\<^sup>2 + u * x + v) = sign_num (t * y\<^sup>2 + u * y + v)\<close> 
             by fastforce 
         qed
           (* changes_sign_var *)
         have "sign_num (t*x^2 + u*x + v) = -1 \<or> sign_num (t*x^2 + u*x + v) = 1 " 
           using insetd unfolding sign_num_def using x_prop 
           by auto 
         then have "sign_num (t*y^2 + u*y + v) = -1 \<or> sign_num (t*y^2 + u*y + v) = 1" using samesn by auto
         then show "False"  using snz by auto 
       qed
         (* Show all the polynomials never change sign *)
       have "((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<forall>y. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<forall>y. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<forall>y. a * y\<^sup>2 + b * y + c \<noteq> 0))"
         using ina inb inc ind by auto
       then  show "False" 
         using f1
         by auto 
     qed
     have cases_mem: "(List.member ?srl x) \<Longrightarrow> False"
     proof - 
       assume "(List.member ?srl x)"
       then have "x \<in> {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
         using set_sorted_list_of_set nonzero_root_set_finite in_set_member
         by (metis List.finite_set finite_Un nonzero_root_set_def sorted_nonzero_root_list_set_def)
       then have "\<exists> (a, b, c) \<in> (((set b) \<union> (set c))\<union> (set d)) . (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a*x^2 + b*x + c = 0"
         by blast
       then obtain t u v where def_prop: "(t, u, v) \<in> (((set b) \<union> (set c))\<union> (set d)) \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> t*x^2 + u*x + v = 0"
         by auto
       have notinb: "(t, u, v) \<notin> (set b)"
       proof - 
         have "(t, u, v) \<in> (set b ) \<Longrightarrow> False"
         proof - 
           assume "(t, u, v) \<in> (set b)"
           then have "t*x^2 + u*x + v < 0" using x_prop
             by blast
           then show "False" using def_prop
             by simp 
         qed
         then  show ?thesis by auto
       qed
       have notind: "(t, u, v) \<notin> (set d)"
       proof - 
         have "(t, u, v) \<in> (set d) \<Longrightarrow> False"
         proof - 
           assume "(t, u, v) \<in> (set d)"
           then have "t*x^2 + u*x + v \<noteq> 0" using x_prop 
             by blast
           then show "False" using def_prop 
             by simp
         qed
         then show ?thesis by auto
       qed
       then have inset: "(t, u, v) \<in> (set c)"
         using def_prop notinb notind
         by blast 
       have case1: "t \<noteq> 0 \<Longrightarrow> False"
       proof - 
         assume tnonz: "t \<noteq> 0" 
         then have r1or2:"x = (- u + - 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t) \<or>
             x = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t) "
           using def_prop discriminant_negative[of t u v] discriminant_nonneg[of t u v]
           apply (auto) 
           using notinb apply (force)
            apply (simp add: discrim_def discriminant_iff)
           using notind by force 
         have discrh: "-1*u^2 + 4 * t * v \<le> 0" 
           using tnonz discriminant_negative[of t u v] unfolding discrim_def
           using def_prop by force 
         have r1: "x = (- u + - 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t) \<Longrightarrow> False"
         proof - 
           assume xis: "x = (- u + - 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)"
           have " t \<noteq> 0 \<and>
          - 1*u^2 + 4 * t * v \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
                d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * x\<^sup>2 + e * x + f \<noteq> 0)"
             using tnonz alleqset discrh x_prop
             by auto
           then have "(\<exists>(a', b', c')\<in>set c.  a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))" 
             using xis inset 
             by auto
           then show "False"
             using f9 by auto
         qed
         have r2: "x = (- u + 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t) \<Longrightarrow> False" 
         proof - 
           assume xis: "x = (- u + 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)"
           have " t \<noteq> 0 \<and>
          - 1*u^2 + 4 * t * v \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
                d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * x\<^sup>2 + e * x + f \<noteq> 0)"
             using tnonz alleqset discrh x_prop
             by auto
           then have "(\<exists>(a', b', c')\<in>set c.  a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))" 
             using xis inset 
             by auto
           then show "False"
             using f13 by auto
         qed
         then show "False"
           using r1or2 r1 r2 by auto
       qed
       have case2: "(t = 0 \<and> u \<noteq> 0) \<Longrightarrow> False" 
       proof -
         assume asm: "t = 0 \<and> u \<noteq> 0"
         then have xis: "x = - v / u" using def_prop notinb add.commute diff_0 divide_non_zero minus_add_cancel uminus_add_conv_diff
           by (metis mult_zero_left)
         have "((t = 0 \<and> u \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * x^2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * x^2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * x^2 + e * x + f \<noteq> 0))"
           using asm x_prop alleqset by auto
         then have "(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
           using xis inset
           by auto
         then show "False"
           using f8 by auto
       qed
       show "False"
         using def_prop case1 case2 by auto 
     qed
     have lengt0: "length ?srl \<ge> 1 \<Longrightarrow> False" 
     proof- 
       assume asm: "length ?srl \<ge> 1"
         (* should violate f1 *)
       have cases_lt: "x < ?srl ! 0 \<Longrightarrow> False" 
       proof - 
         assume xlt: "x < ?srl ! 0"
         have samesign: "\<forall> (a, b, c) \<in> (set b \<union> set c \<union> set d).
               (\<forall>y < x. sign_num (a * y\<^sup>2 + b * y + c) =  sign_num (a*x^2 + b*x + c))"
         proof  clarsimp  
           fix t u v y
           assume insetunion: "(t, u, v) \<in> set b \<or> (t, u, v)  \<in> set c \<or> (t, u, v) \<in> set d"
           assume ylt: "y < x" 
           have tuzer: "t = 0 \<and> u = 0 \<Longrightarrow> sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             unfolding sign_num_def 
             by auto
           have tunonzer: "t \<noteq> 0 \<or> u \<noteq> 0  \<Longrightarrow> sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
           proof - 
             assume tuv_asm: "t\<noteq> 0 \<or> u \<noteq> 0"
             have "\<not>(\<exists>q. q < ?srl ! 0 \<and> t * q\<^sup>2 + u * q + v = 0)"
             proof clarsimp 
               fix q
               assume qlt: "q < sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! 0"
               assume "t * q\<^sup>2 + u * q + v = 0"
               then have qin: "q \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
                 using insetunion tuv_asm by auto
               have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
                 unfolding sorted_nonzero_root_list_set_def
                 using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                   nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
                 by auto
               then have "q \<in> set ?srl" using qin unfolding nonzero_root_set_def
                 by auto 
               then have lm: "List.member ?srl q"     
                 using in_set_member[of q ?srl]
                 by auto
               then have " List.member
                  (sorted_list_of_set (nonzero_root_set (set b \<union> set c \<union> set d)))
                  q \<Longrightarrow>
                 q < sorted_list_of_set (nonzero_root_set (set b \<union> set c \<union> set d)) !
                     0 \<Longrightarrow>
                 (\<And>x xs. (x \<in> set xs) = (\<exists>i<length xs. xs ! i = x)) \<Longrightarrow>
                 (\<And>x xs. (x \<in> set xs) = List.member xs x) \<Longrightarrow>
                 (\<And>y x. \<not> y \<le> x \<Longrightarrow> x < y) \<Longrightarrow>
                 (\<And>xs. sorted xs =
                        (\<forall>i j. i \<le> j \<longrightarrow> j < length xs \<longrightarrow> xs ! i \<le> xs ! j)) \<Longrightarrow>
                 (\<And>p. sorted_nonzero_root_list_set p \<equiv>
                       sorted_list_of_set (nonzero_root_set p)) \<Longrightarrow>
                 False"
               proof -
                 assume a1: "List.member (sorted_list_of_set (nonzero_root_set (set b \<union> set c \<union> set d))) q"
                 assume a2: "q < sorted_list_of_set (nonzero_root_set (set b \<union> set c \<union> set d)) ! 0"
                 have f3: "List.member (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)}) q"
                   using a1 by (metis nonzero_root_set_def)
                 have f4: "q < sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)} ! 0"
                   using a2 by (metis nonzero_root_set_def)
                 have f5: "q \<in> set (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)})"
                   using f3 by (meson in_set_member)
                 have "\<forall>rs r. \<exists>n. ((r::real) \<notin> set rs \<or> n < length rs) \<and> (r \<notin> set rs \<or> rs ! n = r)"
                   by (metis in_set_conv_nth)
                 then obtain nn :: "real list \<Rightarrow> real \<Rightarrow> nat" where
                   f6: "\<And>r rs. (r \<notin> set rs \<or> nn rs r < length rs) \<and> (r \<notin> set rs \<or> rs ! nn rs r = r)"
                   by moura
                 then have "sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)} ! nn (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)}) q = q"
                   using f5 by blast
                 then have "\<And>n. \<not> sorted (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)}) \<or> \<not> n \<le> nn (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)}) q \<or> \<not> nn (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)}) q < length (sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)}) \<or> sorted_list_of_set {r. \<exists>p. p \<in> set b \<union> set c \<union> set d \<and> (case p of (ra, rb, rc) \<Rightarrow> (ra \<noteq> 0 \<or> rb \<noteq> 0) \<and> ra * r\<^sup>2 + rb * r + rc = 0)} ! n \<le> q"
-                  using not_less not_less0 sorted_iff_nth_mono
-                  by (metis (no_types, lifting)) 
+                  using not_less0 sorted_iff_nth_mono by (metis (lifting)) 
                 then show ?thesis
                   using f6 f5 f4 by (meson le0 not_less sorted_sorted_list_of_set)
               qed 
               then show "False" using lm qlt in_set_conv_nth in_set_member not_le_imp_less not_less0 sorted_iff_nth_mono sorted_nonzero_root_list_set_def sorted_sorted_list_of_set
                 by auto
             qed   
             then have "\<not>(\<exists>q. q \<le> x \<and> t * q\<^sup>2 + u * q + v = 0)"
               using xlt
               by auto 
             then show " sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               using ylt changes_sign_var[of t y u v x]
               by blast
           qed
           then show " sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             using tuzer 
             by blast
         qed
         have bseth: "(\<forall>(a, b, c)\<in>set b. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)" 
         proof clarsimp 
           fix t u v y
           assume insetb: "(t, u, v) \<in> set b"
           assume yltx: "y < x" 
           have "(t, u, v) \<in> (set b \<union> set c \<union> set d)" using insetb 
             by auto
           then have samesn: "sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             using samesign insetb yltx
             by blast 
           have "sign_num (t*x^2 + u*x + v) = -1" 
             using x_prop insetb unfolding sign_num_def
             by auto
           then show  "t * y\<^sup>2 + u * y + v < 0"
             using samesn unfolding sign_num_def 
             by (metis add.right_inverse add.right_neutral linorder_neqE_linordered_idom one_add_one zero_neq_numeral) 
         qed
         have bset: " (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)"
         proof clarsimp 
           fix t u v
           assume inset: "(t, u, v) \<in> set b"
           then have " \<forall>y<x. t * y\<^sup>2 + u * y + v < 0 " using bseth by auto
           then show "\<exists>x. \<forall>y<x. t * y\<^sup>2 + u * y + v < 0"
             by auto
         qed
         have cseth: "(\<forall>(a, b, c)\<in>set c. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0)" 
         proof clarsimp 
           fix t u v y
           assume insetc: "(t, u, v) \<in> set c"
           assume yltx: "y < x" 
           have "(t, u, v) \<in> (set b \<union> set c \<union> set d)" using insetc
             by auto
           then have samesn: "sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             using samesign insetc yltx
             by blast 
           have "sign_num (t*x^2 + u*x + v) = -1 \<or> sign_num (t*x^2 + u*x + v) = 0" 
             using x_prop insetc unfolding sign_num_def
             by auto
           then show  "t * y\<^sup>2 + u * y + v \<le> 0"
             using samesn unfolding sign_num_def
             using zero_neq_one by fastforce
         qed
         have cset: " (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0)"
         proof clarsimp 
           fix t u v
           assume inset: "(t, u, v) \<in> set c"
           then have " \<forall>y<x. t * y\<^sup>2 + u * y + v \<le> 0 " using cseth by auto
           then show "\<exists>x. \<forall>y<x. t * y\<^sup>2 + u * y + v \<le>0"
             by auto
         qed
         have dseth: "(\<forall>(a, b, c)\<in>set d. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0)" 
         proof clarsimp 
           fix t u v y
           assume insetd: "(t, u, v) \<in> set d"
           assume yltx: "y < x" 
           assume contrad: "t * y\<^sup>2 + u * y + v = 0"
           have "(t, u, v) \<in> (set b \<union> set c \<union> set d)" using insetd
             by auto
           then have samesn: "sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             using samesign insetd yltx
             by blast 
           have "sign_num (t*x^2 + u*x + v) = -1 \<or> sign_num (t*x^2 + u*x + v) = 1" 
             using x_prop insetd unfolding sign_num_def
             by auto
           then have  "t * y\<^sup>2 + u * y + v \<noteq> 0"
             using samesn unfolding sign_num_def 
             by auto
           then show "False" using contrad by auto
         qed
         have dset: " (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0)"
         proof clarsimp 
           fix t u v
           assume inset: "(t, u, v) \<in> set d"
           then have " \<forall>y<x. t * y\<^sup>2 + u * y + v \<noteq> 0 " using dseth by auto
           then show "\<exists>x. \<forall>y<x. t * y\<^sup>2 + u * y + v \<noteq> 0"
             by auto
         qed
         have "(\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0)" 
           using alleqsetvar by auto 
         then have "((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0))" 
           using  bset cset dset by auto
         then show "False" using f1 by auto
       qed
         (* should violate one of the infinitesmials *)
       have cases_gt: " x > ?srl ! (length ?srl - 1) \<Longrightarrow> False" 
       proof - 
         assume xgt: "x > ?srl ! (length ?srl - 1)"
         let ?bgrt = "?srl ! (length ?srl - 1)"
         have samesign: "\<forall> (a, b, c) \<in> (set b \<union> set c \<union> set d).
               (\<forall>y > ?bgrt. sign_num (a * y\<^sup>2 + b * y + c) =  sign_num (a*x^2 + b*x + c))"
         proof  clarsimp  
           fix t u v y
           assume insetunion: "(t, u, v) \<in> set b \<or> (t, u, v)  \<in> set c \<or> (t, u, v) \<in> set d"
           assume ygt: "sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
               (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0)  < y" 
           have tuzer: "t = 0 \<and> u = 0 \<Longrightarrow> sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             unfolding sign_num_def 
             by auto
           have tunonzer: "t \<noteq> 0 \<or> u \<noteq> 0  \<Longrightarrow> sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
           proof - 
             assume tuv_asm: "t\<noteq> 0 \<or> u \<noteq> 0"
             have "\<not>(\<exists>q. q > ?srl ! (length ?srl - 1) \<and> t * q\<^sup>2 + u * q + v = 0)"
             proof clarsimp 
               fix q
               assume qgt: "sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
                 (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0) < q"
               assume "t * q\<^sup>2 + u * q + v = 0"
               then have qin: "q \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
                 using insetunion tuv_asm by auto
               have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
                 unfolding sorted_nonzero_root_list_set_def
                 using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                   nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
                 by auto
               then have "q \<in> set ?srl" using qin unfolding nonzero_root_set_def
                 by auto 
               then have "List.member ?srl q"     
                 using in_set_member[of q ?srl]
                 by auto
               then show "False" using qgt in_set_conv_nth in_set_member not_le_imp_less not_less0 sorted_iff_nth_mono sorted_nonzero_root_list_set_def sorted_sorted_list_of_set
                 by (smt (z3) Suc_diff_Suc Suc_n_not_le_n \<open>q \<in> set (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d))\<close> in_set_conv_nth length_0_conv length_greater_0_conv length_sorted_list_of_set lenzero less_Suc_eq_le minus_nat.diff_0 not_le sorted_nth_mono sorted_sorted_list_of_set) 
             qed   
             then have nor: "\<not>(\<exists>q. q > ?bgrt \<and> t * q\<^sup>2 + u * q + v = 0)"
               using xgt
               by auto 
             have c1: " x > y \<Longrightarrow>  sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               using nor changes_sign_var[of t y u v x] xgt ygt
               by fastforce 
             then have c2: " y > x \<Longrightarrow>  sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               using nor changes_sign_var[of t x u v y] xgt ygt
               by force
             then have c3: " x = y \<Longrightarrow>  sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               unfolding sign_num_def 
               by auto
             then show "sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               using c1 c2 c3
               by linarith
           qed
           then show " sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             using tuzer 
             by blast
         qed
 
         have "(\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0)" 
           using alleqsetvar by auto 
         have " ?bgrt \<in> set ?srl" 
           using set_sorted_list_of_set nonzero_root_set_finite in_set_member
           using asm by auto
         then have "?bgrt \<in> nonzero_root_set (set b \<union> set c \<union> set d )"
           unfolding sorted_nonzero_root_list_set_def
           using  set_sorted_list_of_set nonzero_root_set_finite 
           by auto
         then have "\<exists>t u v. (t, u, v) \<in> set b \<union> set c \<union> set d \<and>(t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)"
           unfolding nonzero_root_set_def by auto
         then obtain t u v where tuvprop1: "(t, u, v) \<in> set b \<union> set c \<union> set d \<and>(t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)"
           by auto
         then have tuvprop: "((t, u, v) \<in> set b \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0))
           \<or> ((t, u, v) \<in> set c \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<or>
             ((t, u, v) \<in> set d \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0))  "
           by auto
         have tnonz: "t\<noteq> 0 \<Longrightarrow> (-1*u^2 + 4 * t * v \<le> 0  \<and> (?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t) \<or> ?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)))"
         proof - 
           assume "t\<noteq> 0"
           have "-1*u^2 + 4 * t * v \<le> 0 "  using tuvprop1 discriminant_negative[of t u v]
             unfolding discrim_def
             using \<open>t \<noteq> 0\<close> by force              
           then show ?thesis
             using tuvprop discriminant_nonneg[of t u v]
             unfolding discrim_def
             using \<open>t \<noteq> 0\<close> by auto 
         qed
         have unonz: "(t = 0 \<and> u \<noteq> 0) \<Longrightarrow> ?bgrt = - v / u"
         proof - 
           assume "(t = 0 \<and> u \<noteq> 0)"
           then have "u*?bgrt + v = 0" using tuvprop1
             by simp 
           then show "?bgrt = - v / u"
             by (simp add: \<open>t = 0 \<and> u \<noteq> 0\<close> eq_minus_divide_eq mult.commute) 
         qed
 
         have allpropb: "(\<forall>(d, e, f)\<in>set b.
               \<forall>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0)" 
         proof clarsimp 
           fix t1 u1 v1 y1 x1
           assume ins: "(t1, u1, v1) \<in> set b"
           assume x1gt: " sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
        (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0) < x1"
           assume "x1 \<le> y1"
           have xsn: "sign_num (t1 * x^2 + u1 * x + v1 ) = -1" using ins x_prop unfolding sign_num_def
             by auto
           have "sign_num (t1 * x1\<^sup>2 + u1 * x1 + v1 ) = sign_num (t1 * x^2 + u1 * x + v1 ) " 
             using ins x1gt samesign
             apply (auto) 
             by blast 
           then show "t1 * x1\<^sup>2 + u1 * x1 + v1 < 0" using xsn unfolding sign_num_def
             by (metis add.right_inverse add.right_neutral linorder_neqE_linordered_idom one_add_one zero_neq_numeral) 
         qed
         have allpropbvar: "(\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0)" 
         proof clarsimp 
           fix t1 u1 v1
           assume "(t1, u1, v1) \<in> set b"
           then have "\<forall>x\<in>{?bgrt<..(?bgrt + 1)}. t1 * x\<^sup>2 + u1 * x + v1 < 0"
             using allpropb
             by force 
           then show "\<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
            (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0).
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
                (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0)<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 < 0"
             using less_add_one
             by (metis One_nat_def)        
         qed
         have allpropc: "(\<forall>(d, e, f)\<in>set c.
               \<forall>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" 
         proof clarsimp 
           fix t1 u1 v1 y1 x1
           assume ins: "(t1, u1, v1) \<in> set c"
           assume x1gt: " sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
        (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0) < x1"
           assume "x1 \<le> y1"
           have xsn: "sign_num (t1 * x^2 + u1 * x + v1 ) = -1 \<or> sign_num (t1 * x^2 + u1 * x + v1 ) = 0" using ins x_prop unfolding sign_num_def
             by auto
           have "sign_num (t1 * x1\<^sup>2 + u1 * x1 + v1 ) = sign_num (t1 * x^2 + u1 * x + v1 ) " 
             using ins x1gt samesign  One_nat_def
           proof -
             have "case (t1, u1, v1) of (r, ra, rb) \<Rightarrow> \<forall>raa>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1). sign_num (r * raa\<^sup>2 + ra * raa + rb) = sign_num (r * x\<^sup>2 + ra * x + rb)"
               by (smt (z3) Un_iff ins samesign)
             then show ?thesis
               by (simp add: x1gt)
           qed
           then show "t1 * x1\<^sup>2 + u1 * x1 + v1 \<le> 0" using xsn unfolding sign_num_def
             by (metis equal_neg_zero less_numeral_extra(3) linorder_not_less zero_neq_one)
         qed
         have allpropcvar: "(\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" 
         proof clarsimp 
           fix t1 u1 v1
           assume "(t1, u1, v1) \<in> set c"
           then have "\<forall>x\<in>{?bgrt<..(?bgrt + 1)}. t1 * x\<^sup>2 + u1 * x + v1 \<le> 0"
             using allpropc
             by force 
           then show "\<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
            (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0).
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
                (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0)<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 \<le> 0"
             using less_add_one One_nat_def
             by metis
         qed
         have allpropd: "(\<forall>(d, e, f)\<in>set d.
               \<forall>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)" 
         proof clarsimp 
           fix t1 u1 v1 y1 x1
           assume ins: "(t1, u1, v1) \<in> set d"
           assume contrad:"t1 * x1\<^sup>2 + u1 * x1 + v1 = 0"
           assume x1gt: " sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
        (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0) < x1"
           assume "x1 \<le> y1"
           have xsn: "sign_num (t1 * x^2 + u1 * x + v1 ) = -1 \<or> sign_num (t1 * x^2 + u1 * x + v1 ) = 1" using ins x_prop unfolding sign_num_def
             by auto
           have "sign_num (t1 * x1\<^sup>2 + u1 * x1 + v1 ) = sign_num (t1 * x^2 + u1 * x + v1 ) " 
             using ins x1gt samesign apply (auto) 
             by blast 
           then have "t1 * x1\<^sup>2 + u1 * x1 + v1 \<noteq> 0" using xsn unfolding sign_num_def 
             by auto
           then show "False" using contrad by auto
         qed
         have allpropdvar: "(\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)" 
         proof clarsimp 
           fix t1 u1 v1
           assume "(t1, u1, v1) \<in> set d"
           then have "\<forall>x\<in>{?bgrt<..(?bgrt + 1)}. t1 * x\<^sup>2 + u1 * x + v1 \<noteq> 0"
             using allpropd
             by force 
           then show "\<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
            (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0).
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
                (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0)<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 \<noteq> 0"
             using less_add_one by force
         qed
         have "\<forall>x. (\<forall>(d, e, f)\<in>set a.
              d * x\<^sup>2 + e * x + f = 0)" using alleqsetvar
           by auto
         then have ast: "(\<forall>(d, e, f)\<in>set a.
              \<forall>x\<in>{?bgrt<..(?bgrt + 1)}. d * x\<^sup>2 + e * x + f = 0)"
           by auto
         have allpropavar: "(\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0)"
         proof clarsimp 
           fix t1 u1 v1 
           assume "(t1, u1, v1) \<in> set a"
           then have "\<forall>x\<in>{?bgrt<..(?bgrt + 1)}. t1 * x\<^sup>2 + u1 * x + v1 = 0 "
             using ast by auto 
           then show "\<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
            (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0).
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) !
                (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - Suc 0)<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 = 0"
             using less_add_one One_nat_def
             by metis
         qed
         have quadsetb: "((t, u, v) \<in> set b \<and> t\<noteq> 0) \<Longrightarrow> False"
         proof - 
           assume asm: "(t, u, v) \<in> set b \<and> t\<noteq> 0"
           have bgrt1: "(?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
           proof - 
             assume bgrtis: "?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
             have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
               using \<open>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1) = (- u + 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)\<close> 
               by auto 
             have "((t, u, v)\<in>set b \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using f6 bgrtis 
               by auto
           qed
           have bgrt2: "(?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
           proof -
             assume bgrtis: "?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
             have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
               using \<open>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1) = (- u + -1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)\<close> 
               by auto
             have "((t, u, v)\<in>set b \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using f7 bgrtis 
               by auto
           qed 
           show "False" using tnonz bgrt1 bgrt2 asm 
             by auto
         qed
         have linsetb: "((t, u, v) \<in> set b \<and> (t = 0 \<and> u \<noteq> 0)) \<Longrightarrow> False"
         proof - 
           assume asm: "(t, u, v) \<in> set b \<and> (t = 0 \<and> u \<noteq> 0)"
           then have bgrtis: "?bgrt = (- v / u)"
             using unonz
             by blast 
           have "((t, u, v)\<in>set b \<and> (t = 0 \<and> u \<noteq> 0) \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
             using asm allpropavar allpropbvar allpropcvar allpropdvar
             by linarith
           then show "False" using bgrtis f5  
             by auto
         qed
         have insetb: "((t, u, v) \<in> set b \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<Longrightarrow> False"
           using quadsetb linsetb by auto
         have quadsetc: "(t, u, v) \<in> set c \<and> t\<noteq> 0 \<Longrightarrow> False"
         proof - 
           assume asm: "(t, u, v) \<in> set c \<and> t\<noteq> 0"
           have bgrt1: "(?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
           proof - 
             assume bgrtis: "?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
             have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
               using \<open>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1) = (- u + 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)\<close> 
               by auto 
             have "((t, u, v)\<in>set c \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using f13a bgrtis 
               by auto
           qed
           have bgrt2: "(?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
           proof -
             assume bgrtis: "?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
             have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
               using \<open>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1) = (- u + -1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)\<close> 
               by auto
             have "((t, u, v)\<in>set c \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using f9a bgrtis 
               by auto
           qed 
           show "False" using tnonz bgrt1 bgrt2 asm 
             by auto
         qed
         have linsetc: "(t, u, v) \<in> set c \<and> (t = 0 \<and> u \<noteq> 0) \<Longrightarrow> False"
         proof - 
           assume asm: "(t, u, v) \<in> set c \<and> (t = 0 \<and> u \<noteq> 0)"
           then have bgrtis: "?bgrt = (- v / u)"
             using unonz
             by blast 
           have "((t, u, v)\<in>set c \<and> (t = 0 \<and> u \<noteq> 0) \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
             using asm allpropavar allpropbvar allpropcvar allpropdvar
             by linarith
           then show "False" using bgrtis f8a  
             by auto
         qed
         have insetc: "((t, u, v) \<in> set c \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<Longrightarrow> False"
           using quadsetc linsetc by auto
         have quadsetd: "(t, u, v) \<in> set d \<and> t\<noteq> 0 \<Longrightarrow> False"
         proof - 
           assume asm: "(t, u, v) \<in> set d \<and> t\<noteq> 0"
           have bgrt1: "(?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
           proof - 
             assume bgrtis: "?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
             have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
               using \<open>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1) = (- u + 1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)\<close> 
               by auto 
             have "((t, u, v)\<in>set d \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using f11 bgrtis 
               by auto
           qed
           have bgrt2: "(?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
           proof -
             assume bgrtis: "?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
             have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
               using \<open>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! (length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 1) = (- u + -1 * sqrt (u\<^sup>2 - 4 * t * v)) / (2 * t)\<close> 
               by auto
             have "((t, u, v)\<in>set d \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using f12 bgrtis 
               by auto
           qed 
           show "False" using tnonz bgrt1 bgrt2 asm 
             by auto
         qed
         have linsetd: "(t, u, v) \<in> set d \<and> (t = 0 \<and> u \<noteq> 0) \<Longrightarrow> False"
         proof - 
           assume asm: "(t, u, v) \<in> set d \<and> (t = 0 \<and> u \<noteq> 0)"
           then have bgrtis: "?bgrt = (- v / u)"
             using unonz
             by blast 
           have "((t, u, v)\<in>set d \<and> (t = 0 \<and> u \<noteq> 0) \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
             using asm allpropavar allpropbvar allpropcvar allpropdvar
             by linarith
           then show "False" using bgrtis f10
             by auto
         qed
         have insetd: "((t, u, v) \<in> set d \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<Longrightarrow> False"
           using quadsetd linsetd by auto
         then show "False" using insetb insetc insetd tuvprop 
           by auto
       qed
       have len1: "length ?srl = 1 \<Longrightarrow> False" 
       proof - 
         assume len1: "length ?srl = 1"
         have cases: "(List.member ?srl x) \<or> x < ?srl ! 0 \<or> x > ?srl ! 0"
           using in_set_member lenzero nth_mem by fastforce
         then show "False"
           using len1 cases_mem cases_lt cases_gt by auto
       qed
       have lengtone: "length ?srl > 1 \<Longrightarrow> False" 
       proof - 
         assume lengt1: "length ?srl > 1" 
         have cases: "(List.member ?srl x) \<or> x < ?srl ! 0 \<or> x > ?srl ! (length ?srl -1)
                   \<or> (\<exists>k \<le> (length ?srl - 2). (?srl ! k < x \<and> x <?srl ! (k + 1)))"
         proof -
           have eo: "x < ?srl ! 0 \<or> x > ?srl ! (length ?srl -1) \<or> (x \<ge> ?srl ! 0 \<and> x \<le> ?srl ! (length ?srl -1))"
             by auto
           have ifo: "(x \<ge> ?srl ! 0 \<and> x \<le> ?srl ! (length ?srl -1)) \<Longrightarrow> ((List.member ?srl x) \<or> (\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1)))"
           proof - 
             assume xinbtw: "x \<ge> ?srl ! 0 \<and> x \<le> ?srl ! (length ?srl -1)"
             then have "\<not>(List.member ?srl x) \<Longrightarrow>  (\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1))"
             proof - 
               assume nonmem: "\<not>(List.member ?srl x)"
               have "\<not>(\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1)) \<Longrightarrow> False"
               proof clarsimp
                 assume "\<forall>k. sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < x \<longrightarrow>
         k \<le> length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 2 \<longrightarrow>
         \<not> x < sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! Suc k"
                 then have allk: "(\<forall>k \<le> length ?srl - 2. ?srl ! k < x \<longrightarrow>
         \<not> x < ?srl ! Suc k)" by auto 
                 have basec: "x \<ge> ?srl ! 0" using xinbtw by auto
                 have "\<forall>k \<le> length ?srl - 2. ?srl ! k < x" 
                 proof clarsimp 
                   fix k
                   assume klteq: "k \<le> length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 2"
                   show "sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < x"
                     using nonmem klteq basec 
                   proof (induct k)
                     case 0
                     then show ?case
                       using in_set_member lenzero nth_mem by fastforce 
                   next
                     case (Suc k)
                     then show ?case
                       by (smt Suc_leD Suc_le_lessD \<open>\<forall>k. sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < x \<longrightarrow> k \<le> length (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d)) - 2 \<longrightarrow> \<not> x < sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! Suc k\<close> diff_less in_set_member length_0_conv length_greater_0_conv lenzero less_trans_Suc nth_mem pos2) 
                   qed
                 qed
                 then have "x \<ge> ?srl ! (length ?srl -1)" 
                   using allk
                   by (metis One_nat_def Suc_diff_Suc lengt1 less_eq_real_def less_or_eq_imp_le one_add_one plus_1_eq_Suc xinbtw) 
                 then have "x > ?srl ! (length ?srl - 1)" using nonmem
                   by (metis One_nat_def Suc_le_D asm diff_Suc_Suc diff_zero in_set_member lessI less_eq_real_def nth_mem) 
                 then show "False" using xinbtw by auto
               qed
               then show "(\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1))"
                 by blast
             qed
             then show "((List.member ?srl x) \<or> (\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1)))" 
               using sorted_nth_mono
               by auto 
           qed
           then show ?thesis using eo ifo by auto
         qed
           (* should violate one of the infinitesmials *)
         have cases_btw: "(\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1)) \<Longrightarrow> False"
         proof - 
           assume "(\<exists>k \<le> (length ?srl - 2). ?srl ! k < x \<and> x <?srl ! (k + 1))"
           then obtain k where k_prop: "k \<le> (length ?srl - 2) \<and> ?srl ! k < x \<and> x <?srl ! (k + 1)"
             by auto
           have samesign: "\<forall> (a, b, c) \<in> (set b \<union> set c \<union> set d).
               (\<forall>y. (?srl ! k < y \<and> y <?srl ! (k + 1)) \<longrightarrow> sign_num (a * y\<^sup>2 + b * y + c) =  sign_num (a*x^2 + b*x + c))"
           proof  clarsimp  
             fix t u v y
             assume insetunion: "(t, u, v) \<in> set b \<or> (t, u, v)  \<in> set c \<or> (t, u, v) \<in> set d"
             assume ygt: " sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < y" 
             assume ylt: "y < sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! Suc k"
             have tuzer: "t = 0 \<and> u = 0 \<Longrightarrow> sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               unfolding sign_num_def 
               by auto
             have tunonzer: "t \<noteq> 0 \<or> u \<noteq> 0  \<Longrightarrow> sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
             proof - 
               assume tuv_asm: "t\<noteq> 0 \<or> u \<noteq> 0"
               have nor: "\<not>(\<exists>q. q > ?srl ! k \<and> q < ?srl ! (k + 1) \<and> t * q\<^sup>2 + u * q + v = 0)"
               proof clarsimp 
                 fix q
                 assume qlt: "q < sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! Suc k"
                 assume qgt: "sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < q"
                 assume "t * q\<^sup>2 + u * q + v = 0"
                 then have qin: "q \<in>  {x. \<exists>(a, b, c)\<in>set b \<union> set c \<union> set d. (a \<noteq> 0 \<or> b \<noteq> 0) \<and> a * x\<^sup>2 + b * x + c = 0}"
                   using insetunion tuv_asm by auto
                 have "set ?srl = nonzero_root_set (set b \<union> set c \<union> set d)"
                   unfolding sorted_nonzero_root_list_set_def
                   using set_sorted_list_of_set[of "nonzero_root_set (set b \<union> set c \<union> set d)"]
                     nonzero_root_set_finite[of "(set b \<union> set c \<union> set d)"]
                   by auto
                 then have "q \<in> set ?srl" using qin unfolding nonzero_root_set_def
                   by auto 
                 then have "List.member ?srl q"     
                   using in_set_member[of q ?srl]
                   by auto
                 then have "\<exists>n < length ?srl. q = ?srl ! n"
                   by (metis \<open>q \<in> set (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d))\<close> in_set_conv_nth) 
                 then obtain n where nprop: "n < length ?srl \<and> q = ?srl ! n" by auto
                 then have ngtk: "n > k"
                 proof - 
                   have sortedh: "sorted ?srl"
                     by (simp add: sorted_nonzero_root_list_set_def) 
                   then have nlteq: "n \<le> k \<Longrightarrow> ?srl ! n \<le> ?srl ! k" using nprop k_prop sorted_iff_nth_mono
                     using sorted_nth_mono
                     by (metis Suc_1 \<open>q \<in> set (sorted_nonzero_root_list_set (set b \<union> set c \<union> set d))\<close> diff_less length_pos_if_in_set sup.absorb_iff2 sup.strict_boundedE zero_less_Suc)
                   have "?srl ! n > ?srl ! k" using nprop qgt by auto
                   then show ?thesis
                     using nlteq
                     by linarith 
                 qed
                 then have nltkp1: "n < k+1"
                 proof - 
                   have sortedh: "sorted ?srl"
                     by (simp add: sorted_nonzero_root_list_set_def) 
                   then have ngteq: "k+1 \<le> n \<Longrightarrow> ?srl ! (k+1) \<le> ?srl ! n" using nprop k_prop sorted_iff_nth_mono
                     by auto
                   have "?srl ! n < ?srl ! (k + 1)" using nprop qlt by auto
                   then show ?thesis
                     using ngteq by linarith
                 qed
                 then show "False" using ngtk nltkp1 by auto
               qed
               have c1: " x > y \<Longrightarrow>  sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
                 using nor changes_sign_var[of t y u v x] k_prop ygt ylt
                 by fastforce 
               then have c2: " y > x \<Longrightarrow>  sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
                 using nor changes_sign_var[of t x u v y] k_prop ygt ylt
                 by force
               then have c3: " x = y \<Longrightarrow>  sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
                 unfolding sign_num_def 
                 by auto
               then show "sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
                 using c1 c2 c3
                 by linarith
             qed
             then show " sign_num (t * y\<^sup>2 + u * y + v) = sign_num (t * x\<^sup>2 + u * x + v)"
               using tuzer 
               by blast
           qed
 
           let ?bgrt = "?srl ! k"
 
           have "(\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0)" 
             using alleqsetvar by auto 
           have " ?bgrt \<in> set ?srl" 
             using set_sorted_list_of_set nonzero_root_set_finite in_set_member k_prop asm
             by (smt diff_Suc_less le_eq_less_or_eq less_le_trans nth_mem one_add_one plus_1_eq_Suc zero_less_one)
           then have "?bgrt \<in> nonzero_root_set (set b \<union> set c \<union> set d )"
             unfolding sorted_nonzero_root_list_set_def
             using  set_sorted_list_of_set nonzero_root_set_finite 
             by auto
           then have "\<exists>t u v. (t, u, v) \<in> set b \<union> set c \<union> set d \<and>(t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)"
             unfolding nonzero_root_set_def by auto
           then obtain t u v where tuvprop1: "(t, u, v) \<in> set b \<union> set c \<union> set d \<and>(t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)"
             by auto
           then have tuvprop: "((t, u, v) \<in> set b \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0))
           \<or> ((t, u, v) \<in> set c \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<or>
             ((t, u, v) \<in> set d \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0))  "
             by auto
           have tnonz: "t\<noteq> 0 \<Longrightarrow> (-1*u^2 + 4 * t * v \<le> 0  \<and> (?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t) \<or> ?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)))"
           proof - 
             assume "t\<noteq> 0"
             have "-1*u^2 + 4 * t * v \<le> 0 "  using tuvprop1 discriminant_negative[of t u v]
               unfolding discrim_def
               using \<open>t \<noteq> 0\<close> by force              
             then show ?thesis
               using tuvprop discriminant_nonneg[of t u v]
               unfolding discrim_def
               using \<open>t \<noteq> 0\<close> by auto 
           qed
           have unonz: "(t = 0 \<and> u \<noteq> 0) \<Longrightarrow> ?bgrt = - v / u"
           proof - 
             assume "(t = 0 \<and> u \<noteq> 0)"
             then have "u*?bgrt + v = 0" using tuvprop1
               by simp 
             then show "?bgrt = - v / u"
               by (simp add: \<open>t = 0 \<and> u \<noteq> 0\<close> eq_minus_divide_eq mult.commute) 
           qed
 
           have "\<exists>y'. y' > x \<and> y' < ?srl ! (k+1)" using k_prop dense
             by blast 
           then obtain y1 where y1_prop: "y1 > x \<and> y1 < ?srl ! (k+1)" by auto
           then have y1inbtw: "y1 > ?srl ! k \<and> y1 < ?srl ! (k+1)" using k_prop
             by auto
 
           have allpropb: "(\<forall>(d, e, f)\<in>set b.
              \<forall>x\<in>{?bgrt<..y1}. d * x\<^sup>2 + e * x + f < 0)" 
           proof clarsimp 
             fix t1 u1 v1 x1
             assume ins: "(t1, u1, v1) \<in> set b"
             assume x1gt: "sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < x1"
             assume x1lt: "x1 \<le> y1"
             have x1inbtw: "x1 > ?srl ! k \<and> x1 < ?srl ! (k+1)"
               using x1gt x1lt y1inbtw
               by (smt One_nat_def cases_gt k_prop) 
             have xsn: "sign_num (t1 * x^2 + u1 * x + v1 ) = -1" using ins x_prop unfolding sign_num_def
               by auto
             have "sign_num (t1 * x1\<^sup>2 + u1 * x1 + v1 ) = sign_num (t1 * x^2 + u1 * x + v1 ) " 
               using ins x1inbtw samesign
               by blast 
             then show "t1 * x1\<^sup>2 + u1 * x1 + v1 < 0" using xsn unfolding sign_num_def 
               by (metis add.right_inverse add.right_neutral linorder_neqE_linordered_idom one_add_one zero_neq_numeral) 
           qed
           have allpropbvar: "(\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0)" 
           proof clarsimp 
             fix t1 u1 v1
             assume "(t1, u1, v1) \<in> set b"
             then have "\<forall>x\<in>{?bgrt<..y1}. t1 * x\<^sup>2 + u1 * x + v1 < 0"
               using allpropb
               by force 
             then show " \<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k.
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 < 0" 
               using y1inbtw by blast 
           qed
           have allpropc: "(\<forall>(d, e, f)\<in>set c.
                \<forall>x\<in>{?bgrt<..y1}. d * x\<^sup>2 + e * x + f \<le> 0)" 
           proof clarsimp 
             fix t1 u1 v1 x1
             assume ins: "(t1, u1, v1) \<in> set c"
             assume x1gt: " sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < x1"
             assume x1lt: "x1 \<le> y1"
             have x1inbtw: "x1 > ?srl ! k \<and> x1 < ?srl ! (k+1)"
               using x1gt x1lt y1inbtw
               by (smt One_nat_def cases_gt k_prop) 
             have xsn: "sign_num (t1 * x^2 + u1 * x + v1 ) = -1 \<or> sign_num (t1 * x^2 + u1 * x + v1 ) = 0" using ins x_prop unfolding sign_num_def
               by auto
             have "sign_num (t1 * x1\<^sup>2 + u1 * x1 + v1 ) = sign_num (t1 * x^2 + u1 * x + v1 ) " 
               using ins x1inbtw samesign
               by blast 
             then show "t1 * x1\<^sup>2 + u1 * x1 + v1 \<le> 0" using xsn unfolding sign_num_def
               by (smt (verit, del_insts))
           qed
           have allpropcvar: "(\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0)" 
           proof clarsimp 
             fix t1 u1 v1
             assume "(t1, u1, v1) \<in> set c"
             then have "\<forall>x\<in>{?bgrt<..y1}. t1 * x\<^sup>2 + u1 * x + v1 \<le> 0"
               using allpropc 
               by force 
             then show " \<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k.
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 \<le> 0" 
               using y1inbtw by blast 
           qed
           have allpropd: "(\<forall>(d, e, f)\<in>set d.
               \<forall>x\<in>{?bgrt<..y1}. d * x\<^sup>2 + e * x + f \<noteq> 0)" 
           proof clarsimp 
             fix t1 u1 v1 x1
             assume ins: "(t1, u1, v1) \<in> set d"
             assume contrad:"t1 * x1\<^sup>2 + u1 * x1 + v1 = 0"
             assume x1gt: " sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k < x1"
             assume x1lt: "x1 \<le> y1"
             have x1inbtw: "x1 > ?srl ! k \<and> x1 < ?srl ! (k+1)"
               using x1gt x1lt y1inbtw
               by (smt One_nat_def cases_gt k_prop) 
             have xsn: "sign_num (t1 * x^2 + u1 * x + v1 ) = -1 \<or> sign_num (t1 * x^2 + u1 * x + v1 ) = 1" using ins x_prop unfolding sign_num_def
               by auto
             have "sign_num (t1 * x1\<^sup>2 + u1 * x1 + v1 ) = sign_num (t1 * x^2 + u1 * x + v1 ) " 
               using ins x1inbtw samesign
               by blast
             then have "t1 * x1\<^sup>2 + u1 * x1 + v1 \<noteq> 0" using xsn unfolding sign_num_def 
               by auto
             then show "False" using contrad by auto
           qed
           have allpropdvar: "(\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)" 
           proof clarsimp 
             fix t1 u1 v1
             assume "(t1, u1, v1) \<in> set d"
             then have "\<forall>x\<in>{?bgrt<..y1}. t1 * x\<^sup>2 + u1 * x + v1 \<noteq> 0"
               using allpropd
               by force 
             then show " \<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k.
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 \<noteq> 0" 
               using y1inbtw by blast 
           qed
           have "\<forall>x. (\<forall>(d, e, f)\<in>set a.
              d * x\<^sup>2 + e * x + f = 0)" using alleqsetvar
             by auto
           then have ast: "(\<forall>(d, e, f)\<in>set a.
              \<forall>x\<in>{?bgrt<..(?bgrt + 1)}. d * x\<^sup>2 + e * x + f = 0)"
             by auto
           have allpropavar: "(\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0)"
           proof clarsimp 
             fix t1 u1 v1 
             assume "(t1, u1, v1) \<in> set a"
             then have "\<forall>x\<in>{?bgrt<..(?bgrt + 1)}. t1 * x\<^sup>2 + u1 * x + v1 = 0 "
               using ast by auto 
             then show "\<exists>y'>sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k.
           \<forall>x\<in>{sorted_nonzero_root_list_set (set b \<union> set c \<union> set d) ! k<..y'}.
              t1 * x\<^sup>2 + u1 * x + v1 = 0" 
               using less_add_one by blast 
           qed
 
           have quadsetb: "((t, u, v) \<in> set b \<and> t\<noteq> 0) \<Longrightarrow> False"
           proof - 
             assume asm: "(t, u, v) \<in> set b \<and> t\<noteq> 0"
             have bgrt1: "(?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
             proof - 
               assume bgrtis: "?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
               have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
                 by blast           
               have "((t, u, v)\<in>set b \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
                 using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
                 by linarith
               then show "False" using f6 bgrtis 
                 by auto
             qed
             have bgrt2: "(?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
             proof -
               assume bgrtis: "?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
               have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
                 by blast
               have "((t, u, v)\<in>set b \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
                 using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
                 by linarith
               then show "False" using f7 bgrtis 
                 by auto
             qed 
             show "False" using tnonz bgrt1 bgrt2 asm 
               by auto
           qed
           have linsetb: "((t, u, v) \<in> set b \<and> (t = 0 \<and> u \<noteq> 0)) \<Longrightarrow> False"
           proof - 
             assume asm: "(t, u, v) \<in> set b \<and> (t = 0 \<and> u \<noteq> 0)"
             then have bgrtis: "?bgrt = (- v / u)"
               using unonz
               by blast 
             have "((t, u, v)\<in>set b \<and> (t = 0 \<and> u \<noteq> 0) \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using bgrtis f5  
               by auto
           qed
           have insetb: "((t, u, v) \<in> set b \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<Longrightarrow> False"
             using quadsetb linsetb by auto
           have quadsetc: "(t, u, v) \<in> set c \<and> t\<noteq> 0 \<Longrightarrow> False"
           proof - 
             assume asm: "(t, u, v) \<in> set c \<and> t\<noteq> 0"
             have bgrt1: "(?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
             proof - 
               assume bgrtis: "?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
               have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
                 by blast 
               have "((t, u, v)\<in>set c \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
                 using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
                 by linarith
               then show "False" using f13a bgrtis 
                 by auto
             qed
             have bgrt2: "(?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
             proof -
               assume bgrtis: "?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
               have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
                 by blast
               have "((t, u, v)\<in>set c \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
                 using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
                 by linarith
               then show "False" using f9a bgrtis 
                 by auto
             qed 
             show "False" using tnonz bgrt1 bgrt2 asm 
               by auto
           qed
           have linsetc: "(t, u, v) \<in> set c \<and> (t = 0 \<and> u \<noteq> 0) \<Longrightarrow> False"
           proof - 
             assume asm: "(t, u, v) \<in> set c \<and> (t = 0 \<and> u \<noteq> 0)"
             then have bgrtis: "?bgrt = (- v / u)"
               using unonz
               by blast 
             have "((t, u, v)\<in>set c \<and> (t = 0 \<and> u \<noteq> 0) \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using bgrtis f8a  
               by auto
           qed
           have insetc: "((t, u, v) \<in> set c \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<Longrightarrow> False"
             using quadsetc linsetc by auto
           have quadsetd: "(t, u, v) \<in> set d \<and> t\<noteq> 0 \<Longrightarrow> False"
           proof - 
             assume asm: "(t, u, v) \<in> set d \<and> t\<noteq> 0"
             have bgrt1: "(?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
             proof - 
               assume bgrtis: "?bgrt = (- u + 1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
               have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
                 by blast
               have "((t, u, v)\<in>set d \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
                 using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
                 by linarith
               then show "False" using f11 bgrtis 
                 by auto
             qed
             have bgrt2: "(?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)) \<Longrightarrow> False "
             proof -
               assume bgrtis: "?bgrt = (- u + -1 * sqrt (u^2 - 4 * t * v)) / (2 * t)"
               have discrim_prop: "-1*u^2 + 4 * t * v \<le> 0" using asm tnonz
                 by blast
               have "((t, u, v)\<in>set d \<and> t \<noteq> 0 \<and> - 1*u^2 + 4 * t * v \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
                 using asm discrim_prop allpropavar allpropbvar allpropcvar allpropdvar
                 by linarith
               then show "False" using f12 bgrtis 
                 by auto
             qed 
             show "False" using tnonz bgrt1 bgrt2 asm 
               by auto
           qed
           have linsetd: "(t, u, v) \<in> set d \<and> (t = 0 \<and> u \<noteq> 0) \<Longrightarrow> False"
           proof - 
             assume asm: "(t, u, v) \<in> set d \<and> (t = 0 \<and> u \<noteq> 0)"
             then have bgrtis: "?bgrt = (- v / u)"
               using unonz
               by blast 
             have "((t, u, v)\<in>set d \<and> (t = 0 \<and> u \<noteq> 0) \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>?bgrt. \<forall>x\<in>{?bgrt<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)))"
               using asm allpropavar allpropbvar allpropcvar allpropdvar
               by linarith
             then show "False" using bgrtis f10
               by auto
           qed
           have insetd: "((t, u, v) \<in> set d \<and> (t \<noteq> 0 \<or> u \<noteq> 0) \<and> (t * ?bgrt\<^sup>2 + u * ?bgrt + v = 0)) \<Longrightarrow> False"
             using quadsetd linsetd by auto
           then show "False" using insetb insetc insetd tuvprop 
             by auto
         qed
         show "False" using cases cases_btw cases_mem cases_lt cases_gt 
           by auto
       qed
       show "False" using asm len1 lengtone
         by linarith 
     qed
     show "False" using lenzero lengt0
       by linarith 
   qed
   then show ?thesis
     by blast  
 qed
 
 
 lemma qe_forwards: 
   assumes "(\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
   shows "((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) \<or>
      (\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0))) \<or>
      (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) \<or>
      (\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0))) \<or>
      (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))))" 
     (* using eq_qe_1 les_qe_1 *)
 proof -
   let ?e2 = "(((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) 
      \<or>
      (\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)         
           \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))) 
     \<or>
      (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) 
     \<or>
      (\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))) 
       \<or>
      (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))))"
   let ?f10orf11orf12 = "(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f8orf9 = "(\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   let ?f5orf6orf7 = "(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f2orf3orf4 = "(\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)         
           \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   let ?e1 = "(\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
   let ?f1 = "((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0))"
   let ?f2 = "(\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
   let ?f3 = "(\<exists>(a', b', c')\<in>set a. a' \<noteq> 0 \<and> - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))"
   let ?f4 = "(\<exists>(a', b', c')\<in>set a. a' \<noteq> 0 \<and> - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
  (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)) "
   let ?f5 = "(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   let ?f6 = "(\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f7 = "(\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   let ?f8 = "(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
   let ?f13 = "(\<exists>(a', b', c')\<in>set c.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   let ?f9 = "(\<exists>(a', b', c')\<in>set c.  a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))"
   let ?f10 = "(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   let ?f11 = "(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f12 = "(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   have h1a: "(?f1 \<or> ?f2orf3orf4 \<or> ?f5orf6orf7 \<or> ?f8orf9 \<or> ?f10orf11orf12) \<longrightarrow> ?e2"
     by auto
   have h2: "(?f2 \<or> ?f3 \<or> ?f4) \<longrightarrow> ?f2orf3orf4" by auto
   then have h1b: "(?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5orf6orf7 \<or> ?f8orf9 \<or> ?f10orf11orf12) \<longrightarrow> ?e2"
     using h1a by auto
   have h3: "(?f5 \<or> ?f6 \<or> ?f7) \<longrightarrow> ?f5orf6orf7" by auto
   then have h1c: "(?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8orf9 \<or> ?f10orf11orf12) \<longrightarrow> ?e2"
     using h1b by smt 
   have h4: "(?f8 \<or> ?f9 \<or> ?f13) \<longrightarrow> ?f8orf9" by auto
   then have h1d: "(?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8 \<or> ?f9 \<or> ?f13 \<or> ?f10orf11orf12) \<longrightarrow> ?e2"
     using h1c
     by smt 
   have h5: "(?f10 \<or> ?f11 \<or> ?f12) \<longrightarrow> ?f10orf11orf12" 
     by auto
   then have bigor: "(?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8 \<or> ?f13 \<or> ?f9 \<or> ?f10 \<or> ?f11 \<or> ?f12)
     \<longrightarrow> ?e2 "
     using h1d  by smt 
   then have bigor_var: "\<not>?e2 \<longrightarrow> \<not>(?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8 \<or> ?f13 \<or> ?f9 \<or> ?f10 \<or> ?f11 \<or> ?f12)
    " using contrapos_nn
     by smt 
   have not_eq: "\<not>(?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8 \<or> ?f13 \<or> ?f9 \<or> ?f10 \<or> ?f11 \<or> ?f12) 
 =(\<not>?f1 \<and> \<not>?f2  \<and> \<not>?f3  \<and> \<not>?f4  \<and> \<not>?f5 \<and> \<not>?f6 \<and> \<not>?f7 \<and> \<not>?f8 \<and> \<not>?f13 \<and> \<not>?f9 \<and> \<not>?f10 \<and> \<not>?f11 \<and> \<not>?f12) "
     by linarith
   obtain x where x_prop: "(\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" using assms by auto
   have "(\<not>?f1 \<and> \<not>?f2  \<and> \<not>?f3  \<and> \<not>?f4  \<and> \<not>?f5 \<and> \<not>?f6 \<and> \<not>?f7 \<and> \<not>?f8 \<and> \<not>?f13 \<and> \<not>?f9 \<and> \<not>?f10 \<and> \<not>?f11 \<and> \<not>?f12) \<Longrightarrow> False"
   proof - 
     assume big_not: " \<not> ((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set a.
            (a' = 0 \<and> b' \<noteq> 0) \<and>
            (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set a.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set a.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set b.
            (a' = 0 \<and> b' \<noteq> 0) \<and>
            (\<forall>(d, e, f)\<in>set a. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set b.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set b.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set c.
            (a' = 0 \<and> b' \<noteq> 0) \<and>
            (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set c.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f =
                0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f
                < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f
                \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq>
                0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set c.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f =
                0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f
                < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f
                \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq>
                0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set d.
            (a' = 0 \<and> b' \<noteq> 0) \<and>
            (\<forall>(d, e, f)\<in>set a. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set d.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<noteq> 0)) \<and>
     \<not> (\<exists>(a', b', c')\<in>set d.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                   \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                      d * x\<^sup>2 + e * x + f \<noteq> 0))"
     have c1: "(\<exists> (d, e, f) \<in> set a. d \<noteq> 0 \<and> - e\<^sup>2 + 4 * d * f \<le> 0) \<Longrightarrow> False"
     proof - 
       assume "(\<exists> (d, e, f) \<in> set a. d \<noteq> 0 \<and> - e\<^sup>2 + 4 * d * f \<le> 0)"
       then obtain a' b' c' where abc_prop:  "(a', b', c') \<in> set a \<and> a' \<noteq> 0 \<and> - b'\<^sup>2 + 4 * a' * c' \<le> 0"
         by auto
       then have "a'*x^2 + b'*x + c' = 0" using x_prop by auto
       then have xis: "x = (- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a') \<or> x = (- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a') " 
         using abc_prop discriminant_nonneg[of a' b' c'] unfolding discrim_def
         by auto 
       then have "((\<forall>(d, e, f)\<in>set a.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq> 0)) \<or>
         ((\<forall>(d, e, f)\<in>set a.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq> 0))"
         using x_prop by auto
       then have "(\<exists>(a', b', c')\<in>set a.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq> 0)) \<or>
         (\<exists>(a', b', c')\<in>set a.
            a' \<noteq> 0 \<and>
            - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
            (\<forall>(d, e, f)\<in>set a.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d.
                d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                f \<noteq> 0))" using abc_prop xis by auto
       then show "False"
         using big_not by auto
     qed
     have c2: "(\<exists> (d, e, f) \<in> set a. d = 0 \<and> e \<noteq> 0) \<Longrightarrow> False"
     proof - 
       assume "(\<exists> (d, e, f) \<in> set a. d = 0 \<and> e \<noteq> 0)"
       then obtain a' b' c' where abc_prop: "(a', b', c') \<in> set a \<and> a' = 0 \<and> b' \<noteq> 0" by auto 
       then have "a'*x^2 + b'*x + c' = 0" using x_prop by auto
       then have "b'*x + c' = 0" using abc_prop by auto
       then have xis: "x = - c' / b'" using abc_prop
         by (smt divide_non_zero)
       then have "(\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)" 
         using x_prop by auto 
       then have "(\<exists>(a', b', c')\<in>set a.
            (a' = 0 \<and> b' \<noteq> 0) \<and>
            (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
            (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
            (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
            (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
         using abc_prop xis by auto
       then show "False"
         using big_not by auto 
     qed
     have c3: "(\<forall> (d, e, f) \<in> set a. d = 0 \<and> e = 0 \<and> f = 0) \<Longrightarrow> False"
     proof - 
       assume "(\<forall> (d, e, f) \<in> set a. d = 0 \<and> e = 0 \<and> f = 0)"
       then have equalset: "\<forall>x. (\<forall>(d, e, f)\<in>set a. d * x^2 + e * x + f = 0)"
         using case_prodE by auto
       have "\<not>?f5 \<and> \<not>?f6 \<and> \<not>?f7 \<and> \<not>?f8 \<and> \<not>?f13 \<and> \<not>?f9 \<and> \<not>?f10 \<and> \<not>?f11 \<and> \<not>?f12"
         using big_not by auto
       then have "\<not>(\<exists>x. (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
         using equalset big_not qe_forwards_helper[of a b c d] by auto
       then show "False"
         using x_prop by auto
     qed
     have eo: "(\<exists> (d, e, f) \<in> set a. d \<noteq> 0 \<and> - e\<^sup>2 + 4 * d * f \<le> 0) \<or> (\<exists> (d, e, f) \<in> set a. d = 0 \<and> e \<noteq> 0) \<or> (\<forall> (d, e, f) \<in> set a. d = 0 \<and> e = 0 \<and> f = 0)"
     proof - 
       have  "(\<forall> (d, e, f) \<in> set a. (d \<noteq> 0 \<longrightarrow>  - e\<^sup>2 + 4 * d * f \<le> 0))"
       proof clarsimp 
         fix d e f
         assume in_set: " (d, e, f) \<in> set a"
         assume dnonz: "d \<noteq> 0"
         have "d*x^2 + e*x + f = 0" using in_set x_prop by auto 
         then show " 4 * d * f \<le> e\<^sup>2"
           using dnonz discriminant_negative[of d e f] unfolding discrim_def
           by fastforce 
       qed
       then have discrim_prop: "\<not>(\<exists> (d, e, f) \<in> set a. d \<noteq> 0 \<and> - e\<^sup>2 + 4 * d * f \<le> 0) \<Longrightarrow> \<not>(\<exists> (d, e, f) \<in> set a. d \<noteq> 0)"
         by auto
       have "\<not>(\<exists> (d, e, f) \<in> set a. d \<noteq> 0) \<and> \<not>(\<exists> (d, e, f) \<in> set a. d = 0 \<and> e \<noteq> 0) \<Longrightarrow> (\<forall> (d, e, f) \<in> set a. d = 0 \<and> e = 0 \<and> f = 0)"
       proof - 
         assume ne: "\<not>(\<exists> (d, e, f) \<in> set a. d \<noteq> 0) \<and> \<not>(\<exists> (d, e, f) \<in> set a. d = 0 \<and> e \<noteq> 0)"
         show "(\<forall> (d, e, f) \<in> set a. d = 0 \<and> e = 0 \<and> f = 0)"
         proof clarsimp 
           fix d e f 
           assume in_set: "(d, e, f) \<in>set a"
           then have xzer: "d*x^2 + e*x + f = 0" using x_prop by auto
           have dzer: "d = 0" using ne in_set by auto
           have ezer: "e = 0" using ne in_set by auto
           show "d = 0 \<and> e = 0 \<and> f = 0" using xzer dzer ezer by auto 
         qed
       qed
       then show ?thesis using discrim_prop by auto
     qed
     show "False" using c1 c2 c3 eo by auto 
   qed
   then have " \<not>?e2 \<Longrightarrow> False" using bigor_var not_eq
     by presburger (* Takes a second *) 
   then have " \<not>?e2 \<longrightarrow> False" using impI[of "\<not>?e2" "False"]
     by blast 
   then show ?thesis 
     by auto
 qed
 
 subsubsection "Some Cases and Misc"
 lemma quadratic_linear :
   assumes "b\<noteq>0"
   assumes "a \<noteq> 0"
   assumes "4 * a * ba \<le> aa\<^sup>2"
   assumes "b * (sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a) + c = 0"
   assumes "\<forall>x\<in>set eq.
           case x of
           (d, e, f) \<Rightarrow>
             d * ((sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a))\<^sup>2 +
             e * (sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a) +
             f =
             0"
   assumes "(aaa, aaaa, baa) \<in> set eq"
   shows "aaa * (c / b)\<^sup>2 - aaaa * c / b + baa = 0"
 proof-
   have h:  "-(c/b) = (sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a)"
     using assms
     by (smt divide_minus_left nonzero_mult_div_cancel_left times_divide_eq_right)
   have h1 : "\<forall>x\<in>set eq. case x of (d, e, f) \<Rightarrow> d * (c / b)\<^sup>2 + e * - (c / b) + f = 0"
     using assms(5) unfolding h[symmetric] Fields.division_ring_class.times_divide_eq_right[symmetric]
       Power.ring_1_class.power2_minus .
   show ?thesis  
     using bspec[OF h1 assms(6)] by simp
 qed
 
 lemma quadratic_linear1:  
   assumes "b\<noteq>0"
   assumes "a \<noteq> 0"
   assumes "4 * a * ba \<le> aa\<^sup>2"
   assumes "(b::real) * (sqrt ((aa::real)\<^sup>2 - 4 * (a::real) * (ba::real)) - (aa::real)) / (2 * a) + (c::real) = 0"
   assumes "
        (\<forall>x\<in>set (les::(real*real*real)list).
           case x of
           (d, e, f) \<Rightarrow>
             d * ((sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a))\<^sup>2 +
             e * (sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a) +
             f
             < 0)"
   assumes "(aaa, aaaa, baa) \<in> set les"
   shows "aaa * (c / b)\<^sup>2 - aaaa * c / b + baa < 0"
 proof-
   have h:  "-(c/b) = (sqrt (aa\<^sup>2 - 4 * a * ba) - aa) / (2 * a)"
     using assms
     by (smt divide_minus_left nonzero_mult_div_cancel_left times_divide_eq_right)
   have h1 : "\<forall>x\<in>set les. case x of (d, e, f) \<Rightarrow> d * (c / b)\<^sup>2 + e * - (c / b) + f < 0"
     using assms(5) unfolding h[symmetric] Fields.division_ring_class.times_divide_eq_right[symmetric]
       Power.ring_1_class.power2_minus .
   show ?thesis  
     using bspec[OF h1 assms(6)] by simp
 qed
 
 lemma quadratic_linear2 :
   assumes "b\<noteq>0"
   assumes "a \<noteq> 0"
   assumes "4 * a * ba \<le> aa\<^sup>2"
   assumes "b * (- aa -sqrt (aa\<^sup>2 - 4 * a * ba)) / (2 * a) + c = 0"
   assumes "\<forall>x\<in>set eq.
           case x of
           (d, e, f) \<Rightarrow>
             d * ((- aa -sqrt (aa\<^sup>2 - 4 * a * ba)) / (2 * a))\<^sup>2 +
             e * (- aa -sqrt (aa\<^sup>2 - 4 * a * ba)) / (2 * a) +
             f =
             0"
   assumes "(aaa, aaaa, baa) \<in> set eq"
   shows "aaa * (c / b)\<^sup>2 - aaaa * c / b + baa = 0"
 proof-
   have h:  "-((c::real)/(b::real)) = (- (aa::real) -sqrt (aa\<^sup>2 - 4 * (a::real) * (ba::real))) / (2 * a)"
     using assms
     by (smt divide_minus_left nonzero_mult_div_cancel_left times_divide_eq_right)
   have h1 : "\<forall>x\<in>set eq. case x of (d, e, f) \<Rightarrow> d * (c / b)\<^sup>2 + e * - (c / b) + f = 0"
     using assms(5) unfolding h[symmetric] Fields.division_ring_class.times_divide_eq_right[symmetric]
       Power.ring_1_class.power2_minus .
   show ?thesis  
     using bspec[OF h1 assms(6)] by simp
 qed
 
 lemma quadratic_linear3:  
   assumes "b\<noteq>0"
   assumes "a \<noteq> 0"
   assumes "4 * a * ba \<le> aa\<^sup>2"
   assumes "(b::real) * (- (aa::real)- sqrt ((aa::real)\<^sup>2 - 4 * (a::real) * (ba::real)) ) / (2 * a) + (c::real) = 0"
   assumes "(\<forall>x\<in>set (les::(real*real*real)list).
           case x of
           (d, e, f) \<Rightarrow>
             d * ((- aa - sqrt (aa\<^sup>2 - 4 * a * ba)) / (2 * a))\<^sup>2 +
             e * (- aa - sqrt (aa\<^sup>2 - 4 * a * ba)) / (2 * a) +
             f
             < 0)"
   assumes "(aaa, aaaa, baa) \<in> set les"
   shows "aaa * (c / b)\<^sup>2 - aaaa * c / b + baa < 0"
 proof-
   have h:  "-((c::real)/(b::real)) = (- (aa::real) -sqrt (aa\<^sup>2 - 4 * (a::real) * (ba::real))) / (2 * a)"
     using assms
     by (smt divide_minus_left nonzero_mult_div_cancel_left times_divide_eq_right)
   have h1 : "\<forall>x\<in>set les. case x of (d, e, f) \<Rightarrow> d * (c / b)\<^sup>2 + e * - (c / b) + f < 0"
     using assms(5) unfolding h[symmetric] Fields.division_ring_class.times_divide_eq_right[symmetric]
       Power.ring_1_class.power2_minus .
   show ?thesis  
     using bspec[OF h1 assms(6)] by simp
 qed
 
 
 lemma h1b_helper_les: 
   "(\<forall>((a::real), (b::real), (c::real))\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))"
 proof - 
   show "(\<forall>(a, b, c)\<in>set les. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set les. a * x\<^sup>2 + b * x + c < 0))" 
   proof (induct les)
     case Nil
     then show ?case
       by auto
   next
     case (Cons q les) 
     have ind: " \<forall>a\<in>set (q # les). case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c < 0"
       using Cons.prems
       by auto
     then have "case q of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c < 0 "
       by simp      
     then obtain y2 where y2_prop: "case q of (a, ba, c) \<Rightarrow>  (\<forall>y<y2. a * y\<^sup>2 + ba * y + c < 0)"
       by auto
     have "\<forall>a\<in>set les. case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c < 0"
       using ind by simp
     then have " \<exists>y. \<forall>x<y. \<forall>a\<in>set les. case a of (a, ba, c) \<Rightarrow> a * x\<^sup>2 + ba * x + c < 0"
       using Cons.hyps by blast 
     then obtain y1 where y1_prop: "\<forall>x<y1. \<forall>a\<in>set les. case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c < 0"
       by blast
     let ?y = "min y1 y2"
     have "\<forall>x < ?y.  (\<forall>a\<in>set (q #les). case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c < 0)"
       using y1_prop y2_prop 
       by fastforce 
     then show ?case
       by blast 
   qed
 qed
 
 lemma h1b_helper_leq: 
   "(\<forall>((a::real), (b::real), (c::real))\<in>set leq. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set leq. a * x\<^sup>2 + b * x + c \<le> 0))"
 proof - 
   show "(\<forall>(a, b, c)\<in>set leq. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set leq. a * x\<^sup>2 + b * x + c \<le> 0))" 
   proof (induct leq)
     case Nil
     then show ?case
       by auto
   next
     case (Cons q leq) 
     have ind: " \<forall>a\<in>set (q # leq). case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c \<le> 0"
       using Cons.prems
       by auto
     then have "case q of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c \<le> 0 "
       by simp      
     then obtain y2 where y2_prop: "case q of (a, ba, c) \<Rightarrow>  (\<forall>y<y2. a * y\<^sup>2 + ba * y + c \<le> 0)"
       by auto
     have "\<forall>a\<in>set leq. case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c \<le> 0"
       using ind by simp
     then have " \<exists>y. \<forall>x<y. \<forall>a\<in>set leq. case a of (a, ba, c) \<Rightarrow> a * x\<^sup>2 + ba * x + c \<le> 0"
       using Cons.hyps by blast 
     then obtain y1 where y1_prop: "\<forall>x<y1. \<forall>a\<in>set leq. case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c \<le> 0"
       by blast
     let ?y = "min y1 y2"
     have "\<forall>x < ?y.  (\<forall>a\<in>set (q #leq). case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c \<le> 0)"
       using y1_prop y2_prop 
       by fastforce 
     then show ?case
       by blast 
   qed
 qed
 
 lemma h1b_helper_neq: 
   "(\<forall>((a::real), (b::real), (c::real))\<in>set neq. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set neq. a * x\<^sup>2 + b * x + c \<noteq> 0))"
 proof - 
   show "(\<forall>(a, b, c)\<in>set neq. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) \<Longrightarrow> (\<exists>y.\<forall>x<y. (\<forall>(a, b, c)\<in>set neq. a * x\<^sup>2 + b * x + c \<noteq> 0))" 
   proof (induct neq)
     case Nil
     then show ?case
       by auto
   next
     case (Cons q neq) 
     have ind: " \<forall>a\<in>set (q # neq). case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c \<noteq> 0"
       using Cons.prems
       by auto
     then have "case q of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c \<noteq> 0 "
       by simp      
     then obtain y2 where y2_prop: "case q of (a, ba, c) \<Rightarrow>  (\<forall>y<y2. a * y\<^sup>2 + ba * y + c \<noteq> 0)"
       by auto
     have "\<forall>a\<in>set neq. case a of (a, ba, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + ba * y + c \<noteq> 0"
       using ind by simp
     then have " \<exists>y. \<forall>x<y. \<forall>a\<in>set neq. case a of (a, ba, c) \<Rightarrow> a * x\<^sup>2 + ba * x + c \<noteq> 0"
       using Cons.hyps by blast 
     then obtain y1 where y1_prop: "\<forall>x<y1. \<forall>a\<in>set neq. case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c \<noteq> 0"
       by blast
     let ?y = "min y1 y2"
     have "\<forall>x < ?y.  (\<forall>a\<in>set (q #neq). case a of (a, ba, c) \<Rightarrow> a * x^2 + ba * x + c \<noteq> 0)"
       using y1_prop y2_prop 
       by fastforce 
     then show ?case
       by blast 
   qed
 qed
 
 
 lemma min_lem: 
   fixes r::"real"
   assumes a1: "(\<exists>y'>r. (\<forall>((d::real), (e::real), (f::real))\<in>set b. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f < 0))" 
   assumes a2: "(\<exists>y'>r. (\<forall>((d::real), (e::real), (f::real))\<in>set c. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<le> 0))"
   assumes a3: "(\<exists>y'>r. (\<forall>((d::real), (e::real), (f::real))\<in>set d. \<forall>x\<in>{r<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
 proof - 
   obtain y1 where y1_prop: "y1 > r \<and> (\<forall>(d, e, f)\<in>set b.  \<forall>x\<in>{r<..y1}. d * x\<^sup>2 + e * x + f < 0)"
     using a1 by auto
   obtain y2 where y2_prop: "y2 > r \<and> (\<forall>(d, e, f)\<in>set c.  \<forall>x\<in>{r<..y2}. d * x\<^sup>2 + e * x + f \<le> 0)"
     using a2 by auto
   obtain y3 where y3_prop: "y3 > r \<and> (\<forall>(d, e, f)\<in>set d.  \<forall>x\<in>{r<..y3}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
     using a3 by auto
   let ?y = "(min (min y1 y2) y3)"
   have "?y > r" using y1_prop y2_prop y3_prop by auto
   then have "\<exists>x. x > r \<and> x < ?y" using dense[of r ?y] 
     by auto
   then obtain x where x_prop: "x > r \<and> x < ?y" by auto
   have bp: "(\<forall>(a, b, c)\<in>set b. a *x\<^sup>2 + b * x + c < 0)"  
     using x_prop y1_prop by auto 
   have cp: "(\<forall>(a, b, c)\<in>set c. a * x^2 + b * x + c \<le> 0)"  
     using x_prop y2_prop by auto 
   have dp: "(\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)"  
     using x_prop y3_prop by auto 
   then have  "(\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)"
     using  bp cp dp by auto
   then show ?thesis by auto
 qed 
 
 lemma qe_infinitesimals_helper:
   fixes k::"real"
   assumes asm: "(\<forall>(d, e, f)\<in>set a. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. \<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
   shows "(\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
 proof -
   have "\<forall>(d, e, f)\<in>set a. d = 0 \<and> e = 0 \<and> f = 0" 
   proof clarsimp 
     fix d e f
     assume "(d, e, f) \<in> set a"
     then have "\<exists>y'>k. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0"
       using asm by auto
     then obtain y' where y_prop: "y'>k \<and> (\<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f = 0)"
       by auto
     then show "d = 0 \<and> e = 0 \<and> f = 0" using continuity_lem_eq0[of "k" "y'" d e f]
       by auto
   qed
   then have eqprop: "\<forall>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) "
     by auto
   have lesprop: "(\<exists>y'>k. (\<forall>(d, e, f)\<in>set b. \<forall>x\<in>{k<..y'}. d * x\<^sup>2 + e * x + f < 0))" 
     using les_qe_inf_helper[of b "k"] asm 
     by blast 
   have leqprop: "(\<exists>y'>k. (\<forall>(d, e, f)\<in>set c. \<forall>x\<in>{(k)<..y'}. d * x\<^sup>2 + e * x + f \<le> 0))" 
     using leq_qe_inf_helper[of c "k"] asm 
     by blast 
   have neqprop: "(\<exists>y'>(k). (\<forall>(d, e, f)\<in>set d. \<forall>x\<in>{(k)<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))" 
     using neq_qe_inf_helper[of d "k"] asm 
     by blast  
   then have "(\<exists>x. (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)) " 
     using lesprop leqprop neqprop min_lem[of "k" b c d]
     by auto
   then show ?thesis
     using eqprop by auto 
 qed
 
 subsubsection "The qe\\_backwards lemma"
 lemma qe_backwards: 
   assumes "(((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) 
      \<or>
      (\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)        
           \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))) 
     \<or>
      (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) 
     \<or>
      (\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))) 
       \<or>
      (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))))"
   shows " (\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))" 
 proof - 
   let ?e2 = "(((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) 
      \<or>
      (\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)         
           \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))) 
     \<or>
      (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) 
     \<or>
      (\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))) 
       \<or>
      (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))))"
   let ?f10orf11orf12 = "(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f8orf9 = "(\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   let ?f5orf6orf7 = "(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) 
       \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f2orf3orf4 = "(\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) 
         \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)         
           \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   let ?e1 = "(\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
   let ?f1 = "((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0))"
   let ?f2 = "(\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
   let ?f3 = "(\<exists>(a', b', c')\<in>set a. a' \<noteq> 0 \<and> - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))"
   let ?f4 = "(\<exists>(a', b', c')\<in>set a. a' \<noteq> 0 \<and> - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
  (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)) "
   let ?f5 = "(\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   let ?f6 = "(\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f7 = "(\<exists>(a', b', c')\<in>set b. a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   let ?f8 = "(\<exists>(a', b', c')\<in>set c. (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0))"
   let ?f13 = "(\<exists>(a', b', c')\<in>set c.
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0)))"
   let ?f9 = "(\<exists>(a', b', c')\<in>set c.  a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
         (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq> 0))"
   let ?f10 = "(\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0))"
   let ?f11 = "(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
   let ?f12 = "(\<exists>(a', b', c')\<in>set d.
           a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))"
   have h1a: "?e2 \<longrightarrow> (?f1 \<or> ?f2orf3orf4 \<or> ?f5orf6orf7 \<or> ?f8orf9 \<or> ?f10orf11orf12)"
     by auto
   have h2: "?f2orf3orf4 \<longrightarrow> (?f2 \<or> ?f3 \<or> ?f4)" by auto
   then have h1b: "?e2 \<longrightarrow> (?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5orf6orf7 \<or> ?f8orf9 \<or> ?f10orf11orf12) "
     using h1a by auto
   have h3: "?f5orf6orf7 \<longrightarrow> (?f5 \<or> ?f6 \<or> ?f7)" by auto
   then have h1c: "?e2 \<longrightarrow> (?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8orf9 \<or> ?f10orf11orf12) "
     using h1b by smt 
   have h4: "?f8orf9 \<longrightarrow> (?f8 \<or> ?f9 \<or> ?f13)" by auto
   then have h1d: "?e2 \<longrightarrow> (?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8 \<or> ?f9 \<or> ?f13 \<or> ?f10orf11orf12) "
     using h1c
     by smt 
   have h5: "?f10orf11orf12 \<longrightarrow> (?f10 \<or> ?f11 \<or> ?f12)" 
     by auto
   then have bigor: "?e2 \<longrightarrow> (?f1 \<or> ?f2 \<or> ?f3 \<or> ?f4 \<or> ?f5 \<or> ?f6 \<or> ?f7 \<or> ?f8 \<or> ?f13 \<or> ?f9 \<or> ?f10 \<or> ?f11 \<or> ?f12) "
     using h1d  by smt 
   have "?f1 \<Longrightarrow> ?e1"
   proof - 
     assume asm: "(\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
     (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
     (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
     (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0)"
     then have eqprop: "\<forall>x. \<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0" by auto
     have "\<exists>y. \<forall>x<y. \<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0"
       using asm h1b_helper_les by auto
     then obtain y1 where y1_prop: "\<forall>x<y1. \<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0" by auto
     have "\<exists>y. \<forall>x<y. \<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0"
       using asm h1b_helper_leq by auto
     then obtain y2 where y2_prop: "\<forall>x<y2. \<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0" by auto
     have "\<exists>y. \<forall>x<y. \<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0"
       using asm h1b_helper_neq by auto
     then obtain y3 where y3_prop: "\<forall>x<y3. \<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0" by auto
     let ?y = "(min (min y1 y2) y3) - 1"
     have y_prop: "?y < y1 \<and> ?y < y2 \<and> ?y < y3"
       by auto
     have ap: "(\<forall>(a, b, c)\<in>set a. a * ?y\<^sup>2 + b * ?y + c = 0)" 
       using eqprop by auto
     have bp: "(\<forall>(a, b, c)\<in>set b. a * ?y\<^sup>2 + b * ?y + c < 0)"  
       using y_prop y1_prop by auto 
     have cp: "(\<forall>(a, b, c)\<in>set c. a * ?y\<^sup>2 + b * ?y + c \<le> 0)"  
       using y_prop y2_prop by auto 
     have dp: "(\<forall>(a, b, c)\<in>set d. a * ?y\<^sup>2 + b * ?y + c \<noteq> 0)"  
       using y_prop y3_prop by auto 
     then have  "(\<forall>(a, b, c)\<in>set a. a * ?y\<^sup>2 + b * ?y + c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. a * ?y\<^sup>2 + b * ?y + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * ?y\<^sup>2 + b * ?y + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * ?y\<^sup>2 + b * ?y + c \<noteq> 0)"
       using ap bp cp dp by auto
     then show ?thesis by auto
   qed
   then have h1: "?f1 \<longrightarrow> ?e1" 
     by auto
   have "?f2 \<Longrightarrow> ?e1" 
   proof - 
     assume " \<exists>(a', b', c')\<in>set a.
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set a \<and>
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)"
       by auto
     then have "\<exists>(x::real). x = -c'/b'" by auto
     then obtain x where x_prop: "x = - c' / b'" by auto
     then have "(\<forall>xa\<in>set a. case xa of (a, b, c) \<Rightarrow> a * x\<^sup>2 + b * x + c = 0) \<and>
         (\<forall>xa\<in>set b. case xa of (a, b, c) \<Rightarrow> a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>xa\<in>set c. case xa of (a, b, c) \<Rightarrow> a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>xa\<in>set d. case xa of (a, b, c) \<Rightarrow> a * x\<^sup>2 + b * x + c \<noteq> 0)"
       using abc_prop by auto
     then show ?thesis by auto
   qed
   then have h2: "?f2 \<longrightarrow> ?e1" 
     by auto
   have "?f3 \<Longrightarrow> ?e1" 
   proof -
     assume "\<exists>(a', b', c')\<in>set a.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f  \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set a \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f  \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)" by auto
     then have "\<exists>(x::real). x = (- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then obtain x where x_prop: " x = (- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then have "(\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" using abc_prop by auto
     then show ?thesis by auto
   qed
   then have h3: "?f3  \<longrightarrow> ?e1" 
     by auto
   have "?f4 \<Longrightarrow> ?e1" 
   proof -
     assume " \<exists>(a', b', c')\<in>set a.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set a \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)" by auto
     then have "\<exists>(x::real). x = (- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then obtain x where x_prop: " x = (- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then have "(\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" using abc_prop by auto
     then show ?thesis by auto
   qed
   then have "?f4 \<longrightarrow> ?e1" by auto
   have "?f5 \<Longrightarrow> ?e1" 
   proof - 
     assume asm: "\<exists>(a', b', c')\<in>set b.
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set b \<and>
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
       by auto
     then show ?thesis using qe_infinitesimals_helper[of a "- c' / b'" b c d]
       by auto
   qed
   then have h5: "?f5 \<longrightarrow> ?e1" 
     by auto
   have "?f6 \<Longrightarrow> ?e1" 
   proof - 
     assume "\<exists>(a', b', c')\<in>set b.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set b \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)" by auto
     then show ?thesis using qe_infinitesimals_helper[of a "(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" b c d]
       by auto
   qed
   then have h6: "?f6  \<longrightarrow> ?e1" 
     by auto
   have "?f7 \<Longrightarrow> ?e1" 
   proof - 
     assume "\<exists>(a', b', c')\<in>set b.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set b \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)"
       by auto
     then show ?thesis using qe_infinitesimals_helper[of a "(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" b c d]
       by auto
   qed
   then have h7: "?f7 \<longrightarrow> ?e1"
     by auto
   have "?f8 \<Longrightarrow> ?e1"   
   proof -
     assume "\<exists>(a', b', c')\<in>set c.
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and>
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0)" by auto
     then have "\<exists>(x::real). x = (- c' / b')" by auto
     then obtain x where x_prop: " x = - c' / b'" by auto
     then have "(\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" using abc_prop by auto
     then show ?thesis by auto
   qed
   then have h8: "?f8 \<longrightarrow> ?e1" by auto
   have "?f9 \<Longrightarrow> ?e1" 
   proof -
     assume "\<exists>(a', b', c')\<in>set c.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f =  0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f =  0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f  < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq>  0)" by auto
     then have "\<exists>(x::real). x = (- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then obtain x where x_prop: " x = (- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then have "(\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" using abc_prop by auto
     then show ?thesis by auto
   qed
   then have h9:  "?f9 \<longrightarrow> ?e1" by auto
   have "?f10 \<Longrightarrow> ?e1"
   proof - 
     assume asm: "\<exists>(a', b', c')\<in>set d.
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set d \<and>
        (a' = 0 \<and> b' \<noteq> 0) \<and>
        (\<forall>(d, e, f)\<in>set a. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d. \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0)"
       by auto
     then show ?thesis using qe_infinitesimals_helper[of a "- c' / b'" b c d]
       by auto
   qed
   then have h10: "?f10 \<longrightarrow> ?e1" by auto
   have "?f11 \<Longrightarrow> ?e1"   
   proof - 
     assume "\<exists>(a', b', c')\<in>set d.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set d \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)" by auto
     then show ?thesis using qe_infinitesimals_helper[of a "(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" b c d]
       by auto
   qed
   then have h11: "?f11 \<longrightarrow> ?e1" by auto
   have "?f12 \<Longrightarrow> ?e1"  proof - 
     assume "\<exists>(a', b', c')\<in>set d.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set d \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
               \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                  d * x\<^sup>2 + e * x + f \<noteq> 0)"
       by auto
     then show ?thesis using qe_infinitesimals_helper[of a "(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" b c d]
       by auto
   qed
   then have h12: "?f12 \<longrightarrow> ?e1" by auto
   have "?f13 \<Longrightarrow> ?e1" proof -
     assume " \<exists>(a', b', c')\<in>set c.
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)"
     then obtain a' b' c' where abc_prop: "(a', b', c')\<in>set c \<and>
        a' \<noteq> 0 \<and>
        - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
        (\<forall>(d, e, f)\<in>set a.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f = 0) \<and>
        (\<forall>(d, e, f)\<in>set b.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f < 0) \<and>
        (\<forall>(d, e, f)\<in>set c.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<le> 0) \<and>
        (\<forall>(d, e, f)\<in>set d.
            d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
            e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
            f \<noteq> 0)" by auto
     then have "\<exists>(x::real). x = (- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then obtain x where x_prop: " x = (- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')" by auto
     then have "(\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
         (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
         (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
         (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)" using abc_prop by auto
     then show ?thesis by auto
   qed
   then have h13: "?f13 \<longrightarrow> ?e1" by auto
   show ?thesis using bigor h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13
     using assms
     by (smt \<open>\<exists>(a', b', c')\<in>set a. a' \<noteq> 0 \<and> - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and> (\<forall>(d, e, f)\<in>set a. d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 + e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) + f = 0) \<and> (\<forall>(d, e, f)\<in>set b. d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 + e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) + f < 0) \<and> (\<forall>(d, e, f)\<in>set c. d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 + e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) + f \<le> 0) \<and> (\<forall>(d, e, f)\<in>set d. d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 + e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) + f \<noteq> 0) \<Longrightarrow> \<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and> (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and> (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and> (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)\<close>) 
       (* by force *)
 qed
 
 subsection "General QE lemmas"
 
 lemma qe: "(\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0)) =
     ((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) \<or>
      (\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0))) \<or>
      (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) \<or>
      (\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0))) \<or>
      (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))))" 
 proof - 
   let ?e1 = "((\<forall>(a, b, c)\<in>set a. a = 0 \<and> b = 0 \<and> c = 0) \<and>
      (\<forall>(a, b, c)\<in>set b. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<and>
      (\<forall>(a, b, c)\<in>set c. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<and>
      (\<forall>(a, b, c)\<in>set d. \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<noteq> 0) \<or>
      (\<exists>(a', b', c')\<in>set a.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0))) \<or>
      (\<exists>(a', b', c')\<in>set b.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))) \<or>
      (\<exists>(a', b', c')\<in>set c.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d. d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f =
               0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f
               \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
               e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
               f \<noteq>
               0))) \<or>
      (\<exists>(a', b', c')\<in>set d.
          (a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set a.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set b.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set c.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set d.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set a.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set b.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set c.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set d.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0))))" 
   let ?e2 = "(\<exists>x. (\<forall>(a, b, c)\<in>set a. a * x\<^sup>2 + b * x + c = 0) \<and>
          (\<forall>(a, b, c)\<in>set b. a * x\<^sup>2 + b * x + c < 0) \<and>
          (\<forall>(a, b, c)\<in>set c. a * x\<^sup>2 + b * x + c \<le> 0) \<and>
          (\<forall>(a, b, c)\<in>set d. a * x\<^sup>2 + b * x + c \<noteq> 0))"
   have h1: "?e1 \<longrightarrow> ?e2" using qe_backwards 
     by auto
   have h2: "?e2 \<longrightarrow> ?e1" using qe_forwards
     by auto
   have "(?e2 \<longrightarrow> ?e1) \<and> (?e1 \<longrightarrow> ?e2) " using h1 h2
     by force 
   then have  "?e2 \<longleftrightarrow> ?e1"
     using iff_conv_conj_imp[of ?e1 ?e2]
     by presburger
   then show ?thesis
     by auto
 qed
 
 
 fun eq_fun :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real*real*real) list \<Rightarrow> (real*real*real) list \<Rightarrow> (real*real*real) list \<Rightarrow> (real*real*real) list \<Rightarrow> bool" where
   "eq_fun a' b' c' eq les leq neq = ((a' = 0 \<and> b' \<noteq> 0) \<and>
           (\<forall>a\<in>set eq.
               case a of (d, e, f) \<Rightarrow> d * (- c' / b')\<^sup>2 + e * (- c' / b') + f = 0) \<and>
           (\<forall>a\<in>set les.
               case a of (d, e, f) \<Rightarrow> d * (- c' / b')\<^sup>2 + e * (- c' / b') + f < 0) \<and>
           (\<forall>a\<in>set leq.
               case a of (d, e, f) \<Rightarrow> d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<le> 0) \<and>
           (\<forall>a\<in>set neq.
               case a of (d, e, f) \<Rightarrow> d * (- c' / b')\<^sup>2 + e * (- c' / b') + f \<noteq> 0) \<or>
           a' \<noteq> 0 \<and>
           - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
           ((\<forall>a\<in>set eq.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f =
                  0) \<and>
            (\<forall>a\<in>set les.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f
                  < 0) \<and>
            (\<forall>a\<in>set leq.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f
                  \<le> 0) \<and>
            (\<forall>a\<in>set neq.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f \<noteq>
                  0) \<or>
            (\<forall>a\<in>set eq.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f =
                  0) \<and>
            (\<forall>a\<in>set les.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f
                  < 0) \<and>
            (\<forall>a\<in>set leq.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f
                  \<le> 0) \<and>
            (\<forall>a\<in>set neq.
                case a of
                (d, e, f) \<Rightarrow>
                  d * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a'))\<^sup>2 +
                  e * ((- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')) +
                  f \<noteq>
                  0)))"
 
 fun les_fun :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real*real*real) list \<Rightarrow> (real*real*real) list \<Rightarrow> (real*real*real) list \<Rightarrow> (real*real*real) list \<Rightarrow> bool" where 
   "les_fun a' b' c' eq les leq neq = ((a' = 0 \<and> b' \<noteq> 0) \<and>
          (\<forall>(d, e, f)\<in>set eq.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f = 0) \<and>
          (\<forall>(d, e, f)\<in>set les.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f < 0) \<and>
          (\<forall>(d, e, f)\<in>set leq.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<le> 0) \<and>
          (\<forall>(d, e, f)\<in>set neq.
              \<exists>y'>- c' / b'. \<forall>x\<in>{- c' / b'<..y'}. d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
          a' \<noteq> 0 \<and>
          - b'\<^sup>2 + 4 * a' * c' \<le> 0 \<and>
          ((\<forall>(d, e, f)\<in>set eq.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set leq.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set neq.
               \<exists>y'>(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0) \<or>
           (\<forall>(d, e, f)\<in>set eq.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f = 0) \<and>
           (\<forall>(d, e, f)\<in>set les.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f < 0) \<and>
           (\<forall>(d, e, f)\<in>set leq.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<le> 0) \<and>
           (\<forall>(d, e, f)\<in>set neq.
               \<exists>y'>(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a').
                  \<forall>x\<in>{(- b' + - 1 * sqrt (b'\<^sup>2 - 4 * a' * c')) / (2 * a')<..y'}.
                     d * x\<^sup>2 + e * x + f \<noteq> 0)))"
 
 lemma general_qe' :
   (* Direct substitution F(x) *)
   assumes "F = (\<lambda>x. 
                (\<forall>(a,b,c)\<in>set eq . a*x\<^sup>2+b*x+c=0)\<and>
                (\<forall>(a,b,c)\<in>set les. a*x\<^sup>2+b*x+c<0)\<and>
                (\<forall>(a,b,c)\<in>set leq. a*x\<^sup>2+b*x+c\<le>0)\<and>
                (\<forall>(a,b,c)\<in>set neq. a*x\<^sup>2+b*x+c\<noteq>0))"
     (* Substitution of r+\<epsilon> into F *)
   assumes "F\<epsilon> = (\<lambda>r. 
          (\<forall>(a,b,c)\<in>set eq.  \<exists>y>r.\<forall>x\<in>{r<..y}. a*x\<^sup>2+b*x+c=0) \<and>
          (\<forall>(a,b,c)\<in>set les. \<exists>y>r.\<forall>x\<in>{r<..y}. a*x\<^sup>2+b*x+c<0) \<and>
          (\<forall>(a,b,c)\<in>set leq. \<exists>y>r.\<forall>x\<in>{r<..y}. a*x\<^sup>2+b*x+c\<le>0) \<and>
          (\<forall>(a,b,c)\<in>set neq. \<exists>y>r.\<forall>x\<in>{r<..y}. a*x\<^sup>2+b*x+c\<noteq>0)
         )"
     (* Substitution of -\<infinity> into F *)
   assumes "F\<^sub>i\<^sub>n\<^sub>f = (
      (\<forall>(a,b,c)\<in>set eq.  \<exists>x. \<forall>y<x. a*y\<^sup>2+b*y+c=0) \<and>
      (\<forall>(a,b,c)\<in>set les. \<exists>x. \<forall>y<x. a*y\<^sup>2+b*y+c<0) \<and>
      (\<forall>(a,b,c)\<in>set leq. \<exists>x. \<forall>y<x. a*y\<^sup>2+b*y+c\<le>0) \<and>
      (\<forall>(a,b,c)\<in>set neq. \<exists>x. \<forall>y<x. a*y\<^sup>2+b*y+c\<noteq>0)
     )"
     (* finds linear or quadratic roots of a polynomial *)
   assumes "roots = (\<lambda>(a,b,c).
      if a=0 \<and> b\<noteq>0 then {-c/b}::real set else
      if a\<noteq>0 \<and> b\<^sup>2-4*a*c\<ge>0 then {(-b+sqrt(b\<^sup>2-4*a*c))/(2*a)}\<union>{(-b-sqrt(b\<^sup>2-4*a*c))/(2*a)} else {})"
     (* all the root of each atom *)
   assumes "A = \<Union>(roots ` (set eq))"
   assumes "B = \<Union>(roots ` (set les))"
   assumes "C = \<Union>(roots ` (set leq))"
   assumes "D = \<Union>(roots ` (set neq))"
     (* Quantifier Elimination *)
   shows "(\<exists>x. F(x)) = (F\<^sub>i\<^sub>n\<^sub>f\<or>(\<exists>r\<in>A. F r)\<or>(\<exists>r\<in>B. F\<epsilon> r)\<or>(\<exists>r\<in>C. F r)\<or>(\<exists>r\<in>D. F\<epsilon> r))"
 proof-
   { fix X
     have "(\<exists>(a, b, c)\<in>set X. eq_fun a b c eq les leq neq) = (\<exists>x\<in>F ` \<Union>(roots ` (set X)). x)"
     proof(induction X)
       case Nil
       then show ?case by auto
     next
       case (Cons p X)
       have h1: "(\<exists>x\<in>F ` \<Union> (roots ` set (p # X)). x) = ((\<exists>x\<in>F ` roots p. x) \<or> (\<exists>x\<in>F ` \<Union> (roots ` set X). x))"
         by auto
       have h2 :"(case p of (a,b,c) \<Rightarrow> eq_fun a b c eq les leq neq) = (\<exists>x\<in>F ` roots p. x)"
         apply(cases p) unfolding assms apply simp by linarith
       show ?case  unfolding h1 Cons[symmetric] using h2 by auto
     qed
   }
   then have eq : "\<And>X. (\<exists>(a, b, c)\<in>set X. eq_fun a b c eq les leq neq) = (\<exists>x\<in>F ` \<Union> (roots ` set X). x)" by auto
   { fix X
     have "(\<exists>(a, b, c)\<in>set X. les_fun a b c eq les leq neq) = (\<exists>x\<in>F\<epsilon> ` \<Union>(roots ` (set X)). x)"
     proof(induction X)
       case Nil
       then show ?case by auto
     next
       case (Cons p X)
       have h1: "(\<exists>x\<in>F\<epsilon> ` \<Union> (roots ` set (p # X)). x) = ((\<exists>x\<in>F\<epsilon> ` roots p. x) \<or> (\<exists>x\<in>F\<epsilon> ` \<Union> (roots ` set X). x))"
         by auto
       have h2 :"(case p of (a,b,c) \<Rightarrow> les_fun a b c eq les leq neq) = (\<exists>x\<in>F\<epsilon> ` roots p. x)"
         apply(cases p) unfolding assms apply simp by linarith
       show ?case  unfolding h1 Cons[symmetric] using h2 by auto
     qed
   }
   then have les : "\<And>X. (\<exists>(a, b, c)\<in>set X. les_fun a b c eq les leq neq) = (\<exists>x\<in>F\<epsilon> ` \<Union> (roots ` set X). x)" by auto
   have inf : "(\<forall>(a, b, c)\<in>set eq. a = 0 \<and> b = 0 \<and> c = 0) = (\<forall>x\<in>set eq. case x of (a, b, c) \<Rightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)"
   proof(induction eq)
     case Nil
     then show ?case by auto
   next
     case (Cons p eq)
     then show ?case proof(cases p)
       case (fields a b c)
       show ?thesis unfolding fields using infzeros[of _ a b c] Cons by auto
     qed
   qed
   show ?thesis
     using qe[of "eq" "les" "leq" "neq"]
     using eq[of eq] eq[of leq] les[of les] les[of neq] unfolding inf assms
     by auto
 qed
 
 lemma general_qe'' :
   (* Direct substitution F(x) *)
   assumes "S = {(=), (<), (\<le>), (\<noteq>)}"
   assumes "finite (X (=))"
   assumes "finite (X (<))"
   assumes "finite (X (\<le>))"
   assumes "finite (X (\<noteq>))"
   assumes "F = (\<lambda>x. \<forall>rel\<in>S. \<forall>(a,b,c)\<in>(X rel). rel (a*x\<^sup>2+b*x+c) 0)"
     (* Substitution of r+\<epsilon> into F *)
   assumes "F\<epsilon> = (\<lambda>r. \<forall>rel\<in>S. \<forall>(a,b,c)\<in>(X rel). \<exists>y>r.\<forall>x\<in>{r<..y}. rel (a*x\<^sup>2+b*x+c) 0)"
     (* Substitution of -\<infinity> into F *)
   assumes "F\<^sub>i\<^sub>n\<^sub>f = (\<forall>rel\<in>S. \<forall>(a,b,c)\<in>(X rel). \<exists>x. \<forall>y<x. rel (a*y\<^sup>2+b*y+c) 0)"
     (* finds linear or quadratic roots of a polynomial *)
   assumes "roots = (\<lambda>(a,b,c).
      if a=0 \<and> b\<noteq>0 then {-c/b}::real set else
      if a\<noteq>0 \<and> b\<^sup>2-4*a*c\<ge>0 then {(-b+sqrt(b\<^sup>2-4*a*c))/(2*a)}\<union>{(-b-sqrt(b\<^sup>2-4*a*c))/(2*a)} else {})"
     (* all the root of each atom *)
   assumes "A = \<Union>(roots ` ((X (=))))"
   assumes "B = \<Union>(roots ` ((X (<))))"
   assumes "C = \<Union>(roots ` ((X (\<le>))))"
   assumes "D = \<Union>(roots ` ((X (\<noteq>))))"
     (* Quantifier Elimination *)
   shows "(\<exists>x. F(x)) = (F\<^sub>i\<^sub>n\<^sub>f\<or>(\<exists>r\<in>A. F r)\<or>(\<exists>r\<in>B. F\<epsilon> r)\<or>(\<exists>r\<in>C. F r)\<or>(\<exists>r\<in>D. F\<epsilon> r))"
 proof-
   define less where "less = (\<lambda>(a::real,b::real,c::real).\<lambda>(a',b',c'). a<a'\<or> (a=a'\<and> (b<b'\<or>(b=b'\<and>c<c'))))"
   define leq where "leq = (\<lambda>x.\<lambda>y. x=y \<or> less x y)"
   have linorder: "class.linorder leq less"
     unfolding class.linorder_def class.order_def class.preorder_def class.order_axioms_def class.linorder_axioms_def
       less_def leq_def by auto
   show ?thesis
     using assms(6-8) unfolding assms(1) apply simp
     using general_qe'[OF _ _ _ assms(9), of F "List.linorder.sorted_list_of_set leq (X (=))" "List.linorder.sorted_list_of_set leq (X (<))" "List.linorder.sorted_list_of_set leq (X (\<le>))" "List.linorder.sorted_list_of_set leq (X (\<noteq>))" F\<epsilon> F\<^sub>i\<^sub>n\<^sub>f A B C D]
     unfolding List.linorder.set_sorted_list_of_set[OF linorder assms(2)] List.linorder.set_sorted_list_of_set[OF linorder assms(3)] List.linorder.set_sorted_list_of_set[OF linorder assms(4)] List.linorder.set_sorted_list_of_set[OF linorder assms(5)]
     using assms(10-13)by auto
 qed
 
 
 theorem general_qe :
   (* finite sets of atoms involving = < \<le> and \<noteq>*)
   assumes "R = {(=), (<), (\<le>), (\<noteq>)}"
   assumes "\<forall>rel\<in>R. finite (Atoms rel)"
     (* Direct substitution F(x) *)
   assumes "F = (\<lambda>x. \<forall>rel\<in>R. \<forall>(a,b,c)\<in>(Atoms rel). rel (a*x\<^sup>2+b*x+c) 0)"
     (* Substitution of r+\<epsilon> into F *)
   assumes "F\<epsilon> = (\<lambda>r. \<forall>rel\<in>R. \<forall>(a,b,c)\<in>(Atoms rel). \<exists>y>r.\<forall>x\<in>{r<..y}. rel (a*x\<^sup>2+b*x+c) 0)"
     (* Substitution of -\<infinity> into F *)
   assumes "F\<^sub>i\<^sub>n\<^sub>f = (\<forall>rel\<in>R. \<forall>(a,b,c)\<in>(Atoms rel). \<exists>x. \<forall>y<x. rel (a*y\<^sup>2+b*y+c) 0)"
     (* finds linear or quadratic roots of a polynomial *)
   assumes "roots = (\<lambda>(a,b,c).
      if a=0 \<and> b\<noteq>0 then {-c/b} else
      if a\<noteq>0 \<and> b\<^sup>2-4*a*c\<ge>0 then {(-b+sqrt(b\<^sup>2-4*a*c))/(2*a)}\<union>{(-b-sqrt(b\<^sup>2-4*a*c))/(2*a)} else {})"
     (* Quantifier Elimination *)
   shows "(\<exists>x. F(x)) = 
             (F\<^sub>i\<^sub>n\<^sub>f \<or>
             (\<exists>r\<in>\<Union>(roots ` (Atoms (=) \<union> Atoms (\<le>))). F r) \<or>
             (\<exists>r\<in>\<Union>(roots ` (Atoms (<) \<union> Atoms (\<noteq>))). F\<epsilon> r))"
   using general_qe''[OF assms(1) _ _ _ _ assms(3-6) refl refl refl refl]
   using assms(2) unfolding assms(1) 
   by auto
 
 end
\ No newline at end of file
diff --git a/thys/Virtual_Substitution/QuadraticCase.thy b/thys/Virtual_Substitution/QuadraticCase.thy
--- a/thys/Virtual_Substitution/QuadraticCase.thy
+++ b/thys/Virtual_Substitution/QuadraticCase.thy
@@ -1,969 +1,947 @@
 subsection "Quadratic Case"
 theory QuadraticCase
   imports VSAlgos
 begin
 
 (*-------------------------------------------------------------------------------------------------------------*)
 lemma quad_part_1_eq :
   assumes lLength : "length L > var"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg::nat)"
   assumes nonzero : "D \<noteq> 0"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) a = (A::real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) b = (B::real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) d = (D::real)"
   shows "aEval (Eq p) (list_update L var ((A+B*C)/D)) = aEval (Eq(quadratic_part_1 var a b d (Eq p))) (list_update L var C)"
 proof - 
   define f where "f i = insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)" for i
   have h1 : "\<forall>i. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i)) = (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) (isolate_variable_sparse p var i))"
     by(simp add: insertion_isovarspars_free)
   have h2 : "((\<Sum>i = 0..<deg+1. f i / D ^ i) = 0) =((\<Sum>i = 0..<deg+1. (f i) * D ^ (deg - i)) = 0)"
     using normalize_summation nonzero by(auto)
   have "aEval (Eq(quadratic_part_1 var a b d (Eq p))) (list_update L var C) = 
       ((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)) * D ^ (deg - i)) = 0)"
     by(simp add: hdeg insertion_sum insertion_add insertion_mult insertion_var insertion_pow ha hb hd lLength)
   also have "... =((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)) / D ^ i) = 0)"
     using f_def h2 by auto
   also have "... =((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C)^i / (D ^ i)))) = 0)"
     by auto
   also have "... =((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C)/D) ^ i)) = 0)"
     by (metis (no_types, lifting) power_divide sum.cong)
   also have "... =((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) (isolate_variable_sparse p var i) * ((A + B * C)/D) ^ i))=0)"
     using h1 by auto 
   also have "... = (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) p =0)"
     using sum_over_degree_insertion hdeg lLength by auto
   also have "... = aEval (Eq p) (list_update L var ((A+B*C)/D))"
     using aEval.simps(1) by blast
   finally show ?thesis using assms by auto
 qed
 
 
 (*------------------------------------------------------------------------------------------------*)
 lemma quad_part_1_less :
   assumes lLength : "length L > var"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg::nat)"
   assumes nonzero : "D \<noteq> 0"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) a = (A::real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) b = (B::real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) d = (D::real)"
   shows "aEval (Less p) (list_update L var ((A+B*C)/D)) = aEval (Less(quadratic_part_1 var a b d (Less p))) (list_update L var C)"
 proof - 
   define f where "f i = insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)" for i
   have h1a : "((\<Sum>i = 0..<deg+1. f i / D ^ i) < 0) =((\<Sum>i = 0..<deg+1. (f i) * D ^ (deg - i))  * D ^ (deg mod 2) < 0)"
     using normalize_summation_less nonzero by(auto)
   have h4a : "\<forall>i. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i)) = (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) (isolate_variable_sparse p var i))"
     by(simp add: insertion_isovarspars_free)
   have "((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)) * D ^ (deg - i)) * D ^ (deg mod 2) < 0)
         =((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)) / D ^ i) < 0)"
     using h1a f_def by auto
   also have "...=((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C)^i / (D ^ i)))) < 0)"
     by auto
   also have "...=((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C)/D) ^ i)) < 0)"
     by (metis (no_types, lifting) power_divide sum.cong)
   also have "... =((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var ((A+B*C)/D)))  (isolate_variable_sparse p var i) * ((A + B * C)/D) ^ i))<0)"
     using h4a
     by auto 
   also have "... = (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) p <0)"
     using sum_over_degree_insertion hdeg lLength by auto
   finally show ?thesis
     by(simp add: hdeg lLength insertion_add insertion_mult ha hb hd insertion_sum insertion_pow insertion_var)
 qed
 
 (*------------------------------------------------------------------------------------------------*)
 lemma quad_part_1_leq :
   assumes lLength : "length L > var"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg::nat)"
   assumes nonzero : "D \<noteq> 0"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) a = (A::real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) b = (B::real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) d = (D::real)"
   shows "aEval (Leq p) (list_update L var ((A+B*C)/D)) = aEval (Leq(quadratic_part_1 var a b d (Leq p))) (list_update L var C)"
 proof - 
   define f where "f i = insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)" for i
   have h1a : "((\<Sum>i = 0..<deg+1. f i / D ^ i) < 0) =((\<Sum>i = 0..<deg+1. (f i) * D ^ (deg - i))  * D ^ (deg mod 2) < 0)"
     using normalize_summation_less nonzero by(auto)
   have h1b : "((\<Sum>i = 0..<deg+1. f i / D ^ i) = 0) =((\<Sum>i = 0..<deg+1. (f i) * D ^ (deg - i)) = 0)"
     using normalize_summation nonzero by(auto)
   have h1c : "((\<Sum>i = 0..<deg+1. f i / D ^ i) \<le> 0) =((\<Sum>i = 0..<deg+1. (f i) * D ^ (deg - i))  * D ^ (deg mod 2) \<le> 0)"
     using h1a h1b nonzero by auto 
   have h4a : "\<forall>i. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i)) = (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) (isolate_variable_sparse p var i))"
     by(simp add: insertion_isovarspars_free)
   have "((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)) * D ^ (deg - i)) * D ^ (deg mod 2) \<le> 0)=
     ((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C) ^ i)) / D ^ i) \<le> 0)"
     using h1c f_def by auto
   also have "...=((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C)^i / (D ^ i)))) \<le> 0)"
     by auto
   also have "...=((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var C)) (isolate_variable_sparse p var i) * ((A + B * C)/D) ^ i)) \<le> 0)"
     by (metis (no_types, lifting) power_divide sum.cong)
   also have "...=((\<Sum>i = 0..<deg+1. (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) (isolate_variable_sparse p var i) * ((A + B * C)/D) ^ i))\<le>0)"
     using h4a by auto 
   also have "... = (insertion (nth_default 0 (list_update L var ((A+B*C)/D))) p\<le>0)"
     using sum_over_degree_insertion hdeg lLength by auto
   finally show ?thesis
     by(simp add: hdeg lLength insertion_add insertion_mult ha hb hd insertion_sum insertion_pow insertion_var)
 qed
 
 (*------------------------------------------------------------------------------------------------*)
 lemma quad_part_1_neq :
   assumes lLength : "length L > var"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg::nat)"
   assumes nonzero : "D \<noteq> 0"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) a = (A::real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) b = (B::real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) d = (D::real)"
   shows "aEval (Neq p) (list_update L var ((A+B*C)/D)) = aEval (Neq(quadratic_part_1 var a b d (Neq p))) (list_update L var C)"
 proof -
   have "aEval (Eq(quadratic_part_1 var a b d (Eq p))) (list_update L var C) = aEval (Eq p) (list_update L var ((A+B*C)/D))"
     using quad_part_1_eq assms by blast
   then show ?thesis by auto
 qed
 
 (*------------------------------------------------------------------------------------------------*)
 
 
 lemma sqrt_case : 
   assumes detGreater0 : "SQ \<ge> 0"
   shows "((SQ^(i div 2)) * real (i mod 2) * sqrt SQ + SQ ^ (i div 2) * (1 - real (i mod 2))) = (sqrt SQ) ^ i"
 proof -
   have h1 : "i mod 2 = 0 \<or> (odd i \<and> (i mod 2 = 1))"
     by auto
   have h2 : "i mod 2 = 0 \<Longrightarrow> ((SQ^(i div 2)) * real (i mod 2) * sqrt SQ + SQ ^ (i div 2) * (1 - real (i mod 2))) = (sqrt SQ) ^ i"
     using detGreater0 apply auto
     by (simp add: real_sqrt_power_even)
   have h3 : "(odd i \<and> (i mod 2 = 1)) \<Longrightarrow> ((SQ^(i div 2)) * real (i mod 2) * sqrt SQ + SQ ^ (i div 2) * (1 - real (i mod 2))) = (sqrt SQ) ^ i"
     using detGreater0 apply auto
     by (smt One_nat_def add_Suc_right mult.commute nat_arith.rule0 odd_two_times_div_two_succ power.simps(2) power_mult real_sqrt_pow2)
   show ?thesis
     using h1 h2 h3
     by linarith 
 qed
 
 lemma sum_over_sqrt :
   assumes detGreater0 : "SQ \<ge> 0"
   shows "(\<Sum>i\<in>{0..<n+1}. ((f i::real) * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ +f i * SQ ^ (i div 2) * (1 - real (i mod 2))))
         =(\<Sum>i\<in>{0..<n+1}. ((f i::real) * ((sqrt SQ)^i)))"
   apply (intro sum.cong refl)
   using sqrt_case[OF detGreater0] distrib_left mult.assoc by metis
 
 lemma quad_part_2_eq :
   assumes lLength : "length L > var"
   assumes detGreater0 : "SQ\<ge>0"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg ::nat)"
   assumes hsq : "\<forall>x. insertion (nth_default 0 (list_update L var x)) sq = (SQ::real)"
   shows "aEval (Eq p) (list_update L var (sqrt SQ)) = aEval (Eq(quadratic_part_2 var sq p)) (list_update L var (sqrt SQ))"
 proof -
   define f where "f i = insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)" for i
   have h1a : "(\<Sum>i\<in>{0..<deg+1}. (f i * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ +f i * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (f i * ((sqrt SQ)^i)))"
     using sum_over_sqrt detGreater0 by auto
   have "(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ + (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)) * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * ((sqrt SQ)^i)))"
     using h1a f_def by auto
   also have "... = insertion (nth_default 0 (list_update L var (sqrt SQ))) p"
     using sum_over_degree_insertion hdeg lLength by auto
   finally show ?thesis
     by(simp add:hdeg hsq insertion_add insertion_sum insertion_mult insertion_pow insertion_var insertion_const lLength)
 qed
 
 lemma quad_part_2_less :
   assumes lLength : "length L > var"
   assumes detGreater0 : "SQ\<ge>0"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg ::nat)"
   assumes hsq : "\<forall>x. insertion (nth_default 0 (list_update L var x)) sq = (SQ::real)"
   shows "aEval (Less p) (list_update L var (sqrt SQ)) = aEval (Less(quadratic_part_2 var sq p)) (list_update L var (sqrt SQ))"
 proof -
   define f where "f i = insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)" for i
   have h1a : "(\<Sum>i\<in>{0..<deg+1}. (f i * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ +f i * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (f i * ((sqrt SQ)^i)))"
     using sum_over_sqrt detGreater0 by auto
   have "(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ + (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)) * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * ((sqrt SQ)^i)))"
     using h1a f_def by auto
   also have "... = insertion (nth_default 0 (list_update L var (sqrt SQ))) p"
     using sum_over_degree_insertion hdeg lLength by auto
   finally show ?thesis
     by(simp add:hdeg hsq insertion_add insertion_sum insertion_mult insertion_pow insertion_var insertion_const lLength)
 qed
 
 lemma quad_part_2_neq :
   assumes lLength : "length L > var"
   assumes detGreater0 : "SQ\<ge>0"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg ::nat)"
   assumes hsq : "\<forall>x. insertion (nth_default 0 (list_update L var x)) sq = (SQ::real)"
   shows "aEval (Neq p) (list_update L var (sqrt SQ)) = aEval (Neq(quadratic_part_2 var sq p)) (list_update L var (sqrt SQ))"
 proof -
   define f where "f i = insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)" for i
   have h1a : "(\<Sum>i\<in>{0..<deg+1}. (f i * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ +f i * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (f i * ((sqrt SQ)^i)))"
     using sum_over_sqrt detGreater0 by auto
   have "(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ + (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)) * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * ((sqrt SQ)^i)))"
     using h1a f_def by auto
   also have "... = insertion (nth_default 0 (list_update L var (sqrt SQ))) p"
     using sum_over_degree_insertion hdeg lLength by auto
   finally show ?thesis
     by(simp add:hdeg hsq insertion_add insertion_sum insertion_mult insertion_pow insertion_var insertion_const lLength)
 qed
 
 lemma quad_part_2_leq :
   assumes lLength : "length L > var"
   assumes detGreater0 : "SQ\<ge>0"
   assumes hdeg : "MPoly_Type.degree (p::real mpoly) var = (deg ::nat)"
   assumes hsq : "\<forall>x. insertion (nth_default 0 (list_update L var x)) sq = (SQ::real)"
   shows "aEval (Leq p) (list_update L var (sqrt SQ)) = aEval (Leq(quadratic_part_2 var sq p)) (list_update L var (sqrt SQ))"
 proof -
   define f where "f i = insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)" for i
   have h1a : "(\<Sum>i\<in>{0..<deg+1}. (f i * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ +f i * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (f i * ((sqrt SQ)^i)))"
     using sum_over_sqrt detGreater0 by auto
   have "(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * (SQ^(i div 2)) * real (i mod 2) * sqrt SQ + (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i)) * SQ ^ (i div 2) * (1 - real (i mod 2))))
              =(\<Sum>i\<in>{0..<deg+1}. (insertion (nth_default 0 (list_update L var (sqrt SQ))) (isolate_variable_sparse p var i) * ((sqrt SQ)^i)))"
     using h1a f_def by auto
   also have "... = insertion (nth_default 0 (list_update L var (sqrt SQ))) p"
     using sum_over_degree_insertion hdeg lLength by auto
   finally show ?thesis
     by(simp add:hdeg hsq insertion_add insertion_sum insertion_mult insertion_pow insertion_var insertion_const lLength)
 qed
 
 lemma quad_part_2_deg :
   assumes sqfree : "(var::nat)\<notin>vars(sq::real mpoly)"
   shows "MPoly_Type.degree (quadratic_part_2 var sq p) var \<le> 1"
 proof -
   define deg where "deg = MPoly_Type.degree (p::real mpoly) var"
   define f where "f i = isolate_variable_sparse p var i * sq ^ (i div 2) * Const (real (i mod 2)) * Var var" for i
   define g where "g i = isolate_variable_sparse p var i * sq ^ (i div 2) * Const (1 - real (i mod 2))" for i
   have h1a : "\<forall>i. MPoly_Type.degree (isolate_variable_sparse p var i) var = 0"
     by (simp add: varNotIn_degree not_in_isovarspar) 
   have h1b : "\<forall>i. MPoly_Type.degree (sq ^ (i div 2)) var = 0"
     by (simp add: sqfree varNotIn_degree not_in_pow)
   have h1c : "\<forall>i. MPoly_Type.degree (Const (real (i mod 2))) var = 0"
     using degree_const by blast
   have h1d : "MPoly_Type.degree (Var var :: real mpoly) var = 1"
     using degree_one by auto
   have h1 : "\<forall>i<deg+1. MPoly_Type.degree (f i) var \<le> 1"
     using f_def degree_mult h1a h1b h1c h1d
     by (smt ExecutiblePolyProps.degree_one add.right_neutral mult.commute mult_eq_0_iff nat_le_linear not_one_le_zero)
   have h2a : "\<forall>i. MPoly_Type.degree (Const (1 - real (i mod 2))) var = 0"
     using degree_const by blast
   have h2 : "\<forall>i<deg+1. MPoly_Type.degree (g i) var = 0"
     using g_def degree_mult h1a h1b h2a
     by (metis (no_types, lifting) add.right_neutral mult_eq_0_iff)
   have h3 : "\<forall>i<deg+1. MPoly_Type.degree (f i + g i) var \<le> 1"
     using h1 h2 by (simp add: degree_add_leq)
   show ?thesis using atLeastLessThanSuc_atLeastAtMost degree_sum f_def g_def h3 deg_def by auto 
 qed
 
 
 
 (*------------------------------------------------------------------------------------------------*)
 
 lemma quad_equality_helper :
   assumes lLength : "length L > var"
   assumes detGreat0 : "Cv\<ge>0"
   assumes hC : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (C::real mpoly) = (Cv::real)"
   assumes hA : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (A::real mpoly) = (Av::real)"
   assumes hB : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (B::real mpoly) = (Bv::real)"
   shows "aEval (Eq (A + B * Var var)) (list_update L var (sqrt Cv)) = eval (And (Atom(Leq (A*B))) (Atom (Eq (A^2-B^2*C)))) (list_update L var (sqrt Cv))"
 proof-
   have h1 : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (A^2-(B^2)*C) = Av^2-(Bv^2)*Cv"
     by(simp add: hA hB hC insertion_add insertion_mult insertion_sub insertion_pow)
   have h2a : "(Av + Bv * sqrt Cv = 0) = (Av = - Bv * sqrt Cv)"
     by auto
   have h2b : "(Av = - Bv * sqrt Cv) \<Longrightarrow> (Av^2 = (- Bv * sqrt Cv)^2)"
     by simp
   have h2c : "(Av^2 = (- Bv * sqrt Cv)^2) = (Av^2 = Bv^2 * (sqrt Cv)^2)"
     by (simp add: power_mult_distrib)
   have h2d : "(Av^2 = Bv^2 * (sqrt Cv)^2) = (Av^2 = Bv^2 * Cv)"
     by (simp add: detGreat0)
   have h2 : "(Av + Bv * sqrt Cv = 0) \<Longrightarrow> (Av^2 = Bv^2 * Cv)"
     using h2a h2b h2c h2d by blast
   have h3a : "(Av*Bv > 0) \<Longrightarrow> (Av + Bv * sqrt Cv \<noteq> 0)"
     by (smt detGreat0 mult_nonneg_nonneg real_sqrt_ge_zero zero_less_mult_iff)
   have h3 : "(Av + Bv * sqrt Cv = 0) \<Longrightarrow> (Av*Bv\<le> 0)"
     using h3a by linarith
   have h4 : "(Av * Bv \<le> 0 \<and> Av\<^sup>2 = Bv\<^sup>2 * Cv) \<Longrightarrow> (Av + Bv * sqrt Cv = 0)"
     apply(cases "Av>0")
      apply (metis detGreat0 h2a h2c h2d mult_minus_left not_le power2_eq_iff real_sqrt_lt_0_iff zero_less_mult_iff)
     by (smt h2a real_sqrt_abs real_sqrt_mult zero_less_mult_iff)
   show ?thesis
     apply(simp add: hA hB h1 insertion_add insertion_mult insertion_var lLength)
     using h2 h3 h4 by blast
 qed
 
 lemma quadratic_sub_eq :
   assumes lLength : "length L > var"
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (d::real mpoly) = (Dv :: real)"
   shows "aEval (Eq p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub var a b c d (Eq p)) (list_update L var (sqrt Cv))"
 proof -
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Eq p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
   have h3c : "MPoly_Type.degree p2 var = 0 \<or> MPoly_Type.degree p2 var = 1"
     using freeC quad_part_2_deg p2_def by (meson le_neq_implies_less less_one)
   have h3d : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> B = 0"
     by(simp add: B_def isovar_greater_degree)
   then have h3f : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> p2 = A + B * Var var"
     by(simp add: h3d A_def degree0isovarspar)
   have h3g1 : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = (\<Sum>i\<le>1. isolate_variable_sparse p2 var i * Var var ^ i)"
     using sum_over_zero by metis 
   have h3g2a : "\<forall>f. (\<Sum>i::nat\<le>1. f i) = f 0 + f 1" by simp
   have h3g2 : "(\<Sum>i::nat\<le>1. isolate_variable_sparse p2 var i * Var var ^ i) = 
                 isolate_variable_sparse p2 var 0 * Var var ^ 0 + isolate_variable_sparse p2 var 1 * Var var ^ 1"
     using h3g2a by blast 
   have h3g : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = A + B * Var var"
     apply(simp add: sum_over_zero A_def B_def)
     using h3g1 h3g2
     by (metis (no_types, lifting) One_nat_def mult_cancel_left2 power_0 power_one_right)
   have h3h : "p2 = A + B * Var var"
     using h3c h3f h3g by auto
 
   have h4a : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0 (list_update L var y)) A = x"
     using not_contains_insertion not_in_isovarspar A_def by blast
   have h4b : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0 (list_update L var y)) B = x"
     using not_contains_insertion not_in_isovarspar B_def by blast
 
 
   have "aEval (Eq p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) =  aEval (Eq p1) (list_update L var (sqrt Cv))"
     using p1_def quad_part_1_eq nonzero ha hb hd lLength by blast
   also have h2 : "... = aEval (Eq p2) (list_update L var (sqrt Cv))"
     using p2_def quad_part_2_eq lLength detGreater0 hc by metis
   also have "... = aEval (Eq (A + B * Var var)) (list_update L var (sqrt Cv))"
     using h3h by auto
   also have "... = eval (And (Atom(Leq (A*B))) (Atom (Eq (A^2-B^2*c)))) (list_update L var (sqrt Cv))"
     using quad_equality_helper hc detGreater0 h4a h4b lLength by blast
   also have "... = eval (quadratic_sub var a b c d (Eq p)) (list_update L var (sqrt Cv))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(1) by metis
   finally show ?thesis by blast
 qed
   (*------------------------------------------------------------------------------------------------*)
 lemma quadratic_sub_less_helper :
   assumes lLength : "length L > var"
   assumes detGreat0 : "Cv\<ge>0"
   assumes hC : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (C::real mpoly) = (Cv::real)"
   assumes hA : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (A::real mpoly) = (Av::real)"
   assumes hB : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (B::real mpoly) = (Bv::real)"
   shows "aEval (Less (A + B * Var var)) (list_update L var (sqrt Cv)) = eval
      (Or (And (fm.Atom (Less A)) (fm.Atom (Less (B\<^sup>2 * C - A\<^sup>2))))
        (And (fm.Atom (Leq B)) (Or (fm.Atom (Less A)) (fm.Atom (Less (A\<^sup>2 - B\<^sup>2 * C))))))
      (list_update L var (sqrt Cv)) "
 proof-
   have h1 : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (A^2-(B^2)*C) = Av^2-(Bv^2)*Cv"
     by(simp add: hA hB hC insertion_add insertion_mult insertion_sub insertion_pow)
   have h2 : "\<forall>x. insertion (nth_default 0 (list_update L var x)) ((B^2)*C-A^2) = (Bv^2)*Cv-Av^2"
     by(simp add: hA hB hC insertion_add insertion_mult insertion_sub insertion_pow)
   have h3 : "Av=0 \<Longrightarrow> Bv=0 \<Longrightarrow> (Av + Bv * sqrt Cv < 0) =
     (Av < 0 \<and> Bv\<^sup>2 * Cv < Av\<^sup>2 \<or> Bv \<le> 0 \<and> (Av < 0 \<or> Av\<^sup>2 < Bv\<^sup>2 * Cv))"
     by simp
   have h4 : "Av<0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av + Bv * sqrt Cv < 0) =
     (Av < 0 \<and> Bv\<^sup>2 * Cv < Av\<^sup>2 \<or> Bv \<le> 0 \<and> (Av < 0 \<or> Av\<^sup>2 < Bv\<^sup>2 * Cv))"
     by (metis add.right_neutral add_mono_thms_linordered_field(5) detGreat0 less_eq_real_def mult_less_0_iff mult_zero_class.mult_zero_left mult_zero_class.mult_zero_right real_sqrt_eq_zero_cancel_iff real_sqrt_gt_0_iff)
   have h5a : "Av\<ge>0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av < -Bv * sqrt Cv) \<Longrightarrow> (Av\<^sup>2 < Bv\<^sup>2 * Cv)"
   proof -
     assume a1: "0 \<le> Av"
     assume a2: "Av < - Bv * sqrt Cv"
     assume "Bv \<le> 0"
     then have "Av < sqrt (Cv * (Bv * Bv))"
       using a2 by (simp add: mult.commute real_sqrt_mult)
     then show ?thesis
       using a1 by (metis (no_types) mult.commute power2_eq_square real_sqrt_less_iff real_sqrt_mult real_sqrt_pow2_iff)
   qed
   have h5b : "Av\<ge>0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av\<^sup>2 < Bv\<^sup>2 * Cv) \<Longrightarrow> (Av < -Bv * sqrt Cv)"
     using real_less_rsqrt real_sqrt_mult by fastforce
   have h5 : "Av\<ge>0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av + Bv * sqrt Cv < 0) =
     (Av < 0 \<and> Bv\<^sup>2 * Cv < Av\<^sup>2 \<or> Bv \<le> 0 \<and> (Av < 0 \<or> Av\<^sup>2 < Bv\<^sup>2 * Cv))"
     using h5a h5b by linarith
   have h6 : "Av\<ge>0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Av + Bv * sqrt Cv < 0) =
     (Av < 0 \<and> Bv\<^sup>2 * Cv < Av\<^sup>2 \<or> Bv \<le> 0 \<and> (Av < 0 \<or> Av\<^sup>2 < Bv\<^sup>2 * Cv))"
     by (smt detGreat0 mult_nonneg_nonneg real_sqrt_ge_zero)
   have h7a : "Av<0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Av < -Bv * sqrt Cv) \<Longrightarrow> (Bv\<^sup>2 * Cv < Av\<^sup>2)"
     by (smt mult_minus_left real_sqrt_abs real_sqrt_le_mono real_sqrt_mult)
   have h7b : "Av<0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Bv\<^sup>2 * Cv < Av\<^sup>2) \<Longrightarrow> (Av < -Bv * sqrt Cv)"
     by (metis abs_of_nonneg abs_real_def add.commute less_eq_real_def mult.assoc mult_minus_left power2_eq_square real_add_less_0_iff real_sqrt_less_iff real_sqrt_mult real_sqrt_mult_self)
   have h7 : "Av<0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Av + Bv * sqrt Cv < 0) =
     (Av < 0 \<and> Bv\<^sup>2 * Cv < Av\<^sup>2 \<or> Bv \<le> 0 \<and> (Av < 0 \<or> Av\<^sup>2 < Bv\<^sup>2 * Cv))"
     using h7a h7b by linarith
   show ?thesis
     apply(simp add: hA hB h1 h2 insertion_add insertion_mult insertion_var lLength)
     using h3 h4 h5 h6 h7 by smt 
 qed
 
 lemma quadratic_sub_less :
   assumes lLength : "length L > var"
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (d::real mpoly) = (Dv :: real)"
   shows "aEval (Less p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub var a b c d (Less p)) (list_update L var (sqrt Cv))"
 proof -
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Less p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
 
   have h3b : "MPoly_Type.degree p2 var \<le> 1"
     using freeC quad_part_2_deg p2_def by blast
   then have h3c : "MPoly_Type.degree p2 var = 0 \<or> MPoly_Type.degree p2 var = 1"
     by auto
   have h3d : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> B = 0"
     by(simp add: B_def isovar_greater_degree)
   then have h3f : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> p2 = A + B * Var var"
     by(simp add: h3d A_def degree0isovarspar)
   have h3g1 : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = (\<Sum>i\<le>1. isolate_variable_sparse p2 var i * Var var ^ i)"
     using sum_over_zero by metis 
   have h3g2a : "\<forall>f. (\<Sum>i::nat\<le>1. f i) = f 0 + f 1" by simp
   have h3g2 : "(\<Sum>i::nat\<le>1. isolate_variable_sparse p2 var i * Var var ^ i) = 
                 isolate_variable_sparse p2 var 0 * Var var ^ 0 + isolate_variable_sparse p2 var 1 * Var var ^ 1"
     using h3g2a by blast 
   have h3g : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = A + B * Var var"
     apply(simp add: sum_over_zero A_def B_def)
     using h3g1 h3g2
     by (metis (no_types, lifting) One_nat_def mult_cancel_left2 power_0 power_one_right)
   have h3h : "p2 = A + B * Var var"
     using h3c h3f h3g by auto
 
   have h4a : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0(list_update L var y)) A = x"
     using not_contains_insertion not_in_isovarspar A_def by blast
   have h4b : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0(list_update L var y)) B = x"
     using not_contains_insertion not_in_isovarspar B_def by blast
 
   have h1 : "aEval (Less p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = aEval (Less (quadratic_part_1 var a b d (Less p))) (list_update L var (sqrt Cv))"
     using quad_part_1_less assms by blast
   also have "... = aEval (Less p1) (list_update L var (sqrt Cv))"
     using p1_def by auto
   also have "... = aEval (Less (quadratic_part_2 var c p1)) (list_update L var (sqrt Cv))"
     using quad_part_2_less assms by blast
   also have "... = aEval (Less p2) (list_update L var (sqrt Cv))"
     using p2_def by auto
   also have "... = aEval (Less (A + B * Var var)) (list_update L var (sqrt Cv))"
     using h3h by auto
   also have "... = eval
      (Or (And (fm.Atom (Less A)) (fm.Atom (Less (B\<^sup>2 * c - A\<^sup>2))))
        (And (fm.Atom (Leq B)) (Or (fm.Atom (Less A)) (fm.Atom (Less (A\<^sup>2 - B\<^sup>2 * c))))))
      (list_update L var (sqrt Cv))"
     using quadratic_sub_less_helper hc detGreater0 h4a h4b lLength by blast
   also have  "... = eval (quadratic_sub var a b c d (Less p)) (list_update L var (sqrt Cv))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(2) by metis
   finally show ?thesis by blast
 qed
 
 (*------------------------------------------------------------------------------------------------*) 
 lemma quadratic_sub_leq_helper :
   assumes lLength : "length L > var"
   assumes detGreat0 : "Cv\<ge>0"
   assumes hC : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (C::real mpoly) = (Cv::real)"
   assumes hA : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (A::real mpoly) = (Av::real)"
   assumes hB : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (B::real mpoly) = (Bv::real)"
   shows "aEval (Leq (A + B * Var var)) (list_update L var (sqrt Cv)) = 
   eval (Or(And(Atom(Leq(A)))(Atom (Leq(B^2*C-A^2))))(And (Atom(Leq B)) (Atom(Leq (A^2-B^2*C))))) (list_update L var (sqrt Cv))"
 proof-
   have h1 : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (A^2-(B^2)*C) = Av^2-(Bv^2)*Cv"
     by(simp add: hA hB hC insertion_add insertion_mult insertion_sub insertion_pow)
   have h2 : "\<forall>x. insertion (nth_default 0 (list_update L var x)) ((B^2)*C-A^2) = (Bv^2)*Cv-Av^2"
     by(simp add: hA hB hC insertion_add insertion_mult insertion_sub insertion_pow)
   have h3 : "Av=0 \<Longrightarrow> Bv=0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) = (Av \<le> 0 \<and> Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<or> Bv \<le> 0 \<and> Av\<^sup>2 \<le> Bv\<^sup>2 * Cv)"
     by simp
   have h4 : "Av<0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) = (Av \<le> 0 \<and> Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<or> Bv \<le> 0 \<and> Av\<^sup>2 \<le> Bv\<^sup>2 * Cv)"
     by (smt detGreat0 real_sqrt_ge_zero zero_less_mult_iff)
   have h5 : "Av=0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) = (Av \<le> 0 \<and> Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<or> Bv \<le> 0 \<and> Av\<^sup>2 \<le> Bv\<^sup>2 * Cv)"
     by (smt detGreat0 real_sqrt_ge_zero zero_less_mult_iff)
   have h6 : "Av\<ge>0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) = (Av \<le> 0 \<and> Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<or> Bv \<le> 0 \<and> Av\<^sup>2 \<le> Bv\<^sup>2 * Cv)"
     by (smt detGreat0 mult_nonneg_nonneg mult_pos_pos real_sqrt_gt_0_iff real_sqrt_zero zero_le_power2 zero_less_mult_pos zero_less_power2)
   have h7a : "Av<0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) \<Longrightarrow> Bv\<^sup>2 * Cv \<le> Av\<^sup>2"
     by (smt real_sqrt_abs real_sqrt_less_mono real_sqrt_mult)
   have h7b : "Av<0 \<Longrightarrow> Bv>0 \<Longrightarrow>  Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) "
     by (smt real_sqrt_abs real_sqrt_less_mono real_sqrt_mult)
   have h7 : "Av<0 \<Longrightarrow> Bv>0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) = (Av \<le> 0 \<and> Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<or> Bv \<le> 0 \<and> Av\<^sup>2 \<le> Bv\<^sup>2 * Cv)"
     using h7a h7b by linarith
   have h8c : "(-Bv * sqrt Cv)^2 = Bv\<^sup>2 * Cv"
     by (simp add: detGreat0 power_mult_distrib)
   have h8a : "Av>0 \<Longrightarrow> Bv\<le>0  \<Longrightarrow> (Av \<le> -Bv * sqrt Cv) \<Longrightarrow>  Av\<^sup>2 \<le> Bv\<^sup>2 * Cv"
     using detGreat0 h8c power_both_sides by smt 
   have h8b : "Av>0 \<Longrightarrow> Bv\<le>0  \<Longrightarrow>   Av\<^sup>2 \<le> Bv\<^sup>2 * Cv \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) "
     using detGreat0 h8c power_both_sides
     by (smt mult_minus_left real_sqrt_ge_zero zero_less_mult_iff) 
   have h8 : "Av>0 \<Longrightarrow> Bv\<le>0 \<Longrightarrow> (Av + Bv * sqrt Cv \<le> 0) = (Av \<le> 0 \<and> Bv\<^sup>2 * Cv \<le> Av\<^sup>2 \<or> Bv \<le> 0 \<and> Av\<^sup>2 \<le> Bv\<^sup>2 * Cv)"
     using h8a h8b by linarith
   show ?thesis
     apply(simp add: hA hB h1 h2 insertion_add insertion_mult insertion_var lLength)
     using h3 h4 h5 h6 h7 h8 by smt
 qed
 
 lemma quadratic_sub_leq :
   assumes lLength : "length L > var"
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (d::real mpoly) = (Dv :: real)"
   shows "aEval (Leq p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub var a b c d (Leq p)) (list_update L var (sqrt Cv))"
 proof -
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Leq p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
 
   have h3b : "MPoly_Type.degree p2 var \<le> 1"
     using freeC quad_part_2_deg p2_def lLength by metis
   then have h3c : "MPoly_Type.degree p2 var = 0 \<or> MPoly_Type.degree p2 var = 1"
     by auto
   have h3d : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> B = 0"
     by(simp add: B_def isovar_greater_degree)
   then have h3f : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> p2 = A + B * Var var"
     by(simp add: h3d A_def degree0isovarspar)
   have h3g1 : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = (\<Sum>i\<le>1. isolate_variable_sparse p2 var i * Var var ^ i)"
     using sum_over_zero by metis 
   have h3g2a : "\<forall>f. (\<Sum>i::nat\<le>1. f i) = f 0 + f 1" by simp
   have h3g2 : "(\<Sum>i::nat\<le>1. isolate_variable_sparse p2 var i * Var var ^ i) = 
                 isolate_variable_sparse p2 var 0 * Var var ^ 0 + isolate_variable_sparse p2 var 1 * Var var ^ 1"
     using h3g2a by blast 
   have h3g : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = A + B * Var var"
     apply(simp add: sum_over_zero A_def B_def)
     using h3g1 h3g2
     by (metis (no_types, lifting) One_nat_def mult_cancel_left2 power_0 power_one_right)
   have h3h : "p2 = A + B * Var var"
     using h3c h3f h3g by auto
 
   have h4a : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0 (list_update L var y)) A = x"
     using not_contains_insertion not_in_isovarspar A_def by blast
   have h4b : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0 (list_update L var y)) B = x"
     using not_contains_insertion not_in_isovarspar B_def by blast
 
   have "aEval (Leq p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = aEval (Leq p1) (list_update L var (sqrt Cv))"
     using quad_part_1_leq nonzero ha hb hd p1_def lLength by metis
   also have "... = aEval (Leq p2) (list_update L var (sqrt Cv))"
     using p2_def quad_part_2_leq hc detGreater0 lLength by metis
   also have "... = aEval (Leq (A + B * Var var)) (list_update L var (sqrt Cv))"
     using h3h by auto
   also have h4 : "... = eval
      (Or
       (And
         (Atom(Leq(A)))
         (Atom (Leq(B^2*c-A^2))))
       (And
         (Atom(Leq B))
         (Atom(Leq (A^2-B^2*c)))))
      (list_update L var (sqrt Cv))"
     using quadratic_sub_leq_helper hc detGreater0 h4a h4b lLength by blast
   also have "... = eval (quadratic_sub var a b c d (Leq p)) (list_update L var (sqrt Cv))"
     using p1_def quadratic_sub.simps(3) p2_def A_def B_def by metis
   finally show ?thesis by blast
 qed
   (*------------------------------------------------------------------------------------------------*)
 lemma quadratic_sub_neq :
   assumes lLength : "length L > var"
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (d::real mpoly) = (Dv :: real)"
   shows "aEval (Neq p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub var a b c d (Neq p)) (list_update L var (sqrt Cv))"
 proof -
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Neq p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
 
   have h3b : "MPoly_Type.degree p2 var \<le> 1"
     using freeC quad_part_2_deg p2_def lLength by metis
   then have h3c : "MPoly_Type.degree p2 var = 0 \<or> MPoly_Type.degree p2 var = 1"
     by auto
   have h3d : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> B = 0"
     by(simp add: B_def isovar_greater_degree)
   then have h3f : "MPoly_Type.degree p2 var = 0 \<Longrightarrow> p2 = A + B * Var var"
     by(simp add: h3d A_def degree0isovarspar)
   have h3g1 : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = (\<Sum>i\<le>1. isolate_variable_sparse p2 var i * Var var ^ i)"
     using sum_over_zero by metis 
   have h3g2a : "\<forall>f. (\<Sum>i::nat\<le>1. f i) = f 0 + f 1" by simp
   have h3g2 : "(\<Sum>i::nat\<le>1. isolate_variable_sparse p2 var i * Var var ^ i) = 
                 isolate_variable_sparse p2 var 0 * Var var ^ 0 + isolate_variable_sparse p2 var 1 * Var var ^ 1"
     using h3g2a by blast 
   have h3g : "MPoly_Type.degree p2 var = 1 \<Longrightarrow> p2 = A + B * Var var"
     apply(simp add: sum_over_zero A_def B_def)
     using h3g1 h3g2
     by (metis (no_types, lifting) One_nat_def mult_cancel_left2 power_0 power_one_right)
   have h3h : "p2 = A + B * Var var"
     using h3c h3f h3g by auto
 
   have h4a : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0 (list_update L var y)) A = x"
     using not_contains_insertion not_in_isovarspar A_def by blast
   have h4b : "\<exists>x::real. \<forall>y::real. insertion (nth_default 0 (list_update L var y)) B = x"
     using not_contains_insertion not_in_isovarspar B_def by blast
   have h4c : "aEval (Eq (A + B * Var var)) (list_update L var (sqrt Cv))
            = eval (And (Atom(Leq (A*B))) (Atom (Eq (A^2-B^2*c)))) (list_update L var (sqrt Cv))"
     using quad_equality_helper hc detGreater0 h4a h4b lLength by blast
   have h4d : "aEval (Neq (A + B * Var var)) (list_update L var (sqrt Cv))
            = (\<not> (eval (And (Atom(Leq (A*B))) (Atom (Eq (A^2-B^2*c)))) (list_update L var (sqrt Cv))))"
     using aEval.simps(1) aEval.simps(4) h4c by blast
   have h4e : "(\<not> (eval (And (Atom(Leq (A*B))) (Atom (Eq (A^2-B^2*c)))) (list_update L var (sqrt Cv))))
                 = eval (Or (Atom(Less(-A*B))) (Atom (Neq(A^2-B^2*c)))) (list_update L var (sqrt Cv))"
     by (metis aNeg.simps(2) aNeg.simps(3) aNeg_aEval eval.simps(1) eval.simps(4) eval.simps(5) mult_minus_left)
 
   have "aEval (Neq p) (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = aEval (Neq p1) (list_update L var (sqrt Cv))"
     using quad_part_1_neq nonzero ha hb hd p1_def lLength by blast
   also have "... = aEval (Neq p2) (list_update L var (sqrt Cv))"
     using p2_def quad_part_2_neq hc detGreater0 lLength by metis
   also have "... = aEval (Neq (A + B * Var var)) (list_update L var (sqrt Cv))"
     using h3h by auto
   also have "... = eval (Or
       (Atom(Less(-A*B)))
       (Atom (Neq(A^2-B^2*c)))) (list_update L var (sqrt Cv))"
     using h4c h4d h4e by auto
   also have "... = eval (quadratic_sub var a b c d (Neq p)) (list_update L var (sqrt Cv))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(4) quadratic_part_1.simps(1) quadratic_part_1.simps(4)
     by (metis (no_types, lifting))
   finally show ?thesis by blast
 qed
   (*-----------------------------------------------------------------------------------------------*)
 theorem free_in_quad :
   assumes freeA : "var\<notin> vars a"
   assumes freeB : "var\<notin> vars b"
   assumes freeC : "var\<notin> vars c"
   assumes freeD : "var\<notin> vars d"
   shows "freeIn var (quadratic_sub var a b c d A)"
 proof(cases A)
   case (Less p)
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Less p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
   have h1 : "freeIn var (quadratic_sub var a b c d (Less p)) = freeIn var (Or (And (fm.Atom (Less A)) (fm.Atom (Less (B\<^sup>2 * c - A\<^sup>2))))
        (And (fm.Atom (Leq B)) (Or (fm.Atom (Less A)) (fm.Atom (Less (A\<^sup>2 - B\<^sup>2 * c))))))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(2) by metis
   have h2d : "var\<notin>vars(4::real mpoly)"
     by (metis freeB not_in_add not_in_pow numeral_Bit0 one_add_one power_0)
   have h2 : "freeIn var ((Or (And (fm.Atom (Less A)) (fm.Atom (Less (B\<^sup>2 * c - A\<^sup>2))))
        (And (fm.Atom (Leq B)) (Or (fm.Atom (Less A)) (fm.Atom (Less (A\<^sup>2 - B\<^sup>2 * c)))))))"
     using vars_mult not_in_isovarspar A_def B_def not_in_sub not_in_mult not_in_neg not_in_pow not_in_isovarspar h2d freeC
     by (simp)
   show ?thesis using h1 h2 Less by blast
 next
   case (Eq p)
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Eq p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
   have h1 : "freeIn var (quadratic_sub var a b c d (Eq p)) = freeIn var (And (Atom(Leq (A*B))) (Atom (Eq (A\<^sup>2 - B\<^sup>2 * c))))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(1) by metis
   have h2d : "var\<notin>vars(4::real mpoly)"
     by (metis freeB not_in_add not_in_pow numeral_Bit0 one_add_one power_0)
   have h2 : "freeIn var (And (Atom(Leq (A*B))) (Atom (Eq (A\<^sup>2 - B\<^sup>2 * c))))"
     using vars_mult not_in_isovarspar A_def B_def not_in_sub not_in_mult not_in_neg not_in_pow not_in_isovarspar h2d freeC
     by (simp)
   show ?thesis using h1 h2 Eq by blast
 next
   case (Leq p)
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Leq p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
   have h1 : "freeIn var (quadratic_sub var a b c d (Leq p)) = freeIn var (Or(And(Atom(Leq(A)))(Atom (Leq(B^2*c-A^2))))(And(Atom(Leq B))(Atom(Leq (A^2-B^2*c)))))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(3) by metis
   have h2d : "var\<notin>vars(4::real mpoly)"
     by (metis freeB not_in_add not_in_pow numeral_Bit0 one_add_one power_0)
   have h2 : "freeIn var (Or(And(Atom(Leq(A)))(Atom (Leq(B^2*c-A^2))))(And(Atom(Leq B))(Atom(Leq (A^2-B^2*c)))))"
     using vars_mult not_in_isovarspar A_def B_def not_in_sub not_in_mult not_in_neg not_in_pow not_in_isovarspar h2d freeC
     by (simp)
   show ?thesis using h1 h2 Leq by blast
 next
   case (Neq p)
   define p1 where "(p1::real mpoly) = quadratic_part_1 var a b d (Neq p)"
   define p2 where "(p2::real mpoly) = quadratic_part_2 var c p1"
   define A where "A = isolate_variable_sparse p2 var 0"
   define B where "B = isolate_variable_sparse p2 var 1"
   have h1 : "freeIn var (quadratic_sub var a b c d (Neq p)) = freeIn var (Or (Atom(Less(-A*B))) (Atom (Neq(A^2-B^2*c))))"
     using p2_def A_def B_def p1_def quadratic_sub.simps(4) by metis
   have h2d : "var\<notin>vars(4::real mpoly)"
     by (metis freeB not_in_add not_in_pow numeral_Bit0 one_add_one power_0)
   have h2 : "freeIn var (Or (Atom(Less(-A*B))) (Atom (Neq(A^2-B^2*c))))"
     using vars_mult not_in_isovarspar A_def B_def not_in_sub not_in_mult not_in_neg not_in_pow not_in_isovarspar h2d freeC
     by (simp)
   show ?thesis using h1 h2 Neq by blast
 qed
 
 theorem quadratic_sub :
   assumes lLength : "length L > var"
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (d::real mpoly) = (Dv :: real)"
   shows "aEval A (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub var a b c d A) (list_update L var (sqrt Cv))"
 proof(cases A)
   case (Less x1)
   then show ?thesis using quadratic_sub_less assms by blast
 next
   case (Eq x2)
   then show ?thesis using quadratic_sub_eq assms by blast
 next
   case (Leq x3)
   then show ?thesis using quadratic_sub_leq assms by blast
 next
   case (Neq x4)
   then show ?thesis using quadratic_sub_neq assms by blast
 qed
 
 
 
 
 lemma free_in_quad_fm_helper :
   assumes freeA : "var\<notin> vars a"
   assumes freeB : "var\<notin> vars b"
   assumes freeC : "var\<notin> vars c"
   assumes freeD : "var\<notin> vars d"
   shows "freeIn (var+z) (quadratic_sub_fm_helper var a b c d F z)"
 proof(induction F arbitrary: z)
   case TrueF
   then show ?case by auto
 next
   case FalseF
   then show ?case by auto
 next
   case (Atom x)
   then show ?case using free_in_quad[OF not_in_lift[OF assms(1)] not_in_lift[OF assms(2)] not_in_lift[OF assms(3)] not_in_lift[OF assms(4)], of z] by auto
 next
   case (And F1 F2)
   then show ?case by auto
 next
   case (Or F1 F2)
   then show ?case by auto
 next
   case (Neg F)
   then show ?case by auto
 next
   case (ExQ F)
   show ?case using ExQ[of "z+1"] by simp
 next
   case (AllQ F)
   show ?case using AllQ[of "z+1"] by simp
 next
   case (ExN x1 F)
   then show ?case
     by (metis (no_types, lifting) add.assoc freeIn.simps(13) liftmap.simps(10) quadratic_sub_fm_helper.simps)
 next
   case (AllN x1 F)
   then show ?case
     by (metis (no_types, lifting) freeIn.simps(12) group_cancel.add1 liftmap.simps(9) quadratic_sub_fm_helper.simps)
 qed
 
 theorem free_in_quad_fm :
   assumes freeA : "var\<notin> vars a"
   assumes freeB : "var\<notin> vars b"
   assumes freeC : "var\<notin> vars c"
   assumes freeD : "var\<notin> vars d"
   shows "freeIn var (quadratic_sub_fm var a b c d A)"
   using free_in_quad_fm_helper[OF assms, of 0] by auto
 
 
 
 lemma quadratic_sub_fm_helper :
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes lLength : "length L > var+z"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update (drop z L) var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update (drop z L) var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update (drop z L) var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update (drop z L) var x)) (d::real mpoly) = (Dv :: real)"
   shows "eval F (list_update L (var+z) ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub_fm_helper var a b c d F z) (list_update L (var+z) (sqrt Cv))"
   using assms proof(induction F arbitrary: z L)
   case TrueF
   then show ?case by auto
 next
   case FalseF
   then show ?case by auto
 next
   case (Atom x)
   define L1 where "L1 = drop z L"
   define L2 where "L2 = take z L"
   have L_def : "L = L2 @ L1" using L1_def L2_def by auto
   have lengthl2 : "length L2 = z" using L2_def
     using Atom.prems(4) by auto
   have "eval (Atom(Eq (a-Const Av))) ([] @ L1) = eval (liftFm 0 z (Atom(Eq (a- Const Av)))) ([] @ L2 @ L1)"
     by (metis eval_liftFm_helper lengthl2 list.size(3))
   then have "(insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z (a - Const Av)) = 0)"
     apply(simp add: insertion_sub insertion_const)
     using Atom(5) unfolding L1_def
     by (metis list_update_id) 
   then have "insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z a) = Av"
     using lift_minus by blast
   then have a1 : "\<forall>x. insertion (nth_default 0 (L[var + z := x])) (liftPoly 0 z a) = Av"
     unfolding L_def
     by (metis (no_types, lifting) Atom.prems(5) L1_def add.right_neutral add_diff_cancel_right' append_eq_append_conv append_eq_append_conv2 length_append lengthl2 lift_insertion list.size(3) list_update_append not_add_less2) 
   have "eval (Atom(Eq (b-Const Bv))) ([] @ L1) = eval (liftFm 0 z (Atom(Eq (b- Const Bv)))) ([] @ L2 @ L1)"
     by (metis eval_liftFm_helper lengthl2 list.size(3))
   then have "(insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z (b - Const Bv)) = 0)"
     apply(simp add: insertion_sub insertion_const)
     using Atom(6) unfolding L1_def
     by (metis list_update_id) 
   then have "insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z b) = Bv"
     using lift_minus by blast
   then have a2 : "\<forall>x. insertion (nth_default 0 (L[var + z := x])) (liftPoly 0 z b) = Bv"
     unfolding L_def using Atom(6) L1_def
     by (metis L_def add_diff_cancel_right' append.simps(1) lengthl2 lift_insertion list.size(3) list_update_append not_add_less2)    
   have "eval (Atom(Eq (c-Const Cv))) ([] @ L1) = eval (liftFm 0 z (Atom(Eq (c- Const Cv)))) ([] @ L2 @ L1)"
     by (metis eval_liftFm_helper lengthl2 list.size(3))
   then have "(insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z (c - Const Cv)) = 0)"
     apply(simp add: insertion_sub insertion_const)
     using Atom(7) unfolding L1_def
     by (metis list_update_id) 
   then have "insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z c) = Cv"
     using lift_minus by blast
   then have a3 : "\<forall>x. insertion (nth_default 0 (L[var + z := x])) (liftPoly 0 z c) = Cv"
-    unfolding L_def
-  proof -
-    obtain nn :: "(nat \<Rightarrow> real) \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> real mpoly \<Rightarrow> nat" where
-      "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> vars x2 \<and> x1 v3 \<noteq> x0 v3) = (nn x0 x1 x2 \<in> vars x2 \<and> x1 (nn x0 x1 x2) \<noteq> x0 (nn x0 x1 x2))"
-      by moura
-    then have f1: "\<forall>m f fa. nn fa f m \<in> vars m \<and> f (nn fa f m) \<noteq> fa (nn fa f m) \<or> insertion f m = insertion fa m"
-      by (meson insertion_irrelevant_vars)
-    obtain rr :: real where
-      "(\<exists>v0. insertion (nth_default 0 ((L2 @ L1)[var + z := v0])) (liftPoly 0 z c) \<noteq> Cv) = (insertion (nth_default 0 ((L2 @ L1)[var + z := rr])) (liftPoly 0 z c) \<noteq> Cv)"
-      by blast
-    moreover
-    { assume "var + z \<noteq> nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)"
-      moreover
-      { assume "(nth_default 0 (L2 @ L1) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)) = nth_default 0 ((L2 @ L1)[var + z := rr]) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c))) \<noteq> ((L2 @ L1) ! nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c) = (L2 @ L1)[var + z := rr] ! nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c))"
-        then have "nth_default 0 ((L2 @ L1)[var + z := rr]) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)) \<noteq> (L2 @ L1)[var + z := rr] ! nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c) \<or> nth_default 0 (L2 @ L1) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)) \<noteq> (L2 @ L1) ! nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)"
-          by linarith
-        then have "nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c) \<notin> vars (liftPoly 0 z c) \<or> nth_default 0 (L2 @ L1) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)) = nth_default 0 ((L2 @ L1)[var + z := rr]) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c))"
-          by (metis (no_types) append_Nil2 length_list_update nth_default_append) }
-      ultimately have "nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c) \<notin> vars (liftPoly 0 z c) \<or> nth_default 0 (L2 @ L1) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c)) = nth_default 0 ((L2 @ L1)[var + z := rr]) (nn (nth_default 0 ((L2 @ L1)[var + z := rr])) (nth_default 0 (L2 @ L1)) (liftPoly 0 z c))"
-        by force }
-    ultimately show "\<forall>r. insertion (nth_default 0 ((L2 @ L1)[var + z := r])) (liftPoly 0 z c) = Cv"
-      using f1 by (metis (full_types) Atom.prems(3) \<open>insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z c) = Cv\<close> not_in_lift)
-  qed
+    unfolding L_def by (metis freeC list_update_id not_contains_insertion not_in_lift)
   have "eval (Atom(Eq (d-Const Dv))) ([] @ L1) = eval (liftFm 0 z (Atom(Eq (d- Const Dv)))) ([] @ L2 @ L1)"
     by (metis eval_liftFm_helper lengthl2 list.size(3))
   then have "(insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z (d - Const Dv)) = 0)"
     apply(simp add: insertion_sub insertion_const)
     using Atom(8) unfolding L1_def
     by (metis list_update_id) 
   then have "insertion (nth_default 0 (L2 @ L1)) (liftPoly 0 z d) = Dv"
     using lift_minus by blast
   then have a4 : "\<forall>x. insertion (nth_default 0 (L[var + z := x])) (liftPoly 0 z d) = Dv"
     unfolding L_def
     by (metis Atom(8) L1_def L_def add_diff_cancel_right' append.simps(1) lengthl2 lift_insertion list.size(3) list_update_append not_add_less2)
   then show ?case  apply(simp)
     using quadratic_sub[OF Atom(4) Atom(1) Atom(2) not_in_lift[OF Atom(3)], of "(liftPoly 0 z a)" Av "(liftPoly 0 z b)" Bv "(liftPoly 0 z d)" x
         , OF a1 a2 a3 a4] .
 next
   case (And F1 F2)
   then show ?case by auto
 next
   case (Or F1 F2)
   then show ?case by auto
 next
   case (Neg F)
   then show ?case by auto
 next
   case (ExQ F)
   have lengthG : "var + (z + 1) < length (x#L)" for x using ExQ(5) by auto
   have forall : "\<forall>x. insertion (nth_default 0 ((drop z L)[var := x])) a = Av \<Longrightarrow> 
       \<forall>x. insertion (nth_default 0 ((drop (z + 1) (x1 # L))[var := x])) a = Av" for x1 a Av
     by auto
   have l : "x # L[var + z := v] = ((x#L)[var+(z+1):=v])" for x v
     by auto
   have "eval (ExQ F) (L[var + z := (Av + Bv * sqrt Cv) / Dv]) =
     (\<exists>x. eval F (x # L[var + z := (Av + Bv * sqrt Cv) / Dv]))"
     by(simp)
   also have "... = (\<exists>x. eval
           (liftmap
             (\<lambda>x. quadratic_sub (var + x) (liftPoly 0 x a) (liftPoly 0 x b) (liftPoly 0 x c) (liftPoly 0 x d))
             F (z + 1))
           (x # L[var + z := sqrt Cv]))"
     apply(rule ex_cong1)
     unfolding l
     using ExQ(1)[OF ExQ(2) ExQ(3) ExQ(4) lengthG forall[OF ExQ(6)] forall[OF ExQ(7)] forall[OF ExQ(8)] forall[OF ExQ(9)]]
     unfolding quadratic_sub_fm_helper.simps liftmap.simps
     by simp
   also have "... = eval (quadratic_sub_fm_helper var a b c d (ExQ F) z) (L[var + z := sqrt Cv])"
     unfolding quadratic_sub_fm_helper.simps liftmap.simps eval.simps by auto
   finally show ?case by simp
 next
   case (AllQ F)
   have lengthG : "var + (z + 1) < length (x#L)" for x using AllQ(5) by auto
   have forall : "\<forall>x. insertion (nth_default 0 ((drop z L)[var := x])) a = Av \<Longrightarrow> 
       \<forall>x. insertion (nth_default 0 ((drop (z + 1) (x1 # L))[var := x])) a = Av" for x1 a Av
     by auto
   have l : "x # L[var + z := v] = ((x#L)[var+(z+1):=v])" for x v
     by auto
   have "eval (AllQ F) (L[var + z := (Av + Bv * sqrt Cv) / Dv]) =
     (\<forall>x. eval F (x # L[var + z := (Av + Bv * sqrt Cv) / Dv]))"
     by(simp)
   also have "... = (\<forall>x. eval
           (liftmap
             (\<lambda>x. quadratic_sub (var + x) (liftPoly 0 x a) (liftPoly 0 x b) (liftPoly 0 x c) (liftPoly 0 x d))
             F (z + 1))
           (x # L[var + z := sqrt Cv]))"
     apply(rule all_cong1)
     unfolding l
     using AllQ(1)[OF AllQ(2) AllQ(3) AllQ(4) lengthG forall[OF AllQ(6)] forall[OF AllQ(7)] forall[OF AllQ(8)] forall[OF AllQ(9)]]
     unfolding quadratic_sub_fm_helper.simps liftmap.simps
     by simp
   also have "... = eval (quadratic_sub_fm_helper var a b c d (AllQ F) z) (L[var + z := sqrt Cv])"
     unfolding quadratic_sub_fm_helper.simps liftmap.simps eval.simps by auto
   finally show ?case by simp
 next
   case (ExN x1 F)
   have list : "\<And>l. length l=x1 \<Longrightarrow> ((drop (z + x1) l @ drop (z + x1 - length l) L)) = ((drop z L))"
     by auto
   have map : "\<And> z L. eval (liftmap (\<lambda>x A. (quadratic_sub (var + x) (liftPoly 0 x a) (liftPoly 0 x b) (liftPoly 0 x c) (liftPoly 0 x d) A)) F (z + x1))
       L = eval (liftmap (\<lambda>x A. (quadratic_sub (var + x1 + x) (liftPoly 0 (x+x1) a) (liftPoly 0 (x+x1) b) (liftPoly 0 (x+x1) c) (liftPoly 0 (x+x1) d) A)) F z)
       L"
     apply(induction F) apply(simp_all add:add.commute add.left_commute)
     apply force
     apply force
     by (metis (mono_tags, lifting) ab_semigroup_add_class.add_ac(1))+
   show ?case apply simp apply(rule ex_cong1)
     subgoal for l
       using map[of z] list[of l] ExN(1)[OF ExN(2-4), of "z+x1" "l@L"] ExN(5-9) list_update_append
       apply auto
       by (simp add: list_update_append) +
     done
 next
   case (AllN x1 F)
   have list : "\<And>l. length l=x1 \<Longrightarrow> ((drop (z + x1) l @ drop (z + x1 - length l) L)) = ((drop z L))"
     by auto
   have map : "\<And> z L. eval (liftmap (\<lambda>x A. (quadratic_sub (var + x) (liftPoly 0 x a) (liftPoly 0 x b) (liftPoly 0 x c) (liftPoly 0 x d) A)) F (z + x1))
       L = eval (liftmap (\<lambda>x A. (quadratic_sub (var + x1 + x) (liftPoly 0 (x+x1) a) (liftPoly 0 (x+x1) b) (liftPoly 0 (x+x1) c) (liftPoly 0 (x+x1) d) A)) F z)
       L"
     apply(induction F) apply(simp_all add:add.commute add.left_commute)
     apply force
     apply force
     by (metis (mono_tags, lifting) ab_semigroup_add_class.add_ac(1))+
   show ?case apply simp apply(rule all_cong1)
     subgoal for l
       using map[of z] list[of l] AllN(1)[OF AllN(2-4), of "z+x1" "l@L"] AllN(5-9)
       apply auto
       by (simp add: list_update_append) +
     done
 qed
 
 theorem quadratic_sub_fm :
   assumes lLength : "length L > var"
   assumes nonzero : "Dv \<noteq> 0"
   assumes detGreater0 : "Cv \<ge> 0"
   assumes freeC : "var \<notin> vars c"
   assumes ha : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (a::real mpoly) = (Av :: real)"
   assumes hb : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (b::real mpoly) = (Bv :: real)"
   assumes hc : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (c::real mpoly) = (Cv :: real)"
   assumes hd : "\<forall>x. insertion (nth_default 0 (list_update L var x)) (d::real mpoly) = (Dv :: real)"
   shows "eval F (list_update L var ((Av+Bv*sqrt(Cv))/Dv)) = eval (quadratic_sub_fm var a b c d F) (list_update L var (sqrt Cv))"
   unfolding quadratic_sub_fm.simps using quadratic_sub_fm_helper[OF assms(2) assms(3) assms(4), of 0 L a Av b Bv d F] assms(1) assms(5) assms(6) assms(7) assms(8)
   by (simp add: lLength)
 end
\ No newline at end of file