diff --git a/thys/Adaptive_State_Counting/ASC/ASC_Sufficiency.thy b/thys/Adaptive_State_Counting/ASC/ASC_Sufficiency.thy
--- a/thys/Adaptive_State_Counting/ASC/ASC_Sufficiency.thy
+++ b/thys/Adaptive_State_Counting/ASC/ASC_Sufficiency.thy
@@ -1,874 +1,877 @@
 theory ASC_Sufficiency
   imports ASC_Suite
 begin
 
 section \<open> Sufficiency of the test suite to test for reduction \<close>
 
 text \<open>
 This section provides a proof that the test suite generated by the adaptive state counting algorithm
 is sufficient to test for reduction.
 \<close>
 
 subsection \<open> Properties of minimal sequences to failures extending the deterministic state cover \<close>
 
 text \<open>
 The following two lemmata show that minimal sequences to failures extending the deterministic state
 cover do not with their extending suffix visit any state twice or visit a state also reached by a
 sequence in the chosen permutation of reactions to the deterministic state cover.
 \<close>
 
 lemma minimal_sequence_to_failure_extending_implies_Rep_Pre :
   assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> N (vs@xs') M1 V"
   and     "prefix xs' xs"
   shows "\<not> Rep_Pre M2 M1 vs xs'"
 proof 
   assume "Rep_Pre M2 M1 vs xs'" 
   then obtain xs1 xs2 s1 s2 where  "prefix xs1 xs2"   
                                    "prefix xs2 xs'"
                                    "xs1 \<noteq> xs2"
                                    "io_targets M2 (initial M2) (vs @ xs1) = {s2}" 
                                    "io_targets M2 (initial M2) (vs @ xs2) = {s2}"
                                    "io_targets M1 (initial M1) (vs @ xs1) = {s1}"
                                    "io_targets M1 (initial M1) (vs @ xs2) = {s1}"
     by auto
   then have "s2 \<in> io_targets M2 (initial M2) (vs @ xs1)"
             "s2 \<in> io_targets M2 (initial M2) (vs @ xs2)"
             "s1 \<in> io_targets M1 (initial M1) (vs @ xs1)"
             "s1 \<in> io_targets M1 (initial M1) (vs @ xs2)"            
     by auto
 
   have "vs@xs1 \<in> L M1" 
     using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs1)\<close>] by assumption
   have "vs@xs2 \<in> L M1" 
     using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs2)\<close>] by assumption
   have "vs@xs1 \<in> L M2" 
     using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs1)\<close>] by assumption
   have "vs@xs2 \<in> L M2" 
     using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs2)\<close>] by assumption
 
   obtain tr1_1 where "path M1 (vs@xs1 || tr1_1) (initial M1)" 
                      "length tr1_1 = length (vs@xs1)" 
                      "target (vs@xs1 || tr1_1) (initial M1) = s1"
     using \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs1)\<close> by auto
   obtain tr1_2 where "path M1 (vs@xs2 || tr1_2) (initial M1)" 
                      "length tr1_2 = length (vs@xs2)" 
                      "target (vs@xs2 || tr1_2) (initial M1) = s1"
     using \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs2)\<close> by auto 
   obtain tr2_1 where "path M2 (vs@xs1 || tr2_1) (initial M2)" 
                      "length tr2_1 = length (vs@xs1)" 
                      "target (vs@xs1 || tr2_1) (initial M2) = s2"
     using \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs1)\<close> by auto
   obtain tr2_2 where "path M2 (vs@xs2 || tr2_2) (initial M2)"
                      "length tr2_2 = length (vs@xs2)"
                      "target (vs@xs2 || tr2_2) (initial M2) = s2"
     using \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs2)\<close> by auto 
 
 
   have "productF M2 M1 FAIL PM" 
     using assms(4) by auto
   have "well_formed M1" 
     using assms(2) by auto
   have "well_formed M2" 
     using assms(3) by auto
   have "observable PM"
     by (meson assms(2) assms(3) assms(4) observable_productF)
 
   have "length (vs@xs1) = length tr2_1"
     using \<open>length tr2_1 = length (vs @ xs1)\<close> by presburger
   then have "length tr2_1 = length tr1_1" 
     using \<open>length tr1_1 = length (vs@xs1)\<close> by presburger
 
   have "vs@xs1 \<in> L PM" 
     using productF_path_inclusion[OF \<open>length (vs@xs1) = length tr2_1\<close> \<open>length tr2_1 = length tr1_1\<close> 
                                      \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
     by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs @ xs1 \<in> L M1\<close> \<open>vs @ xs1 \<in> L M2\<close> \<open>well_formed M1\<close> 
         \<open>well_formed M2\<close> productF_language)
     
 
   have "length (vs@xs2) = length tr2_2"
     using \<open>length tr2_2 = length (vs @ xs2)\<close> by presburger
   then have "length tr2_2 = length tr1_2" 
     using \<open>length tr1_2 = length (vs@xs2)\<close> by presburger
 
   have "vs@xs2 \<in> L PM" 
     using productF_path_inclusion[OF \<open>length (vs@xs2) = length tr2_2\<close> \<open>length tr2_2 = length tr1_2\<close> 
                                      \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
     by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs @ xs2 \<in> L M1\<close> \<open>vs @ xs2 \<in> L M2\<close> \<open>well_formed M1\<close> 
         \<open>well_formed M2\<close> productF_language)
 
 
   
 
   have "io_targets PM (initial M2, initial M1) (vs @ xs1) = {(s2, s1)}" 
     using productF_path_io_targets_reverse
           [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs1)\<close> 
               \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs1)\<close> \<open>vs @ xs1 \<in> L M2\<close> \<open>vs @ xs1 \<in> L M1\<close> ]
   proof -
     have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
       by blast
     then show ?thesis
       by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1; 
                              initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk> 
                             \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs @ xs1) = {(s2, s1)}\<close> 
           assms(2) assms(3))
   qed 
 
   have "io_targets PM (initial M2, initial M1) (vs @ xs2) = {(s2, s1)}" 
     using productF_path_io_targets_reverse
           [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs2)\<close> 
               \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs2)\<close> \<open>vs @ xs2 \<in> L M2\<close> \<open>vs @ xs2 \<in> L M1\<close> ]
   proof -
     have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
       by blast
     then show ?thesis
       by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1; 
                              initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk> 
                             \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs @ xs2) = {(s2, s1)}\<close> 
           assms(2) assms(3))
   qed
 
   have "prefix (vs @ xs1) (vs @ xs2)"
     using \<open>prefix xs1 xs2\<close> by auto
 
 
 
   have "sequence_to_failure M1 M2 (vs@xs)" 
     using assms(1) by auto
   
 
   have "prefix (vs@xs1) (vs@xs')"
     using \<open>prefix xs1 xs2\<close> \<open>prefix xs2 xs'\<close> prefix_order.dual_order.trans same_prefix_prefix 
     by blast 
   have "prefix (vs@xs2) (vs@xs')"
     using \<open>prefix xs2 xs'\<close> prefix_order.dual_order.trans same_prefix_prefix by blast 
 
    
 
   have "io_targets PM (initial PM) (vs @ xs1) = {(s2,s1)}"
     using \<open>io_targets PM (initial M2, initial M1) (vs @ xs1) = {(s2, s1)}\<close> assms(4) by auto
   have "io_targets PM (initial PM) (vs @ xs2) = {(s2,s1)}"
     using \<open>io_targets PM (initial M2, initial M1) (vs @ xs2) = {(s2, s1)}\<close> assms(4) by auto
 
 
   have "(vs @ xs2) @ (drop (length xs2) xs) = vs@xs"
     by (metis \<open>prefix xs2 xs'\<close>  append_eq_appendI append_eq_conv_conj assms(6) prefixE) 
   moreover have "io_targets PM (initial PM) (vs@xs) = {FAIL}" 
     using sequence_to_failure_reaches_FAIL_ob[OF \<open>sequence_to_failure M1 M2 (vs@xs)\<close> assms(2,3) 
                                                  \<open>productF M2 M1 FAIL PM\<close>] 
     by assumption
   ultimately have "io_targets PM (initial PM) ((vs @ xs2) @ (drop (length xs2) xs)) = {FAIL}" 
     by auto
   
   have "io_targets PM (s2,s1) (drop (length xs2) xs) = {FAIL}" 
     using observable_io_targets_split
           [OF \<open>observable PM\<close>
               \<open>io_targets PM (initial PM) ((vs @ xs2) @ (drop (length xs2) xs)) = {FAIL}\<close>
               \<open>io_targets PM (initial PM) (vs @ xs2) = {(s2, s1)}\<close>] 
     by assumption
 
   have "io_targets PM (initial PM) (vs@xs1@(drop (length xs2) xs)) = {FAIL}"
     using observable_io_targets_append
           [OF \<open>observable PM\<close> \<open>io_targets PM (initial PM) (vs @ xs1) = {(s2,s1)}\<close> 
               \<open>io_targets PM (s2,s1) (drop (length xs2) xs) = {FAIL}\<close>] 
     by simp
   have "sequence_to_failure M1 M2 (vs@xs1@(drop (length xs2) xs))"
     using sequence_to_failure_alt_def
           [OF \<open>io_targets PM (initial PM) (vs@xs1@(drop (length xs2) xs)) = {FAIL}\<close> assms(2,3)]
           assms(4) 
     by blast 
 
   have "length xs1 < length xs2"
-    using \<open>prefix xs1 xs2\<close> \<open>xs1 \<noteq> xs2\<close> prefix_length_prefix by fastforce     
-  have "xs = (xs1 @ (drop (length xs1) xs))"
-    by (metis (no_types) \<open>(vs @ xs2) @ drop (length xs2) xs = vs @ xs\<close> \<open>prefix xs1 xs2\<close> 
-        append_assoc append_eq_conv_conj prefixE)
-  have "length xs1 < length xs"
-    using \<open>prefix xs1 xs2\<close> \<open>prefix xs2 xs'\<close> \<open>xs = xs1 @ drop (length xs1) xs\<close> \<open>xs1 \<noteq> xs2\<close> 
-          assms(6) leI 
-    by fastforce 
+    using \<open>prefix xs1 xs2\<close> \<open>xs1 \<noteq> xs2\<close> prefix_length_prefix by fastforce
+
+  have prefix_drop: "ys = ys1 @ (drop (length ys1)) ys" if "prefix ys1 ys"
+    for ys ys1 :: "('a \<times> 'b) list"
+    using that by (induction ys1) (auto elim: prefixE)
+  then have "xs = (xs1 @ (drop (length xs1) xs))"
+    using \<open>prefix xs1 xs2\<close> \<open>prefix xs2 xs'\<close> \<open>prefix xs' xs\<close> by simp
+  then have "length xs1 < length xs"
+    using prefix_drop[OF \<open>prefix xs2 xs'\<close>] \<open>prefix xs2 xs'\<close> \<open>prefix xs' xs\<close>
+    using \<open>length xs1 < length xs2\<close>
+    by (auto dest!: prefix_length_le)
   have "length (xs1@(drop (length xs2) xs)) < length xs"
     using \<open>length xs1 < length xs2\<close> \<open>length xs1 < length xs\<close> by auto
 
 
   have "vs \<in> L\<^sub>i\<^sub>n M1 V 
         \<and> sequence_to_failure M1 M2 (vs @ xs1@(drop (length xs2) xs)) 
         \<and> length (xs1@(drop (length xs2) xs)) < length xs"
     using \<open>length (xs1 @ drop (length xs2) xs) < length xs\<close> 
           \<open>sequence_to_failure M1 M2 (vs @ xs1 @ drop (length xs2) xs)\<close> 
           assms(1) minimal_sequence_to_failure_extending.simps 
     by blast
   
   then have "\<not> minimal_sequence_to_failure_extending V M1 M2 vs xs"
     by (meson minimal_sequence_to_failure_extending.elims(2))
    
 
   then show "False" 
     using assms(1) by linarith
 qed
   
 
 
 
 lemma minimal_sequence_to_failure_extending_implies_Rep_Cov :
   assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> N (vs@xsR) M1 V"
   and     "prefix xsR xs"
 shows "\<not> Rep_Cov M2 M1 V'' vs xsR"
 proof 
   assume "Rep_Cov M2 M1 V'' vs xsR"
   then obtain xs' vs' s2 s1 where "xs' \<noteq> []" 
                                   "prefix xs' xsR" 
                                   "vs' \<in> V''"
                                   "io_targets M2 (initial M2) (vs @ xs') = {s2}" 
                                   "io_targets M2 (initial M2) (vs') = {s2}"
                                   "io_targets M1 (initial M1) (vs @ xs') = {s1}" 
                                   "io_targets M1 (initial M1) (vs') = {s1}"
     by auto
 
   then have "s2 \<in> io_targets M2 (initial M2) (vs @ xs')"
             "s2 \<in> io_targets M2 (initial M2) (vs')"
             "s1 \<in> io_targets M1 (initial M1) (vs @ xs')"
             "s1 \<in> io_targets M1 (initial M1) (vs')"            
     by auto
 
   have "vs@xs' \<in> L M1" 
     using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs')\<close>] by assumption
   have "vs' \<in> L M1" 
     using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs')\<close>] by assumption
   have "vs@xs' \<in> L M2" 
     using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs')\<close>] by assumption
   have "vs' \<in> L M2" 
     using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs')\<close>] by assumption
 
   obtain tr1_1 where "path M1 (vs@xs' || tr1_1) (initial M1)"
                      "length tr1_1 = length (vs@xs')"
                      "target (vs@xs' || tr1_1) (initial M1) = s1"
     using \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs')\<close> by auto
   obtain tr1_2 where "path M1 (vs' || tr1_2) (initial M1)"
                      "length tr1_2 = length (vs')"
                      "target (vs' || tr1_2) (initial M1) = s1"
     using \<open>s1 \<in> io_targets M1 (initial M1) (vs')\<close> by auto 
   obtain tr2_1 where "path M2 (vs@xs' || tr2_1) (initial M2)"
                      "length tr2_1 = length (vs@xs')"
                      "target (vs@xs' || tr2_1) (initial M2) = s2"
     using \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs')\<close> by auto
   obtain tr2_2 where "path M2 (vs' || tr2_2) (initial M2)"
                      "length tr2_2 = length (vs')"
                      "target (vs' || tr2_2) (initial M2) = s2" 
     using \<open>s2 \<in> io_targets M2 (initial M2) (vs')\<close> by auto 
 
 
   have "productF M2 M1 FAIL PM" 
     using assms(4) by auto
   have "well_formed M1" 
     using assms(2) by auto
   have "well_formed M2" 
     using assms(3) by auto
   have "observable PM"
     by (meson assms(2) assms(3) assms(4) observable_productF)
 
   have "length (vs@xs') = length tr2_1"
     using \<open>length tr2_1 = length (vs @ xs')\<close> by presburger
   then have "length tr2_1 = length tr1_1" 
     using \<open>length tr1_1 = length (vs@xs')\<close> by presburger
 
   have "vs@xs' \<in> L PM" 
     using productF_path_inclusion[OF \<open>length (vs@xs') = length tr2_1\<close> \<open>length tr2_1 = length tr1_1\<close> 
                                      \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
     by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs @ xs' \<in> L M1\<close> \<open>vs @ xs' \<in> L M2\<close> \<open>well_formed M1\<close>
         \<open>well_formed M2\<close> productF_language)
     
 
   have "length (vs') = length tr2_2"
     using \<open>length tr2_2 = length (vs')\<close> by presburger
   then have "length tr2_2 = length tr1_2" 
     using \<open>length tr1_2 = length (vs')\<close> by presburger
 
   have "vs' \<in> L PM" 
     using productF_path_inclusion[OF \<open>length (vs') = length tr2_2\<close> \<open>length tr2_2 = length tr1_2\<close> 
                                      \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
     by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs' \<in> L M1\<close> \<open>vs' \<in> L M2\<close> \<open>well_formed M1\<close> 
         \<open>well_formed M2\<close> productF_language)
 
 
   
 
   have "io_targets PM (initial M2, initial M1) (vs @ xs') = {(s2, s1)}" 
     using productF_path_io_targets_reverse
           [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs')\<close> 
               \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs')\<close> \<open>vs @ xs' \<in> L M2\<close> \<open>vs @ xs' \<in> L M1\<close> ]
   proof -
     have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
       by blast
     then show ?thesis
       by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1; 
                               initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk> 
                             \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs @ xs') = {(s2, s1)}\<close> 
           assms(2) assms(3))
   qed 
 
   have "io_targets PM (initial M2, initial M1) (vs') = {(s2, s1)}" 
     using productF_path_io_targets_reverse
           [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs')\<close> 
               \<open>s1 \<in> io_targets M1 (initial M1) (vs')\<close> \<open>vs' \<in> L M2\<close> \<open>vs' \<in> L M1\<close> ]
   proof -
     have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
       by blast
     then show ?thesis
       by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1; 
                               initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk> 
                             \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs') = {(s2, s1)}\<close> 
           assms(2) assms(3))
   qed
   have "io_targets PM (initial PM) (vs') = {(s2, s1)}"
     by (metis (no_types) \<open>io_targets PM (initial M2, initial M1) vs' = {(s2, s1)}\<close> 
         \<open>productF M2 M1 FAIL PM\<close> productF_simps(4))
    
 
   have "sequence_to_failure M1 M2 (vs@xs)" 
     using assms(1) by auto
 
   have "xs = xs' @ (drop (length xs') xs)"
     by (metis \<open>prefix xs' xsR\<close> append_assoc append_eq_conv_conj assms(6) prefixE)
   then have "io_targets PM (initial M2, initial M1) (vs @ xs' @ (drop (length xs') xs)) = {FAIL}"
     by (metis \<open>productF M2 M1 FAIL PM\<close> \<open>sequence_to_failure M1 M2 (vs @ xs)\<close> assms(2) assms(3) 
         productF_simps(4) sequence_to_failure_reaches_FAIL_ob)
   then have "io_targets PM (initial M2, initial M1) ((vs @ xs') @ (drop (length xs') xs)) = {FAIL}"    
     by auto
   have "io_targets PM (s2, s1) (drop (length xs') xs) = {FAIL}" 
     using observable_io_targets_split
           [OF \<open>observable PM\<close> 
               \<open>io_targets PM (initial M2,initial M1) ((vs @ xs') @ (drop (length xs') xs)) = {FAIL}\<close> 
               \<open>io_targets PM (initial M2, initial M1) (vs @ xs') = {(s2, s1)}\<close>] 
     by assumption
 
   have "io_targets PM (initial PM) (vs' @ (drop (length xs') xs)) = {FAIL}" 
     using observable_io_targets_append
           [OF \<open>observable PM\<close> \<open>io_targets PM (initial PM) (vs') = {(s2, s1)}\<close>
               \<open>io_targets PM (s2, s1) (drop (length xs') xs) = {FAIL}\<close>] 
     by assumption
 
   have "sequence_to_failure M1 M2 (vs' @ (drop (length xs') xs))"   
     using sequence_to_failure_alt_def
           [OF \<open>io_targets PM (initial PM) (vs' @ (drop (length xs') xs)) = {FAIL}\<close> assms(2,3)] 
           assms(4) 
     by blast
 
   have "length (drop (length xs') xs) < length xs"
     by (metis (no_types) \<open>xs = xs' @ drop (length xs') xs\<close> \<open>xs' \<noteq> []\<close> length_append 
         length_greater_0_conv less_add_same_cancel2)   
 
   have "vs' \<in> L\<^sub>i\<^sub>n M1 V" 
   proof -
     have "V'' \<in> Perm V M1" 
       using assms(5) unfolding N.simps by blast
 
     then 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)"
       unfolding Perm.simps by blast
     then obtain v where "v \<in> V" "vs' = f v" 
       using \<open>vs' \<in> V''\<close> by auto
     then have "vs' \<in> language_state_for_input M1 (initial M1) v" 
       using f_def by auto
     
     have "language_state_for_input M1 (initial M1) v = L\<^sub>i\<^sub>n M1 {v}"
       by auto
     moreover have "{v} \<subseteq> V" 
       using \<open>v \<in> V\<close> by blast   
     ultimately have "language_state_for_input M1 (initial M1) v \<subseteq> L\<^sub>i\<^sub>n M1 V"
       unfolding language_state_for_inputs.simps language_state_for_input.simps by blast
     then show ?thesis
       using\<open>vs' \<in> language_state_for_input M1 (initial M1) v\<close> by blast
   qed
   
   have "\<not> minimal_sequence_to_failure_extending V M1 M2 vs xs" 
     using \<open>vs' \<in> L\<^sub>i\<^sub>n M1 V\<close>
           \<open>sequence_to_failure M1 M2 (vs' @ (drop (length xs') xs))\<close>
           \<open>length (drop (length xs') xs) < length xs\<close>
     using minimal_sequence_to_failure_extending.elims(2) by blast 
   then show "False" 
     using assms(1) by linarith
 qed
 
 
 
 
 lemma mstfe_no_repetition :
   assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
   and     "OFSM M1"
   and     "OFSM M2"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "V'' \<in> N (vs@xs') M1 V"
   and     "prefix xs' xs"
 shows "\<not> Rep_Pre M2 M1 vs xs'"
   and "\<not> Rep_Cov M2 M1 V'' vs xs'"
   using minimal_sequence_to_failure_extending_implies_Rep_Pre[OF assms]
         minimal_sequence_to_failure_extending_implies_Rep_Cov[OF assms]
   by linarith+
 
 
 subsection \<open> Sufficiency of the test suite to test for reduction \<close>
 
 text \<open>
 The following lemma proves that set of input sequences generated in the final iteration of the
 @{verbatim TS} function constitutes a test suite sufficient to test for reduction the FSMs it has 
 been generated for.
 
 This proof is performed by contradiction: If the test suite is not sufficient, then some minimal
 sequence to a failure extending the deterministic state cover must exist. Due to the test suite
 being assumed insufficient, this sequence cannot be contained in it and hence a prefix of it must
 have been contained in one of the sets calculated by the @{verbatim R} function. This is only 
 possible if the prefix is not a minimal sequence to a failure extending the deterministic state 
 cover or if the test suite observes a failure, both of which violates the assumptions.
 \<close>
 
 
 lemma asc_sufficiency :
   assumes "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "final_iteration M2 M1 \<Omega> V m i"  
 shows "M1 \<preceq>\<lbrakk>(TS M2 M1 \<Omega> V m i) . \<Omega>\<rbrakk> M2 \<longrightarrow> M1 \<preceq> M2"
 proof 
   assume "atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2"
   show "M1 \<preceq> M2"
   proof (rule ccontr)
   
     let ?TS = "\<lambda> n . TS M2 M1 \<Omega> V m n"
     let ?C = "\<lambda> n . C M2 M1 \<Omega> V m n"
     let ?RM = "\<lambda> n . RM M2 M1 \<Omega> V m n"
   
   
     assume "\<not> M1 \<preceq> M2"
     obtain vs xs where "minimal_sequence_to_failure_extending V M1 M2 vs xs" 
       using  assms(1) assms(2) assms(4) 
              minimal_sequence_to_failure_extending_det_state_cover_ob[OF _ _ _ _ \<open>\<not> M1 \<preceq> M2\<close>, of V]
       by blast 
   
     then have "vs \<in> L\<^sub>i\<^sub>n M1 V" 
               "sequence_to_failure M1 M2 (vs @ xs)" 
               "\<not> (\<exists> io' . \<exists> w' \<in> L\<^sub>i\<^sub>n M1 V . sequence_to_failure M1 M2 (w' @ io') 
                                                           \<and> length io' < length xs)"
       by auto
   
     then have "vs@xs \<in> L M1 - L M2" 
       by auto
   
     have "vs@xs \<in> L\<^sub>i\<^sub>n M1 {map fst (vs@xs)}"
       by (metis (full_types) Diff_iff \<open>vs @ xs \<in> L M1 - L M2\<close> insertI1 
           language_state_for_inputs_map_fst)
   
     have "vs@xs \<notin> L\<^sub>i\<^sub>n M2 {map fst (vs@xs)}"
       by (meson Diff_iff \<open>vs @ xs \<in> L M1 - L M2\<close> language_state_for_inputs_in_language_state 
           subsetCE) 
   
     have "finite V" 
       using det_state_cover_finite assms(4,2) by auto
     then have "finite (?TS i)"
       using TS_finite[of V M2] assms(2) by auto
     then have "io_reduction_on M1 (?TS i) M2" 
       using io_reduction_from_atc_io_reduction
             [OF \<open>atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2\<close>] 
       by auto
   
     have "map fst (vs@xs) \<notin> ?TS i"
     proof -
       have f1: "\<forall>ps P Pa. (ps::('a \<times> 'b) list) \<notin> P - Pa \<or> ps \<in> P \<and> ps \<notin> Pa"
         by blast
       have "\<forall>P Pa ps. \<not> P \<subseteq> Pa \<or> (ps::('a \<times> 'b) list) \<in> Pa \<or> ps \<notin> P"
         by blast
       then show ?thesis
         using f1 by (metis (no_types) \<open>vs @ xs \<in> L M1 - L M2\<close> \<open>io_reduction_on M1 (?TS i) M2\<close> 
                      language_state_for_inputs_in_language_state language_state_for_inputs_map_fst)
     qed 
   
     have "map fst vs \<in> V"
       using \<open>vs \<in> L\<^sub>i\<^sub>n M1 V\<close> by auto 
     
     let ?stf = "map fst (vs@xs)"
     let ?stfV = "map fst vs"
     let ?stfX = "map fst xs"
     have "?stf = ?stfV @ ?stfX"
       by simp 
   
     then have "?stfV @ ?stfX \<notin> ?TS i"
       using \<open>?stf \<notin> ?TS i\<close> by auto 
   
     have "mcp (?stfV @ ?stfX) V ?stfV"
       by (metis \<open>map fst (vs @ xs) = map fst vs @ map fst xs\<close> 
           \<open>minimal_sequence_to_failure_extending V M1 M2 vs xs\<close> assms(1) assms(2) assms(4) 
           minimal_sequence_to_failure_extending_mcp)
   
     have "set ?stf \<subseteq> inputs M1"
       by (meson DiffD1 \<open>vs @ xs \<in> L M1 - L M2\<close> assms(1) language_state_inputs) 
     then have "set ?stf \<subseteq> inputs M2"
       using assms(3) by blast 
     moreover have "set ?stf = set ?stfV \<union> set ?stfX"
       by simp 
     ultimately have "set ?stfX \<subseteq> inputs M2"
       by blast 
   
   
     obtain xr j where "xr \<noteq> ?stfX" 
                       "prefix xr ?stfX" 
                       "Suc j \<le> i" 
                       "?stfV@xr \<in> RM M2 M1 \<Omega> V m (Suc j)"
       using TS_non_containment_causes_final_suc[OF \<open>?stfV @ ?stfX \<notin> ?TS i\<close> 
             \<open>mcp (?stfV @ ?stfX) V ?stfV\<close> \<open>set ?stfX \<subseteq> inputs M2\<close> assms(5,2)] 
       by blast
   
     
     let ?yr = "take (length xr) (map snd xs)"
     have "length ?yr = length xr"
       using \<open>prefix xr (map fst xs)\<close> prefix_length_le by fastforce 
     have "(xr || ?yr) = take (length xr) xs"
       by (metis (no_types, hide_lams) \<open>prefix xr (map fst xs)\<close> append_eq_conv_conj prefixE take_zip
           zip_map_fst_snd) 
   
     have "prefix (vs@(xr || ?yr)) (vs@xs)"
       by (simp add: \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> take_is_prefix)
   
     have "xr = take (length xr) (map fst xs)"
       by (metis \<open>length (take (length xr) (map snd xs)) = length xr\<close> 
           \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> map_fst_zip take_map) 
   
     have "vs@(xr || ?yr) \<in> L M1"
       by (metis DiffD1 \<open>prefix (vs @ (xr || take (length xr) (map snd xs))) (vs @ xs)\<close> 
           \<open>vs @ xs \<in> L M1 - L M2\<close> language_state_prefix prefixE) 
   
     then have "vs@(xr || ?yr) \<in> L\<^sub>i\<^sub>n M1 {?stfV @ xr}"
       by (metis \<open>length (take (length xr) (map snd xs)) = length xr\<close> insertI1 
           language_state_for_inputs_map_fst map_append map_fst_zip) 
   
     have "length xr < length xs"
       by (metis \<open>xr = take (length xr) (map fst xs)\<close> \<open>xr \<noteq> map fst xs\<close> not_le_imp_less take_all 
           take_map)
   
   
   
     from \<open>?stfV@xr \<in> RM M2 M1 \<Omega> V m (Suc j)\<close> have "?stfV@xr \<in> {xs' \<in> C M2 M1 \<Omega> V m (Suc j) .
         (\<not> (L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}))
         \<or> (\<forall> io \<in> L\<^sub>i\<^sub>n M1 {xs'} .
             (\<exists> V'' \<in> N io M1 V .  
               (\<exists> S1 . 
                 (\<exists> vs xs .
                   io = (vs@xs)
                   \<and> mcp (vs@xs) V'' vs
                   \<and> S1 \<subseteq> nodes M2
                   \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                     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> ))
                   \<and> m < LB M2 M1 vs xs (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V'' ))))}" 
       unfolding RM.simps by blast
   
     moreover have "\<forall> xs' \<in> ?C (Suc j) . L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}"
     proof 
       fix xs' assume "xs' \<in> ?C (Suc j)"
       from \<open>Suc j \<le> i\<close> have "?C (Suc j) \<subseteq> ?TS i"
         using C_subset TS_subset by blast 
       then have "{xs'} \<subseteq> ?TS i" 
         using \<open>xs' \<in> ?C (Suc j)\<close> by blast
       show "L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}" 
         using io_reduction_on_subset[OF \<open>io_reduction_on M1 (?TS i) M2\<close> \<open>{xs'} \<subseteq> ?TS i\<close>] 
         by assumption
     qed
   
     ultimately have "(\<forall> io \<in> L\<^sub>i\<^sub>n M1 {?stfV@xr} .
             (\<exists> V'' \<in> N io M1 V .  
               (\<exists> S1 . 
                 (\<exists> vs xs .
                   io = (vs@xs)
                   \<and> mcp (vs@xs) V'' vs
                   \<and> S1 \<subseteq> nodes M2
                   \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                     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> ))
                   \<and> m < LB M2 M1 vs xs (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V'' ))))"
       by blast 
   
     then have "
             (\<exists> V'' \<in> N (vs@(xr || ?yr)) M1 V .  
               (\<exists> S1 . 
                 (\<exists> vs' xs' .
                   vs@(xr || ?yr) = (vs'@xs')
                   \<and> mcp (vs'@xs') V'' vs'
                   \<and> S1 \<subseteq> nodes M2
                   \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                     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> ))
                   \<and> m < LB M2 M1 vs' xs' (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V'' )))"
       using \<open>vs@(xr || ?yr) \<in> L\<^sub>i\<^sub>n M1 {?stfV @ xr}\<close>
       by blast 
   
     then obtain V'' S1 vs' xs' where RM_impl :  
                                      "V'' \<in> N (vs@(xr || ?yr)) M1 V"
                                      "vs@(xr || ?yr) = (vs'@xs')"
                                      "mcp (vs'@xs') V'' vs'"
                                      "S1 \<subseteq> nodes M2"
                                      "(\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                                        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> ))"
                                      " m < LB M2 M1 vs' xs' (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V''"
       by blast
   
    
     have "?stfV = mcp' (map fst (vs @ (xr || take (length xr) (map snd xs)))) V"
       by (metis (full_types) \<open>length (take (length xr) (map snd xs)) = length xr\<close> 
           \<open>mcp (map fst vs @ map fst xs) V (map fst vs)\<close> \<open>prefix xr (map fst xs)\<close> map_append 
           map_fst_zip mcp'_intro mcp_prefix_of_suffix) 
   
     have "is_det_state_cover M2 V"
       using assms(4) by blast 
     moreover have "well_formed M2" 
       using assms(2) by auto
     moreover have "finite V" 
       using det_state_cover_finite assms(4,2) by auto
     ultimately have "vs \<in> V''"  
                     "vs = mcp' (vs @ (xr || take (length xr) (map snd xs))) V''"
       using N_mcp_prefix[OF \<open>?stfV = mcp' (map fst (vs @ (xr || take (length xr) (map snd xs)))) V\<close> 
             \<open>V'' \<in> N (vs@(xr || ?yr)) M1 V\<close>, of M2] 
       by simp+
     
     have "vs' = vs"
       by (metis (no_types) \<open>mcp (vs' @ xs') V'' vs'\<close> 
           \<open>vs = mcp' (vs @ (xr || take (length xr) (map snd xs))) V''\<close> 
           \<open>vs @ (xr || take (length xr) (map snd xs)) = vs' @ xs'\<close> mcp'_intro)
      
     then have "xs' = (xr || ?yr)"
       using \<open>vs @ (xr || take (length xr) (map snd xs)) = vs' @ xs'\<close> by blast  
   
   
     have "V \<subseteq> ?TS i"
     proof -
       have "1 \<le> i"
         using \<open>Suc j \<le> i\<close> by linarith
       then have "?TS 1 \<subseteq> ?TS i"
         using TS_subset by blast   
       then show ?thesis 
         by auto
     qed
       
     have "?stfV@xr \<in> ?C (Suc j)" 
       using \<open>?stfV@xr \<in> RM M2 M1 \<Omega> V m (Suc j)\<close> unfolding RM.simps by blast
   
   
   
     \<comment> \<open>show that the prerequisites (@{verbatim Prereq}) for @{verbatim LB} are met by construction\<close>
   
     have "(\<forall>vs'a\<in>V''. prefix vs'a (vs' @ xs') \<longrightarrow> length vs'a \<le> length vs')"
       using \<open>mcp (vs' @ xs') V'' vs'\<close> by auto
   
     moreover have "atc_io_reduction_on_sets M1 (?TS j \<union> V) \<Omega> M2"   
     proof -
       have "j < i" 
         using \<open>Suc j \<le> i\<close> by auto
       then have "?TS j \<subseteq> ?TS i" 
         by (simp add: TS_subset) 
       then show ?thesis 
         using atc_io_reduction_on_subset
               [OF \<open>atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2\<close>, of "?TS j"]
         by (meson Un_subset_iff \<open>V \<subseteq> ?TS i\<close> \<open>atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2\<close>
             atc_io_reduction_on_subset) 
     qed
   
     moreover have "finite (?TS j \<union> V)"
     proof -
       have "finite (?TS j)"
         using TS_finite[OF \<open>finite V\<close>, of M2 M1 \<Omega> m j] assms(2) by auto 
       then show ?thesis 
         using \<open>finite V\<close> by blast
     qed
   
     moreover have "V \<subseteq> ?TS j \<union> V" 
       by blast
   
     moreover have "(\<forall> p . (prefix p xs' \<and> p \<noteq> xs') \<longrightarrow> map fst (vs' @ p) \<in> ?TS j \<union> V)"
     proof 
       fix p 
       show "prefix p xs' \<and> p \<noteq> xs' \<longrightarrow> map fst (vs' @ p) \<in> TS M2 M1 \<Omega> V m j \<union> V"
       proof
         assume "prefix p xs' \<and> p \<noteq> xs'"
   
         have "prefix (map fst (vs' @ p)) (map fst (vs' @ xs'))"
           by (simp add: \<open>prefix p xs' \<and> p \<noteq> xs'\<close> map_mono_prefix)
         have "prefix (map fst (vs' @ p)) (?stfV @ xr)"
           using \<open>length (take (length xr) (map snd xs)) = length xr\<close> 
                 \<open>prefix (map fst (vs' @ p)) (map fst (vs' @ xs'))\<close> 
                 \<open>vs' = vs\<close> \<open>xs' = xr || take (length xr) (map snd xs)\<close> 
           by auto
         then have "prefix (map fst vs' @ map fst p) (?stfV @ xr)"
           by simp 
         then have "prefix (map fst p) xr"
           by (simp add: \<open>vs' = vs\<close>)
   
         have "?stfV @ xr \<in> ?TS (Suc j)" 
         proof (cases j)
           case 0
           then show ?thesis
             using \<open>map fst vs @ xr \<in> C M2 M1 \<Omega> V m (Suc j)\<close> by auto  
         next
           case (Suc nat)
           then show ?thesis
             using TS.simps(3) \<open>map fst vs @ xr \<in> C M2 M1 \<Omega> V m (Suc j)\<close> by blast 
         qed
   
         have "mcp (map fst vs @ xr) V (map fst vs)"
           using \<open>mcp (map fst vs @ map fst xs) V (map fst vs)\<close> \<open>prefix xr (map fst xs)\<close> 
                 mcp_prefix_of_suffix 
           by blast 
   
         have "map fst vs @ map fst p \<in> TS M2 M1 \<Omega> V m (Suc j)"
           using TS_prefix_containment[OF \<open>?stfV @ xr \<in> ?TS (Suc j)\<close> 
                                          \<open>mcp (map fst vs @ xr) V (map fst vs)\<close> 
                                          \<open>prefix (map fst p) xr\<close>] 
           by assumption
    
   
         have "Suc (length xr) = (Suc j)" 
           using C_index[OF \<open>?stfV@xr \<in> ?C (Suc j)\<close> \<open>mcp (map fst vs @ xr) V (map fst vs)\<close>] 
           by assumption
         
         have"Suc (length p) < (Suc j)"
         proof -
           have "map fst xs' = xr"
             by (metis \<open>xr = take (length xr) (map fst xs)\<close> 
                 \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> 
                 \<open>xs' = xr || take (length xr) (map snd xs)\<close> take_map)
           then show ?thesis
             by (metis (no_types) Suc_less_eq \<open>Suc (length xr) = Suc j\<close> \<open>prefix p xs' \<and> p \<noteq> xs'\<close> 
                 append_eq_conv_conj length_map nat_less_le prefixE prefix_length_le take_all)
         qed
   
         have "mcp (map fst vs @ map fst p) V (map fst vs)"
           using \<open>mcp (map fst vs @ xr) V (map fst vs)\<close> \<open>prefix (map fst p) xr\<close> mcp_prefix_of_suffix 
           by blast 
   
         then have "map fst vs @ map fst p \<in> ?C (Suc (length (map fst p)))" 
           using TS_index(2)[OF \<open>map fst vs @ map fst p \<in> TS M2 M1 \<Omega> V m (Suc j)\<close>] by auto
   
         have "map fst vs @ map fst p \<in> ?TS j"
           using TS_union[of M2 M1 \<Omega> V m j]
         proof -
           have "Suc (length p) \<in> {0..<Suc j}"
             using \<open>Suc (length p) < Suc j\<close> by force
           then show ?thesis
             by (metis UN_I \<open>TS M2 M1 \<Omega> V m j = (\<Union>j\<in>set [0..<Suc j]. C M2 M1 \<Omega> V m j)\<close> 
                 \<open>map fst vs @ map fst p \<in> C M2 M1 \<Omega> V m (Suc (length (map fst p)))\<close> 
                 length_map set_upt)
         qed 
   
         then show "map fst (vs' @ p) \<in> TS M2 M1 \<Omega> V m j \<union> V"
           by (simp add: \<open>vs' = vs\<close>) 
       qed
     qed
   
     
     moreover have "vs' @ xs' \<in> L M2 \<inter> L M1"
       by (metis (no_types, lifting) IntI RM_impl(2) 
           \<open>\<forall>xs'\<in>C M2 M1 \<Omega> V m (Suc j). L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}\<close> 
           \<open>map fst vs @ xr \<in> C M2 M1 \<Omega> V m (Suc j)\<close> 
           \<open>vs @ (xr || take (length xr) (map snd xs)) \<in> L\<^sub>i\<^sub>n M1 {map fst vs @ xr}\<close> 
           language_state_for_inputs_in_language_state subsetCE)
       
           
     
     ultimately have "Prereq M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V''"
       using RM_impl(4,5) unfolding Prereq.simps by blast
   
     have "V'' \<in> Perm V M1"
       using \<open>V'' \<in> N (vs@(xr || ?yr)) M1 V\<close> unfolding N.simps by blast
   
     have \<open>prefix (xr || ?yr) xs\<close>
       by (simp add: \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> take_is_prefix)
   
   
     \<comment> \<open> show that furthermore neither @{verbatim Rep_Pre} nor @{verbatim Rep_Cov} holds \<close>
 
     have "\<not> Rep_Pre M2 M1 vs (xr || ?yr)"
       using minimal_sequence_to_failure_extending_implies_Rep_Pre
             [OF \<open>minimal_sequence_to_failure_extending V M1 M2 vs xs\<close> assms(1,2) 
                 \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close> RM_impl(1) 
                 \<open>prefix (xr || take (length xr) (map snd xs)) xs\<close>]
       by assumption
     then have "\<not> Rep_Pre M2 M1 vs' xs'"
       using \<open>vs' = vs\<close> \<open>xs' = xr || ?yr\<close> by blast 
   
     have "\<not> Rep_Cov M2 M1 V'' vs (xr || ?yr)" 
       using minimal_sequence_to_failure_extending_implies_Rep_Cov
             [OF \<open>minimal_sequence_to_failure_extending V M1 M2 vs xs\<close> assms(1,2) 
                 \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close> RM_impl(1) 
                 \<open>prefix (xr || take (length xr) (map snd xs)) xs\<close>]
       by assumption
     then have "\<not> Rep_Cov M2 M1 V'' vs' xs'"
       using \<open>vs' = vs\<close> \<open>xs' = xr || ?yr\<close> by blast 
   
     have "vs'@xs' \<in> L M1"
       using \<open>vs @ (xr || take (length xr) (map snd xs)) \<in> L M1\<close> 
             \<open>vs' = vs\<close> \<open>xs' = xr || take (length xr) (map snd xs)\<close> 
       by blast 
     
   
     \<comment> \<open> therefore it is impossible to remove the prefix of the minimal sequence to a failure,
          as this would require @{verbatim M1} to have more than m states \<close>
     
     have "LB M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V'' \<le> card (nodes M1)"
       using LB_count[OF \<open>vs'@xs' \<in> L M1\<close> assms(1,2,3) \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close> 
                         \<open>V'' \<in> Perm V M1\<close> \<open>Prereq M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V''\<close> 
                         \<open>\<not> Rep_Pre M2 M1 vs' xs'\<close> \<open> \<not> Rep_Cov M2 M1 V'' vs' xs'\<close>]
       by assumption
     then have "LB M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V'' \<le> m" 
       using assms(3) by linarith
   
     then show "False" 
       using \<open>m < LB M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V''\<close> by linarith
   qed
 qed
 
 
 
 
 subsection \<open> Main result \<close>
 
 text \<open>
 The following lemmata add to the previous result to show that some FSM @{verbatim M1} is a reduction 
 of FSM @{verbatim M2} if and only if it is a reduction on the test suite generated by the adaptive 
 state counting algorithm for these FSMs.
 \<close>
 
 lemma asc_soundness :
   assumes     "OFSM M1"
   and         "OFSM M2"
 shows "M1 \<preceq> M2 \<longrightarrow> atc_io_reduction_on_sets M1 T \<Omega> M2"
   using atc_io_reduction_on_sets_reduction assms by blast
 
 
 
 lemma asc_main_theorem :
   assumes "OFSM M1"
   and     "OFSM M2"
   and     "asc_fault_domain M2 M1 m"
   and     "test_tools M2 M1 FAIL PM V \<Omega>"
   and     "final_iteration M2 M1 \<Omega> V m i"
 shows     "M1 \<preceq> M2 \<longleftrightarrow> atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2"
 by (metis asc_sufficiency assms(1-5) atc_io_reduction_on_sets_reduction)
 
 
 
 
 end
\ No newline at end of file
diff --git a/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy b/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
--- a/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
+++ b/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
@@ -1,939 +1,925 @@
 section \<open>CCW for Arbitrary Points in the Plane\<close>
 theory Counterclockwise_2D_Arbitrary
 imports Counterclockwise_2D_Strict
 begin
 
 subsection \<open>Interpretation of Knuth's axioms in the plane\<close>
 
 definition lex::"point \<Rightarrow> point \<Rightarrow> bool" where
   "lex p q \<longleftrightarrow> (fst p < fst q \<or> fst p = fst q \<and> snd p < snd q \<or> p = q)"
 
 definition psi::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
   "psi p q r \<longleftrightarrow> (lex p q \<and> lex q r)"
 
 definition ccw::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
   "ccw p q r \<longleftrightarrow> ccw' p q r \<or> (det3 p q r = 0 \<and> (psi p q r \<or> psi q r p \<or> psi r p q))"
 
 interpretation ccw: linorder_list0 "ccw x" for x .
 
 lemma ccw'_imp_ccw: "ccw' a b c \<Longrightarrow> ccw a b c"
   by (simp add: ccw_def)
 
 lemma ccw_ncoll_imp_ccw: "ccw a b c \<Longrightarrow> \<not>coll a b c \<Longrightarrow> ccw' a b c"
   by (simp add: ccw_def)
 
 lemma ccw_translate: "ccw p (p + q) (p + r) = ccw 0 q r"
   by (auto simp: ccw_def psi_def lex_def)
 
 lemma ccw_translate_origin: "NO_MATCH 0 p \<Longrightarrow> ccw p q r = ccw 0 (q - p) (r - p)"
   using ccw_translate[of p "q - p" "r - p"]
   by simp
 
 lemma psi_scale:
   "psi (r *\<^sub>R a) (r *\<^sub>R b) 0 = (if r > 0 then psi a b 0 else if r < 0 then psi 0 b a else True)"
   "psi (r *\<^sub>R a) 0 (r *\<^sub>R b) = (if r > 0 then psi a 0 b else if r < 0 then psi b 0 a else True)"
   "psi 0 (r *\<^sub>R a) (r *\<^sub>R b) = (if r > 0 then psi 0 a b else if r < 0 then psi b a 0 else True)"
   by (auto simp: psi_def lex_def det3_def' not_less algebra_split_simps)
 
 lemma ccw_scale23: "ccw 0 a b \<Longrightarrow> r > 0 \<Longrightarrow> ccw 0 (r *\<^sub>R a) (r *\<^sub>R b)"
   by (auto simp: ccw_def psi_scale)
 
 lemma psi_notI: "distinct3 p q r \<Longrightarrow> psi p q r \<Longrightarrow> \<not> psi q p r"
   by (auto simp: algebra_simps psi_def lex_def)
 
-lemma not_lex_eq: "\<not> lex a b \<longleftrightarrow> lex b a \<and> a \<noteq> b"
+lemma not_lex_eq: "\<not> lex a b \<longleftrightarrow> lex b a \<and> b \<noteq> a"
   by (auto simp: algebra_simps lex_def prod_eq_iff)
 
 lemma lex_trans: "lex a b \<Longrightarrow> lex b c \<Longrightarrow> lex a c"
   by (auto simp: lex_def)
 
 lemma lex_sym_eqI: "lex a b \<Longrightarrow> lex b a \<Longrightarrow> a = b"
   and lex_sym_eq_iff: "lex a b \<Longrightarrow> lex b a \<longleftrightarrow> a = b"
   by (auto simp: lex_def)
 
 lemma lex_refl[simp]: "lex p p"
   by (metis not_lex_eq)
 
 lemma psi_disjuncts:
   "distinct3 p q r \<Longrightarrow> psi p q r \<or> psi p r q \<or> psi q r p \<or> psi q p r \<or> psi r p q \<or> psi r q p"
   by (auto simp: psi_def not_lex_eq)
 
 lemma nlex_ccw_left: "lex x 0 \<Longrightarrow> ccw 0 (0, 1) x"
   by (auto simp: ccw_def lex_def psi_def ccw'_def det3_def')
 
 interpretation ccw_system123 ccw
   apply unfold_locales
   subgoal by (force simp: ccw_def ccw'_def det3_def' algebra_simps)
   subgoal by (force simp: ccw_def ccw'_def det3_def' psi_def algebra_simps lex_sym_eq_iff)
   subgoal by (drule psi_disjuncts) (force simp: ccw_def ccw'_def det3_def' algebra_simps)
   done
 
 lemma lex_scaleR_nonneg: "lex a b \<Longrightarrow> r \<ge> 0 \<Longrightarrow> lex a (a + r *\<^sub>R (b - a))"
   by (auto simp: lex_def)
 
 lemma lex_scale1_zero:
     "lex (v *\<^sub>R u) 0 = (if v > 0 then lex u 0 else if v < 0 then lex 0 u else True)"
   and lex_scale2_zero:
     "lex 0 (v *\<^sub>R u) = (if v > 0 then lex 0 u else if v < 0 then lex u 0 else True)"
   by (auto simp: lex_def prod_eq_iff less_eq_prod_def algebra_split_simps)
 
 lemma nlex_add:
   assumes "lex a 0" "lex b 0"
   shows "lex (a + b) 0"
   using assms by (auto simp: lex_def)
 
 lemma nlex_sum:
   assumes "finite X"
   assumes "\<And>x. x \<in> X \<Longrightarrow> lex (f x) 0"
   shows "lex (sum f X) 0"
   using assms
   by induction (auto intro!: nlex_add)
 
 lemma abs_add_nlex:
   assumes "coll 0 a b"
   assumes "lex a 0"
   assumes "lex b 0"
   shows "abs (a + b) = abs a + abs b"
 proof (rule antisym[OF abs_triangle_ineq])
   have "fst (\<bar>a\<bar> + \<bar>b\<bar>) \<le> fst \<bar>a + b\<bar>"
     using assms
     by (auto simp add: det3_def' abs_prod_def lex_def)
   moreover
   {
     assume H: "fst a < 0" "fst b < 0"
     hence "snd b \<le> 0 \<longleftrightarrow> snd a \<le> 0"
       using assms
       by (auto simp: lex_def det3_def' mult.commute)
         (metis mult_le_cancel_left_neg mult_zero_right)+
     hence "\<bar>snd a\<bar> + \<bar>snd b\<bar> \<le> \<bar>snd a + snd b\<bar>"
       using H by auto
   } hence "snd (\<bar>a\<bar> + \<bar>b\<bar>) \<le> snd \<bar>a + b\<bar>"
     using assms
     by (auto simp add: det3_def' abs_prod_def lex_def)
   ultimately
   show "\<bar>a\<bar> + \<bar>b\<bar> \<le> \<bar>a + b\<bar>" unfolding less_eq_prod_def ..
 qed
 
 lemma lex_sum_list: "(\<And>x. x \<in> set xs \<Longrightarrow> lex x 0) \<Longrightarrow> lex (sum_list xs) 0"
   by (induct xs) (auto simp: nlex_add)
 
 lemma
   abs_sum_list_coll:
   assumes coll: "list_all (coll 0 x) xs"
   assumes "x \<noteq> 0"
   assumes up: "list_all (\<lambda>x. lex x 0) xs"
   shows "abs (sum_list xs) = sum_list (map abs xs)"
   using assms
 proof (induct xs)
   case (Cons y ys)
   hence "coll 0 x y" "coll 0 x (sum_list ys)"
     by (auto simp: list_all_iff intro!: coll_sum_list)
   hence "coll 0 y (sum_list ys)" using \<open>x \<noteq> 0\<close>
     by (rule coll_trans)
   hence "\<bar>y + sum_list ys\<bar> = abs y + abs (sum_list ys)" using Cons
     by (subst abs_add_nlex) (auto simp: list_all_iff lex_sum_list)
   thus ?case using Cons by simp
 qed simp
 
 lemma lex_diff1: "lex (a - b) c = lex a (c + b)"
   and lex_diff2: "lex c (a - b) = lex (c + b) a"
   by (auto simp: lex_def)
 
 lemma sum_list_eq_0_iff_nonpos:
   fixes xs::"'a::ordered_ab_group_add list"
   shows "list_all (\<lambda>x. x \<le> 0) xs \<Longrightarrow> sum_list xs = 0 \<longleftrightarrow> (\<forall>n\<in>set xs. n = 0)"
   by (auto simp: list_all_iff sum_list_sum_nth sum_nonpos_eq_0_iff)
     (auto simp add: in_set_conv_nth)
 
 lemma sum_list_nlex_eq_zeroI:
   assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
   assumes "sum_list xs = 0"
   assumes "x \<in> set xs"
   shows "x = 0"
 proof -
   from assms(2) have z1: "sum_list (map fst xs) = 0" and z2: "sum_list (map snd xs) = 0"
     by (auto simp: prod_eq_iff fst_sum_list snd_sum_list)
   from nlex have "list_all (\<lambda>x. x \<le> 0) (map fst xs)"
     by (auto simp: lex_def list_all_iff)
   from sum_list_eq_0_iff_nonpos[OF this] z1 nlex
   have
     z1': "list_all (\<lambda>x. x = 0) (map fst xs)"
     and "list_all (\<lambda>x. x \<le> 0) (map snd xs)"
     by (auto simp: list_all_iff lex_def)
   from sum_list_eq_0_iff_nonpos[OF this(2)] z2
   have "list_all (\<lambda>x. x = 0) (map snd xs)" by (simp add: list_all_iff)
   with z1' show "x = 0" by (auto simp: list_all_iff zero_prod_def assms prod_eq_iff)
 qed
 
 lemma sum_list_eq0I: "(\<forall>x\<in>set xs. x = 0) \<Longrightarrow> sum_list xs = 0"
   by (induct xs) auto
 
 lemma sum_list_nlex_eq_zero_iff:
   assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
   shows "sum_list xs = 0 \<longleftrightarrow> list_all ((=) 0) xs"
   using assms
   by (auto intro: sum_list_nlex_eq_zeroI sum_list_eq0I simp: list_all_iff)
 
 lemma
   assumes "lex p q" "lex q r" "0 \<le> a" "0 \<le> b" "0 \<le> c" "a + b + c = 1"
   assumes comb_def: "comb = a *\<^sub>R p + b *\<^sub>R q + c *\<^sub>R r"
   shows lex_convex3: "lex p comb" "lex comb r"
 proof -
   from convex3_alt[OF assms(3-6), of p q r]
   obtain u v where
     uv: "a *\<^sub>R p + b *\<^sub>R q + c *\<^sub>R r = p + u *\<^sub>R (q - p) + v *\<^sub>R (r - p)" "0 \<le> u" "0 \<le> v" "u + v \<le> 1" .
   have "lex p r"
     using assms by (metis lex_trans)
   hence "lex (v *\<^sub>R (p - r)) 0" using uv
     by (simp add: lex_scale1_zero lex_diff1)
   also
   have "lex 0 (u *\<^sub>R (q - p))" using \<open>lex p q\<close> uv
     by (simp add: lex_scale2_zero lex_diff2)
   finally (lex_trans)
   show "lex p comb"
     unfolding comb_def uv
     by (simp add: lex_def prod_eq_iff algebra_simps)
   from comb_def have comb_def': "comb = c *\<^sub>R r + b *\<^sub>R q + a *\<^sub>R p" by simp
   from assms have "c + b + a = 1" by simp
   from convex3_alt[OF assms(5,4,3) this, of r q p]
   obtain u v where uv: "c *\<^sub>R r + b *\<^sub>R q + a *\<^sub>R p = r + u *\<^sub>R (q - r) + v *\<^sub>R (p - r)"
     "0 \<le> u" "0 \<le> v" "u + v \<le> 1"
     by auto
   have "lex (u *\<^sub>R (q - r)) 0"
     using uv \<open>lex q r\<close>
     by (simp add: lex_scale1_zero lex_diff1)
   also have "lex 0  (v *\<^sub>R (r - p))"
     using uv \<open>lex p r\<close>
     by (simp add: lex_scale2_zero lex_diff2)
   finally (lex_trans) show "lex comb r"
     unfolding comb_def' uv
     by (simp add: lex_def prod_eq_iff algebra_simps)
 qed
 
 lemma lex_convex_self2:
   assumes "lex p q" "0 \<le> a" "a \<le> 1"
   defines "r \<equiv> a *\<^sub>R p + (1 - a) *\<^sub>R q"
   shows "lex p r" (is ?th1)
     and "lex r q" (is ?th2)
   using lex_convex3[OF \<open>lex p q\<close>, of q a "1 - a" 0 r]
       assms
   by (simp_all add: r_def)
 
 lemma lex_uminus0[simp]: "lex (-a) 0 = lex 0 a"
   by (auto simp: lex_def)
 
 lemma
   lex_fst_zero_imp:
   "fst x = 0 \<Longrightarrow> lex x 0 \<Longrightarrow> lex y 0 \<Longrightarrow> \<not>coll 0 x y \<Longrightarrow> ccw' 0 y x"
   by (auto simp: ccw'_def det3_def' lex_def algebra_split_simps)
 
 lemma lex_ccw_left: "lex x y \<Longrightarrow> r > 0 \<Longrightarrow> ccw y (y + (0, r)) x"
   by (auto simp: ccw_def ccw'_def det3_def' algebra_simps lex_def psi_def)
 
 lemma lex_translate_origin: "NO_MATCH 0 a \<Longrightarrow> lex a b = lex 0 (b - a)"
   by (auto simp: lex_def)
 
 
 subsection \<open>Order prover setup\<close>
 
 definition "lexs p q \<longleftrightarrow> (lex p q \<and> p \<noteq> q)"
 
 lemma lexs_irrefl: "\<not> lexs p p"
   and lexs_imp_lex: "lexs x y \<Longrightarrow> lex x y"
   and not_lexs: "(\<not> lexs x y) = (lex y x)"
   and not_lex: "(\<not> lex x y) = (lexs y x)"
   and eq_lex_refl: "x = y \<Longrightarrow> lex x y"
   by (auto simp: lexs_def lex_def prod_eq_iff)
 
 lemma lexs_trans: "lexs x y \<Longrightarrow> lexs y z \<Longrightarrow> lexs x z"
   and lexs_lex_trans: "lexs x y \<Longrightarrow> lex y z \<Longrightarrow> lexs x z"
   and lex_lexs_trans: "lex x y \<Longrightarrow> lexs y z \<Longrightarrow> lexs x z"
   and lex_neq_trans: "lex a b \<Longrightarrow> a \<noteq> b \<Longrightarrow> lexs a b"
   and neq_lex_trans: "a \<noteq> b \<Longrightarrow> lex a b \<Longrightarrow> lexs a b"
   and lexs_imp_neq: "lexs a b \<Longrightarrow> a \<noteq> b"
   by (auto simp: lexs_def lex_def prod_eq_iff)
 
-declare
-  lexs_irrefl[THEN notE, order add less_reflE: linorder "(=) :: point => point => bool" lex lexs]
-declare lex_refl[order add le_refl: linorder "(=) :: point => point => bool" lex lexs]
-declare lexs_imp_lex[order add less_imp_le: linorder "(=) :: point => point => bool" lex lexs]
-declare
-  not_lexs[THEN iffD2, order add not_lessI: linorder "(=) :: point => point => bool" lex lexs]
-declare not_lex[THEN iffD2, order add not_leI: linorder "(=) :: point => point => bool" lex lexs]
-declare
-  not_lexs[THEN iffD1, order add not_lessD: linorder "(=) :: point => point => bool" lex lexs]
-declare not_lex[THEN iffD1, order add not_leD: linorder "(=) :: point => point => bool" lex lexs]
-declare lex_sym_eqI[order add eqI: linorder "(=) :: point => point => bool" lex lexs]
-declare eq_lex_refl[order add eqD1: linorder "(=) :: point => point => bool" lex lexs]
-declare sym[THEN eq_lex_refl, order add eqD2: linorder "(=) :: point => point => bool" lex lexs]
-declare lexs_trans[order add less_trans: linorder "(=) :: point => point => bool" lex lexs]
-declare lexs_lex_trans[order add less_le_trans: linorder "(=) :: point => point => bool" lex lexs]
-declare lex_lexs_trans[order add le_less_trans: linorder "(=) :: point => point => bool" lex lexs]
-declare lex_trans[order add le_trans: linorder "(=) :: point => point => bool" lex lexs]
-declare lex_neq_trans[order add le_neq_trans: linorder "(=) :: point => point => bool" lex lexs]
-declare neq_lex_trans[order add neq_le_trans: linorder "(=) :: point => point => bool" lex lexs]
-declare lexs_imp_neq[order add less_imp_neq: linorder "(=) :: point => point => bool" lex lexs]
-declare
-  eq_neq_eq_imp_neq[order add eq_neq_eq_imp_neq: linorder "(=) :: point => point => bool" lex lexs]
-declare not_sym[order add not_sym: linorder "(=) :: point => point => bool" lex lexs]
-
+local_setup \<open>
+   HOL_Order_Tac.declare_linorder {
+    ops = {eq = @{term \<open>(=) :: point \<Rightarrow> point \<Rightarrow> bool\<close>}, le = @{term \<open>lex\<close>}, lt = @{term \<open>lexs\<close>}},
+    thms = {trans = @{thm lex_trans}, refl = @{thm lex_refl}, eqD1 = @{thm eq_lex_refl},
+            eqD2 = @{thm eq_lex_refl[OF sym]}, antisym = @{thm lex_sym_eqI}, contr = @{thm notE}},
+    conv_thms = {less_le = @{thm eq_reflection[OF lexs_def]},
+                 nless_le = @{thm eq_reflection[OF not_lexs]},
+                 nle_le = @{thm eq_reflection[OF not_lex_eq]}}
+  }
+\<close>
 
 subsection \<open>Contradictions\<close>
 
 lemma
   assumes d: "distinct4 s p q r"
   shows contra1: "\<not>(lex p q \<and> lex q r \<and> lex r s \<and> indelta s p q r)" (is ?th1)
     and contra2: "\<not>(lex s p \<and> lex p q \<and> lex q r \<and> indelta s p q r)" (is ?th2)
     and contra3: "\<not>(lex p r \<and> lex p s \<and> lex q r \<and> lex q s \<and> insquare p r q s)" (is ?th3)
 proof -
   {
     assume "det3 s p q = 0" "det3 s q r = 0" "det3 s r p = 0" "det3 p q r = 0"
     hence ?th1 ?th2 ?th3 using d
       by (auto simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
   } moreover {
     assume *: "\<not>(det3 s p q = 0 \<and> det3 s q r = 0 \<and> det3 s r p = 0 \<and> det3 p q r = 0)"
     {
       assume d0: "det3 p q r = 0"
       with d have "?th1 \<and> ?th2"
         by (force simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
     } moreover {
       assume dp: "det3 p q r \<noteq> 0"
       have "?th1 \<and> ?th2"
         unfolding de_Morgan_disj[symmetric]
       proof (rule notI, goal_cases)
         case prems: 1
         hence **: "indelta s p q r" by auto
         hence nonnegs: "det3 p q r \<ge> 0" "0 \<le> det3 s q r" "0 \<le> det3 p s r" "0 \<le> det3 p q s"
           by (auto simp: ccw_def ccw'_def det3_def' algebra_simps)
         hence det_pos: "det3 p q r > 0" using dp by simp
         have det_eq: "det3 s q r + det3 p s r + det3 p q s = det3 p q r"
           by (auto simp: ccw_def det3_def' algebra_simps)
         hence det_div_eq:
           "det3 s q r / det3 p q r + det3 p s r / det3 p q r + det3 p q s / det3 p q r = 1"
           using det_pos by (auto simp: field_simps)
         from lex_convex3[OF _ _ _ _ _ det_div_eq convex_comb_dets[OF det_pos, of s]]
         have "lex p s" "lex s r"
           using prems by (auto simp: nonnegs)
         with prems d show False by (simp add: lex_sym_eq_iff)
       qed
     } moreover have ?th3
     proof (safe, goal_cases)
       case prems: 1
       have nonnegs: "det3 p r q \<ge> 0" "det3 r q s \<ge> 0" "det3 s p r \<ge> 0" "det3 q s p \<ge> 0"
         using prems
         by (auto simp add: ccw_def ccw'_def less_eq_real_def)
       have dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
         by (auto simp: det3_def')
       hence **: "det3 p r q = 0 \<and> det3 q s p = 0 \<Longrightarrow> det3 r q s = 0 \<and> det3 s p r = 0"
         using prems
         by (auto simp: ccw_def ccw'_def)
       moreover
       {
         fix p r q s
         assume det_pos: "det3 p r q > 0"
         assume dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
         assume nonnegs:"det3 r q s \<ge> 0" "det3 s p r \<ge> 0" "det3 q s p \<ge> 0"
         assume g14: "lex p r" "lex p s" "lex q r" "lex q s"
         assume d: "distinct4 s p q r"
 
         let ?sum = "(det3 p r q + det3 q s p) / det3 p r q"
         have eqs: "det3 s p r = det3 p r s" "det3 r q s = det3 s r q" "det3 q s p = - det3 p s q"
           by (auto simp: det3_def' algebra_simps)
         from convex_comb_dets[OF det_pos, of s]
         have "((det3 p r q / det3 p r q) *\<^sub>R s + (det3 q s p / det3 p r q) *\<^sub>R r) /\<^sub>R ?sum =
             ((det3 r q s / det3 p r q) *\<^sub>R p + (det3 s p r / det3 p r q) *\<^sub>R q) /\<^sub>R ?sum"
           unfolding eqs
           by (simp add: algebra_simps prod_eq_iff)
         hence srpq: "(det3 p r q / det3 p r q / ?sum) *\<^sub>R s + (det3 q s p / det3 p r q / ?sum) *\<^sub>R r =
           (det3 r q s / det3 p r q / ?sum) *\<^sub>R p + (det3 s p r / det3 p r q  / ?sum) *\<^sub>R q"
           (is "?s *\<^sub>R s + ?r *\<^sub>R r = ?p *\<^sub>R p + ?q *\<^sub>R q")
           using det_pos
           by (simp add: algebra_simps inverse_eq_divide)
         have eqs: "?s + ?r = 1" "?p + ?q = 1"
           and s: "?s \<ge> 0" "?s \<le> 1"
           and r: "?r \<ge> 0" "?r \<le> 1"
           and p: "?p \<ge> 0" "?p \<le> 1"
           and q: "?q \<ge> 0" "?q \<le> 1"
           unfolding add_divide_distrib[symmetric]
           using det_pos nonnegs dets_eq
           by (auto)
         from eqs have eqs': "1 - ?s = ?r" "1 - ?r = ?s" "1 - ?p = ?q" "1 - ?q = ?p"
           by auto
         have comm: "?r *\<^sub>R r + ?s *\<^sub>R s = ?s *\<^sub>R s + ?r *\<^sub>R r"
           "?q *\<^sub>R q + ?p *\<^sub>R p = ?p *\<^sub>R p + ?q *\<^sub>R q"
           by simp_all
         define K
           where "K = (det3 r q s / det3 p r q / ?sum) *\<^sub>R p + (det3 s p r / det3 p r q  / ?sum) *\<^sub>R q"
         note rewrs = eqs' comm srpq K_def[symmetric]
         from lex_convex_self2[OF _ s, of s r, unfolded rewrs]
            lex_convex_self2[OF _ r, of r s, unfolded rewrs]
            lex_convex_self2[OF _ p, of p q, unfolded rewrs]
            lex_convex_self2[OF _ q, of q p, unfolded rewrs]
         have False using g14 d det_pos
           by (metis lex_trans not_lex_eq)
       } note wlog = this
       from dets_eq have 1: "det3 q s p + det3 p r q = det3 s p r + det3 r q s"
         by simp
       from d have d': "distinct4 r q p s" by auto
       note wlog[of q s p r, OF _ 1 nonnegs(3,2,1) prems(4,3,2,1) d']
         wlog[of p r q s, OF _ dets_eq nonnegs(2,3,4) prems(1-4) d]
       ultimately show False using nonnegs d *
         by (auto simp: less_eq_real_def det3_def' algebra_simps)
     qed
     ultimately have ?th1 ?th2 ?th3 by blast+
   } ultimately show ?th1 ?th2 ?th3 by force+
 qed
 
 lemma ccw'_subst_psi_disj:
   assumes "det3 t r s = 0"
   assumes "psi t r s \<or> psi t s r \<or> psi s r t"
   assumes "s \<noteq> t"
   assumes "ccw' t r p"
   shows "ccw' t s p"
 proof cases
   assume "r \<noteq> s"
   from assms have "r \<noteq> t" by (auto simp: det3_def' ccw'_def algebra_simps)
   from assms have "det3 r s t = 0"
     by (auto simp: algebra_simps det3_def')
   from coll_ex_scaling[OF assms(3) this]
   obtain x where s: "r = s + x *\<^sub>R (t - s)" by auto
   from assms(4)[simplified s]
   have "0 < det3 0 (s + x *\<^sub>R (t - s) - t) (p - t)"
     by (auto simp: algebra_simps det3_def' ccw'_def)
   also have "s + x *\<^sub>R (t - s) - t = (1 - x) *\<^sub>R (s - t)"
     by (simp add: algebra_simps)
   finally have ccw': "ccw' 0 ((1 - x) *\<^sub>R (s - t)) (p - t)"
     by (simp add: ccw'_def)
   hence neq: "x \<noteq> 1" by (auto simp add: det3_def' ccw'_def)
   have tr: "fst s < fst r \<Longrightarrow> fst t = fst s \<Longrightarrow> snd t \<le> snd r"
     by (simp add: s)
   from s have "fst (r - s) = fst (x *\<^sub>R (t - s))" "snd (r - s) = snd (x *\<^sub>R (t - s))"
     by (auto simp: )
   hence "x = (if fst (t - s) = 0 then snd (r - s) / snd (t - s) else fst (r - s) / fst (t - s))"
     using \<open>s \<noteq> t\<close>
     by (auto simp add: field_simps prod_eq_iff)
   also have "\<dots> \<le> 1"
     using assms
     by (auto simp: lex_def psi_def tr)
   finally have "x < 1" using neq by simp
   thus ?thesis using ccw'
     by (auto simp: ccw'.translate_origin)
 qed (insert assms, simp)
 
 lemma lex_contr:
   assumes "distinct4 t s q r"
   assumes "lex t s" "lex s r"
   assumes "det3 t s r = 0"
   assumes "ccw' t s q"
   assumes "ccw' t q r"
   shows "False"
   using ccw'_subst_psi_disj[of t s r q] assms
   by (cases "r = t") (auto simp: det3_def' algebra_simps psi_def ccw'_def)
 
 lemma contra4:
   assumes "distinct4 s r q p"
   assumes lex: "lex q p" "lex p r" "lex r s"
   assumes ccw: "ccw r q s" "ccw r s p" "ccw r q p"
   shows False
 proof cases
   assume c: "ccw s q p"
   from c have *: "indelta s r q p"
     using assms by simp
   with contra1[OF assms(1)]
   have "\<not> (lex r q \<and> lex q p \<and> lex p s)" by blast
   hence "\<not> lex q p"
     using \<open>ccw s q p\<close> contra1 cyclic assms nondegenerate by blast
   thus False using assms by simp
 next
   assume "\<not> ccw s q p"
   with ccw have "ccw q s p \<and> ccw s p r \<and> ccw p r q \<and> ccw r q s"
     by (metis assms(1) ccw'.cyclic ccw_def not_ccw'_eq psi_disjuncts)
   moreover
   from lex have "lex q r" "lex q s" "lex p r" "lex p s" by order+
   ultimately show False using contra3[of r q p s] \<open>distinct4 s r q p\<close> by blast
 qed
 
 lemma not_coll_ordered_lexI:
   assumes "l \<noteq> x0"
     and "lex x1 r"
     and "lex x1 l"
     and "lex r x0"
     and "lex l x0"
     and "ccw' x0 l x1"
     and "ccw' x0 x1 r"
   shows "det3 x0 l r \<noteq> 0"
 proof
   assume "coll x0 l r"
   from \<open>coll x0 l r\<close> have 1: "coll 0 (l - x0) (r - x0)"
     by (simp add: det3_def' algebra_simps)
   from \<open>lex r x0\<close> have 2: "lex (r - x0) 0" by (auto simp add: lex_def)
   from \<open>lex l x0\<close> have 3: "lex (l - x0) 0" by (auto simp add: lex_def)
   from \<open>ccw' x0 l x1\<close> have 4: "ccw' 0 (l - x0) (x1 - x0)"
     by (simp add: det3_def' ccw'_def algebra_simps)
   from \<open>ccw' x0 x1 r\<close> have 5: "ccw' 0 (x1 - x0) (r - x0)"
     by (simp add: det3_def' ccw'_def algebra_simps)
   from \<open>lex x1 r\<close> have 6: "lex 0 (r - x0 - (x1 - x0))" by (auto simp: lex_def)
   from \<open>lex x1 l\<close> have 7: "lex 0 (l - x0 - (x1 - x0))" by (auto simp: lex_def)
   define r' where "r' = r - x0"
   define l' where "l' = l - x0"
   define x0' where "x0' = x1 - x0"
   from 1 2 3 4 5 6 7
   have rs: "coll 0 l' r'" "lex r' 0"
     "lex l' 0"
     "ccw' 0 l' x0'"
     "ccw' 0 x0' r'"
     "lex 0 (r' - x0')"
     "lex 0 (l' - x0')"
     unfolding r'_def[symmetric] l'_def[symmetric] x0'_def[symmetric]
     by auto
   from assms have "l' \<noteq> 0"
     by (auto simp: l'_def)
   from coll_scale[OF \<open>coll 0 l' _\<close> this]
   obtain y where y: "r' = y *\<^sub>R l'" by auto
   {
     assume "y > 0"
     with rs have False
       by (auto simp: det3_def' algebra_simps y ccw'_def)
   } moreover {
     assume "y < 0"
     with rs have False
       by (auto simp: lex_def not_less algebra_simps algebra_split_simps y ccw'_def)
   } moreover {
     assume "y = 0"
     from this rs have False
       by (simp add: ccw'_def y)
   } ultimately show False by arith
 qed
 
 interpretation ccw_system4 ccw
 proof unfold_locales
   fix p q r t
   assume ccw: "ccw t q r" "ccw p t r" "ccw p q t"
   show "ccw p q r"
   proof (cases "det3 t q r = 0 \<and> det3 p t r = 0 \<and> det3 p q t = 0")
     case True
     {
       assume "psi t q r \<or> psi q r t \<or> psi r t q"
         "psi p t r \<or> psi t r p \<or> psi r p t"
         "psi p q t \<or> psi q t p \<or> psi t p q"
       hence "psi p q r \<or> psi q r p \<or> psi r p q"
         using lex_sym_eq_iff psi_def by blast
     }
     with True ccw show ?thesis
       by (simp add: det3_def' algebra_simps ccw_def ccw'_def)
   next
     case False
     hence "0 \<le> det3 t q r" "0 \<le> det3 p t r" "0 \<le> det3 p q t"
       using ccw by (auto simp: less_eq_real_def ccw_def ccw'_def)
     with False show ?thesis
       by (auto simp: ccw_def det3_def' algebra_simps ccw'_def intro!: disjI1)
   qed
 qed
 
 lemma lex_total: "lex t q \<and> t \<noteq> q \<or> lex q t \<and> t \<noteq> q \<or> t = q"
   by auto
 
 lemma
   ccw_two_up_contra:
   assumes c: "ccw' t p q" "ccw' t q r"
   assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
   assumes distinct: "distinct5 t s p q r"
   shows False
 proof -
   from ccws
   have nn: "det3 t s p \<ge> 0" "det3 t s q \<ge> 0" "det3 t s r \<ge> 0" "det3 t r p \<ge> 0"
     by (auto simp add: less_eq_real_def ccw_def ccw'_def)
   with c det_identity[of t p q s r]
   have tsr: "coll t s r" and tsp: "coll t s p"
     by (auto simp: add_nonneg_eq_0_iff ccw'_def)
   moreover
   have trp: "coll t r p"
     by (metis ccw'_subst_collinear distinct not_ccw'_eq tsr tsp)
   ultimately have tpr: "coll t p r"
     by (auto simp: det3_def' algebra_simps)
   moreover
   have psi: "psi t p r \<or> psi t r p \<or> psi r p t"
     unfolding psi_def
   proof -
     have ntsr: "\<not> ccw' t s r" "\<not> ccw' t r s"
       using tsr
       by (auto simp: not_ccw'_eq det3_def' algebra_simps)
     have f8: "\<not> ccw' t r s"
       using tsr not_ccw'_eq by blast
     have f9: "\<not> ccw' t r p"
       using tpr by (simp add: not_ccw'_eq)
     have f10: "(lex t r \<and> lex r p \<or> lex r p \<and> lex p t \<or> lex p t \<and> lex t r)"
       using ccw_def ccws(6) psi_def f9 by auto
 
     have "\<not> ccw' t r q"
       using c(2) not_ccw'_eq by blast
     moreover
     have "\<not>coll t q s"
       using ntsr ccw'_subst_collinear distinct c(2) by blast
     hence "ccw' t s q"
       by (meson ccw_def ccws(2) not_ccw'_eq)
     moreover
     from tsr tsp \<open>coll t r p\<close> have "coll t p s" "coll t p r" "coll t r s"
       by (auto simp add: det3_def' algebra_simps)
     ultimately
     show "lex t p \<and> lex p r \<or> lex t r \<and> lex r p \<or> lex r p \<and> lex p t"
       by (metis ccw'_subst_psi_disj distinct ccw_def ccws(3) contra4 tsp ntsr(1) f10 lex_total
         psi_def trp)
   qed
   moreover
   from distinct have "r \<noteq> t" by auto
   ultimately
   have "ccw' t r q" using c(1)
     by (rule ccw'_subst_psi_disj)
   thus False
     using c(2) by (simp add: ccw'_contra)
 qed
 
 lemma
   ccw_transitive_contr:
   fixes t s p q r
   assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
   assumes distinct: "distinct5 t s p q r"
   shows False
 proof -
   from ccws distinct have *: "ccw p t r" "ccw p q t" by (metis cyclic)+
   with distinct have "ccw r p q" using interior[OF _ _ ccws(5) *, of UNIV]
     by (auto intro: cyclic)
 
   from ccws have nonnegs: "det3 t s p \<ge> 0" "det3 t s q \<ge> 0" "det3 t s r \<ge> 0" "det3 t p q \<ge> 0"
     "det3 t q r \<ge> 0" "det3 t r p \<ge> 0"
     by (auto simp add: less_eq_real_def ccw_def ccw'_def)
   {
     assume "ccw' t p q" "ccw' t q r" "ccw' t r p"
     hence False
       using ccw_two_up_contra ccws distinct by blast
   } moreover {
     assume c: "coll t q r" "coll t r p"
     with distinct four_points_aligned(1)[OF c, of s]
     have "coll t p q"
       by auto
     hence "(psi t p q \<or> psi p q t \<or> psi q t p)"
       "psi t q r \<or> psi q r t \<or> psi r t q"
       "psi t r p \<or> psi r p t \<or> psi p t r"
       using ccws(4,5,6) c
       by (simp_all add: ccw_def ccw'_def)
     hence False
       using distinct
       by (auto simp: psi_def ccw'_def)
   } moreover {
     assume c: "det3 t p q = 0" "det3 t q r > 0" "det3 t r p = 0"
     have "\<And>x. det3 t q r = 0 \<or> t = x \<or> r = q \<or> q = x \<or> r = p \<or> p = x \<or> r = x"
       by (meson c(1) c(3) distinct four_points_aligned(1))
     hence False
       by (metis (full_types) c(2) distinct less_irrefl)
   } moreover {
     assume c: "det3 t p q = 0" "det3 t q r = 0" "det3 t r p > 0"
     have "\<And>x. det3 t r p = 0 \<or> t = x \<or> r = x \<or> q = x \<or> p = x"
       by (meson c(1) c(2) distinct four_points_aligned(1))
     hence False
       by (metis (no_types) c(3) distinct less_numeral_extra(3))
   } moreover {
     assume c: "ccw' t p q" "ccw' t q r"
     from ccw_two_up_contra[OF this ccws distinct]
     have False .
   } moreover {
     assume c: "ccw' t p q" "ccw' t r p"
     from ccw_two_up_contra[OF this(2,1), of s] ccws distinct
     have False by auto
   } moreover {
     assume c: "ccw' t q r" "ccw' t r p"
     from ccw_two_up_contra[OF this, of s] ccws distinct
     have False by auto
   } ultimately show "False"
     using \<open>0 \<le> det3 t p q\<close>
     \<open>0 \<le> det3 t q r\<close>\<open>0 \<le> det3 t r p\<close>
     by (auto simp: less_eq_real_def ccw'_def)
 qed
 
 interpretation ccw: ccw_system ccw
   by unfold_locales (metis ccw_transitive_contr nondegenerate)
 
 lemma ccw_scaleR1:
   "det3 0 xr P \<noteq> 0 \<Longrightarrow> 0 < e \<Longrightarrow> ccw 0 xr P \<Longrightarrow> ccw 0 (e*\<^sub>Rxr) P"
   by (simp add: ccw_def)
 
 lemma ccw_scaleR2:
   "det3 0 xr P \<noteq> 0 \<Longrightarrow> 0 < e \<Longrightarrow> ccw 0 xr P \<Longrightarrow> ccw 0 xr (e*\<^sub>RP)"
   by (simp add: ccw_def)
 
 lemma ccw_translate3_aux:
   assumes "\<not>coll 0 a b"
   assumes "x < 1"
   assumes "ccw 0 (a - x*\<^sub>Ra) (b - x *\<^sub>R a)"
   shows "ccw 0 a b"
 proof -
   from assms have "\<not> coll 0 (a - x*\<^sub>Ra) (b - x *\<^sub>R a)"
     by simp
   with assms have "ccw' 0 ((1 - x) *\<^sub>R a) (b - x *\<^sub>R a)"
     by (simp add: algebra_simps ccw_def)
   thus "ccw 0 a b"
     using \<open>x < 1\<close>
     by (simp add: ccw_def)
 qed
 
 lemma ccw_translate3_minus: "det3 0 a b \<noteq> 0 \<Longrightarrow> x < 1 \<Longrightarrow> ccw 0 a (b - x *\<^sub>R a) \<Longrightarrow> ccw 0 a b"
   using ccw_translate3_aux[of a b x] ccw_scaleR1[of a "b - x *\<^sub>R a" "1-x" ]
   by (auto simp add: algebra_simps)
 
 lemma ccw_translate3: "det3 0 a b \<noteq> 0 \<Longrightarrow> x < 1 \<Longrightarrow> ccw 0 a b \<Longrightarrow> ccw 0 a (x *\<^sub>R a + b)"
   by (rule ccw_translate3_minus) (auto simp add: algebra_simps)
 
 lemma ccw_switch23: "det3 0 P Q \<noteq> 0 \<Longrightarrow> (\<not> ccw 0 Q P \<longleftrightarrow> ccw 0 P Q)"
   by (auto simp: ccw_def algebra_simps not_ccw'_eq ccw'_not_coll)
 
 lemma ccw0_upward: "fst a > 0 \<Longrightarrow> snd a = 0 \<Longrightarrow> snd b > snd a \<Longrightarrow> ccw 0 a b"
   by (auto simp: ccw_def det3_def' algebra_simps ccw'_def)
 
 lemma ccw_uminus3[simp]: "det3 a b c \<noteq> 0 \<Longrightarrow> ccw (-a) (-b) (-c) = ccw a b c"
   by (auto simp: ccw_def ccw'_def algebra_simps det3_def')
 
 lemma coll_minus_eq: "coll (x - a) (x - b) (x - c) = coll a b c"
   by (auto simp: det3_def' algebra_simps)
 
 lemma ccw_minus3: "\<not> coll a b c \<Longrightarrow> ccw (x - a) (x - b) (x - c) \<longleftrightarrow> ccw a b c"
   by (simp add: ccw_def coll_minus_eq)
 
 lemma ccw0_uminus[simp]: "\<not> coll 0 a b \<Longrightarrow> ccw 0 (-a) (-b) \<longleftrightarrow> ccw 0 a b"
   using ccw_uminus3[of 0 a b]
   by simp
 
 lemma lex_convex2:
   assumes "lex p q" "lex p r" "0 \<le> u" "u \<le> 1"
   shows "lex p (u *\<^sub>R q + (1 - u) *\<^sub>R r)"
 proof cases
   note \<open>lex p q\<close>
   also
   assume "lex q r"
   hence "lex q (u *\<^sub>R q + (1 - u) *\<^sub>R r)"
     using \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
     by (rule lex_convex_self2)
   finally (lex_trans) show ?thesis .
 next
   note \<open>lex p r\<close>
   also
   assume "\<not> lex q r"
   hence "lex r q"
     by simp
   hence "lex r ((1 - u) *\<^sub>R r + (1 - (1 - u)) *\<^sub>R q)"
     using \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
     by (intro lex_convex_self2) simp_all
   finally (lex_trans) show ?thesis by (simp add: ac_simps)
 qed
 
 lemma lex_convex2':
   assumes "lex q p" "lex r p" "0 \<le> u" "u \<le> 1"
   shows "lex (u *\<^sub>R q + (1 - u) *\<^sub>R r) p"
 proof -
   have "lex (- p) (u *\<^sub>R (-q) + (1 - u) *\<^sub>R (-r))"
     using assms
     by (intro lex_convex2) (auto simp: lex_def)
   thus ?thesis
     by (auto simp: lex_def algebra_simps)
 qed
 
 lemma psi_convex1:
   assumes "psi c a b"
   assumes "psi d a b"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "psi (u *\<^sub>R c + v *\<^sub>R d) a b"
 proof -
   from assms have v: "v = (1 - u)" by simp
   show ?thesis
     using assms
     by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
 qed
 
 lemma psi_convex2:
   assumes "psi a c b"
   assumes "psi a d b"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "psi a (u *\<^sub>R c + v *\<^sub>R d) b"
 proof -
   from assms have v: "v = (1 - u)" by simp
   show ?thesis
     using assms
     by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
 qed
 
 lemma psi_convex3:
   assumes "psi a b c"
   assumes "psi a b d"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "psi a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   from assms have v: "v = (1 - u)" by simp
   show ?thesis
     using assms
     by (auto simp: psi_def v intro!: lex_convex2)
 qed
 
 lemma coll_convex:
   assumes "coll a b c" "coll a b d"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "coll a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof cases
   assume "a \<noteq> b"
   with assms(1, 2)
   obtain x y where xy: "c - a = x *\<^sub>R (b - a)" "d - a = y *\<^sub>R (b - a)"
     by (auto simp: det3_translate_origin dest!: coll_scale)
   from assms have "(u + v) *\<^sub>R a = a" by simp
   hence "u *\<^sub>R c + v *\<^sub>R d - a = u *\<^sub>R (c - a) + v *\<^sub>R (d - a)"
     by (simp add: algebra_simps)
   also have "\<dots> = u *\<^sub>R x *\<^sub>R (b - a) + v *\<^sub>R y *\<^sub>R (b - a)"
     by (simp add: xy)
   also have "\<dots> = (u * x + v * y) *\<^sub>R (b - a)" by (simp add: algebra_simps)
   also have "coll 0 (b - a) \<dots>"
     by (simp add: coll_scaleR_right_eq)
   finally show ?thesis
     by (auto simp: det3_translate_origin)
 qed simp
 
 lemma (in ccw_vector_space) convex3:
   assumes "u \<ge> 0" "v \<ge> 0" "u + v = 1" "ccw a b d" "ccw a b c"
   shows "ccw a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   have "v = 1 - u" using assms by simp
   hence "ccw 0 (b - a) (u *\<^sub>R (c - a) + v *\<^sub>R (d - a))"
     using assms
     by (cases "u = 0" "v = 0" rule: bool.exhaust[case_product bool.exhaust])
       (auto simp add: translate_origin intro!: add3)
   also
   have "(u + v) *\<^sub>R a = a" by (simp add: assms)
   hence "u *\<^sub>R (c - a) + v *\<^sub>R (d - a) = u *\<^sub>R c + v *\<^sub>R d - a"
     by (auto simp: algebra_simps)
   finally show ?thesis by (simp add: translate_origin)
 qed
 
 lemma ccw_self[simp]: "ccw a a b" "ccw b a a"
   by (auto simp: ccw_def psi_def intro: cyclic)
 
 lemma ccw_sefl'[simp]: "ccw a b a"
   by (rule cyclic) simp
 
 lemma ccw_convex':
   assumes uv: "u \<ge> 0" "v \<ge> 0" "u + v = 1"
   assumes "ccw a b c" and 1: "coll a b c"
   assumes "ccw a b d" and 2: "\<not> coll a b d"
   shows "ccw a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   from assms have u: "0 \<le> u" "u \<le> 1" and v: "v = 1 - u"
     by (auto simp: algebra_simps)
   let ?c = "u *\<^sub>R c + v *\<^sub>R d"
   from 1 have abd: "ccw' a b d"
     using assms by (auto simp: ccw_def)
   {
     assume 2: "\<not> coll a b c"
     from 2 have "ccw' a b c"
       using assms by (auto simp: ccw_def)
     with abd have "ccw' a b ?c"
       using assms by (auto intro!: ccw'.convex3)
     hence ?thesis
       by (simp add: ccw_def)
   } moreover {
     assume 2: "coll a b c"
     {
       assume "a = b"
       hence ?thesis by simp
     } moreover {
       assume "v = 0"
       hence ?thesis
         by (auto simp: v assms)
     } moreover {
       assume "v \<noteq> 0" "a \<noteq> b"
       have "coll c a b" using 2 by (auto simp: det3_def' algebra_simps)
       from coll_ex_scaling[OF \<open>a \<noteq> b\<close> this]
       obtain r where c: "c = a + r *\<^sub>R (b - a)" by auto
       have *: "u *\<^sub>R (a + r *\<^sub>R (b - a)) + v *\<^sub>R d - a = (u * r) *\<^sub>R (b - a)  + (1 - u) *\<^sub>R (d - a)"
         by (auto simp: algebra_simps v)
       have "ccw' a b ?c"
         using \<open>v \<noteq> 0\<close> uv abd
         by (simp add: ccw'.translate_origin c *)
       hence ?thesis by (simp add: ccw_def)
     } ultimately have ?thesis by blast
   } ultimately show ?thesis by blast
 qed
 
 lemma ccw_convex:
   assumes uv: "u \<ge> 0" "v \<ge> 0" "u + v = 1"
   assumes "ccw a b c"
   assumes "ccw a b d"
   assumes lex: "coll a b c \<Longrightarrow> coll a b d \<Longrightarrow> lex b a"
   shows "ccw a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   from assms have u: "0 \<le> u" "u \<le> 1" and v: "v = 1 - u"
     by (auto simp: algebra_simps)
   let ?c = "u *\<^sub>R c + v *\<^sub>R d"
   {
     assume coll: "coll a b c \<and> coll a b d"
     hence "coll a b ?c"
       by (auto intro!: coll_convex assms)
     moreover
     from coll have "psi a b c \<or> psi b c a \<or> psi c a b" "psi a b d \<or> psi b d a \<or> psi d a b"
       using assms by (auto simp add: ccw_def ccw'_not_coll)
     hence "psi a b ?c \<or> psi b ?c a \<or> psi ?c a b"
       using coll uv lex
       by (auto simp: psi_def ccw_def not_lex lexs_def v intro: lex_convex2 lex_convex2')
     ultimately have ?thesis
       by (simp add: ccw_def)
   } moreover {
     assume 1: "\<not> coll a b d" and 2: "\<not> coll a b c"
     from 1 have abd: "ccw' a b d"
       using assms by (auto simp: ccw_def)
     from 2 have "ccw' a b c"
       using assms by (auto simp: ccw_def)
     with abd have "ccw' a b ?c"
       using assms by (auto intro!: ccw'.convex3)
     hence ?thesis
       by (simp add: ccw_def)
   } moreover {
     assume "\<not> coll a b d" "coll a b c"
     have ?thesis
       by (rule ccw_convex') fact+
   } moreover {
     assume 1: "coll a b d" and 2: "\<not> coll a b c"
     have "0 \<le> 1 - u" using assms by (auto )
     from ccw_convex'[OF this \<open>0 \<le> u\<close> _ \<open>ccw a b d\<close> 1 \<open>ccw a b c\<close> 2]
     have ?thesis by (simp add: algebra_simps v)
   } ultimately show ?thesis by blast
 qed
 
 interpretation ccw: ccw_convex ccw S "\<lambda>a b. lex b a" for S
   by unfold_locales (rule ccw_convex)
 
 lemma ccw_sorted_scaleR: "ccw.sortedP 0 xs \<Longrightarrow> r > 0 \<Longrightarrow> ccw.sortedP 0 (map ((*\<^sub>R) r) xs)"
   by (induct xs)
     (auto intro!: ccw.sortedP.Cons ccw_scale23 elim!: ccw.sortedP_Cons simp del: scaleR_Pair)
 
 lemma ccw_sorted_implies_ccw'_sortedP:
   assumes nonaligned: "\<And>y z. y \<in> set Ps \<Longrightarrow> z \<in> set Ps \<Longrightarrow> y \<noteq> z \<Longrightarrow> \<not> coll 0 y z"
   assumes sorted: "linorder_list0.sortedP (ccw 0) Ps"
   assumes "distinct Ps"
   shows "linorder_list0.sortedP (ccw' 0 ) Ps"
   using assms
 proof (induction Ps)
   case (Cons P Ps)
   {
     fix p assume p: "p \<in> set Ps"
     moreover
     from p Cons.prems have "ccw 0 P p"
       by (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
     ultimately
     have "ccw' 0 P p"
       using \<open>distinct (P#Ps)\<close>
       by (intro ccw_ncoll_imp_ccw Cons) auto
   }
   moreover
   have "linorder_list0.sortedP (ccw' 0) Ps"
     using Cons.prems
     by (intro Cons) (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
   ultimately
   show ?case
     by (auto intro!: linorder_list0.Cons )
 qed (auto intro: linorder_list0.Nil)
 
 end
diff --git a/thys/Allen_Calculus/nest.thy b/thys/Allen_Calculus/nest.thy
--- a/thys/Allen_Calculus/nest.thy
+++ b/thys/Allen_Calculus/nest.thy
@@ -1,810 +1,809 @@
 (*
 Title:  Allen's qualitative temporal calculus
 Author:  Fadoua Ghourabi (fadouaghourabi@gmail.com)
 Affiliation: Ochanomizu University, Japan
 *)
 
 
 theory nest
 
 imports 
     Main  jointly_exhaustive examples
     "HOL-Eisbach.Eisbach_Tools"
 
 begin
 
 section \<open>Nests\<close>
 text\<open>Nests are sets of intervals that share a meeting point. We define relation before between nests that give the ordering properties of points.\<close>
 
 subsection \<open>Definitions\<close>
 
 type_synonym 'a nest = "'a set"
 
 definition (in arelations) BEGIN :: "'a \<Rightarrow> 'a nest" 
 where "BEGIN i  = {j | j. (j,i) \<in> ov \<union> s \<union> m \<union> f^-1 \<union> d^-1 \<union> e \<union> s^-1}"
 
 definition (in arelations) END :: "'a \<Rightarrow> 'a nest" 
 where "END i  = {j | j. (j,i) \<in> e \<union> ov^-1 \<union> s^-1 \<union> d^-1 \<union> f \<union> f^-1 \<union> m^-1}"
 
 definition (in arelations) NEST ::"'a nest \<Rightarrow> bool"
 where "NEST S \<equiv> \<exists>i. \<I> i \<and> (S = BEGIN i \<or> S = END i)"
 
 definition (in arelations) before :: "'a nest \<Rightarrow> 'a nest \<Rightarrow> bool" (infix "\<lless>" 100)
 where "before N M \<equiv> NEST N \<and> NEST M \<and> (\<exists>n m. \<^cancel>\<open>\<I> m \<and> \<I> n \<and>\<close> n \<in> N \<and> m \<in> M \<and> (n,m) \<in> b)"
 
 subsection \<open>Properties of Nests\<close>
 
 lemma intv1:
 assumes "\<I> i" 
 shows "i \<in> BEGIN i"
 unfolding BEGIN_def
 by (simp add:e assms)
 
 lemma intv2:
 assumes "\<I> i" 
 shows "i \<in> END i"
 unfolding END_def
 by (simp add: e assms)
 
 lemma NEST_nonempty:
 assumes "NEST S"
 shows "S \<noteq> {}" 
 using assms unfolding NEST_def 
 by (insert intv1 intv2, auto)
 
 lemma NEST_BEGIN:
 assumes "\<I> i" 
 shows "NEST (BEGIN i)"
 using NEST_def assms by auto
 
 lemma NEST_END:
 assumes "\<I> i" 
 shows "NEST (END i)"
 using NEST_def assms by auto
 
 lemma before:
 assumes a:"\<I> i" 
 shows "BEGIN i \<lless> END i" 
 proof -
   
     obtain p where pi:"(p,i) \<in> m"
     using  a M3 m by blast
     then have p:"p \<in> BEGIN i" using BEGIN_def by auto
 
     obtain q where qi:"(q,i) \<in> m^-1" 
     using a M3 m by blast
     then have q:"q \<in> END i" using END_def by auto
 
     from pi qi have c1:"(p,q) \<in> b" using b  m
     by blast 
 
     with  c1 p q assms show ?thesis  by (auto simp:NEST_def  before_def)
 
 qed
 
 lemma  meets:
 fixes i j
  assumes "\<I> i" and "\<I> j" 
 shows "(i,j) \<in> m = ((END i) = (BEGIN j))" 
 proof 
   assume ij:"(i,j) \<in> m" then have ibj:"i \<in> (BEGIN j)" unfolding BEGIN_def by auto
   from ij have ji:"(j,i) \<in> m^-1" by simp
   then have jeo:"j \<in> (END i)" unfolding END_def by simp
   show "((END i) = (BEGIN j))"
   proof 
       {fix x::"'a" assume a:"x \<in> (END i)"
       then have asimp:"(x,i) \<in> e \<union>  ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> m\<inverse> \<union> f^-1"
       unfolding END_def by auto
       then have "x \<in> (BEGIN j)" using ij eovisidifmifiOm
       by (auto simp:BEGIN_def)     
       }
       thus conc1:"END i \<subseteq> BEGIN j" by auto
    next
      {fix x assume b:"x \<in> (BEGIN j)"
      then have bsimp:"(x,j) \<in> ov \<union> s\<union> m  \<union> f^-1 \<union> d^-1 \<union> e \<union> s^-1"
      unfolding BEGIN_def by auto
      then have "x \<in> (END i)" using ij ovsmfidiesiOmi
      by (auto simp:END_def)
      }thus conc2:"BEGIN j \<subseteq> END i" by auto
   qed
 next
   assume a0:"END (i::'a) = BEGIN (j::'a)" show "(i,j) \<in> m"
   proof (rule ccontr)
      assume a:"(i,j) \<notin> m" then have "\<not>i\<parallel>j" using m by auto
      from a have "(i,j) \<in> b  \<union> ov  \<union> s \<union> d \<union> f^-1 \<union> e \<union> f  \<union> s^-1  \<union> d^-1 \<union> ov^-1 \<union> m^-1  \<union> b^-1" using assms JE by auto
      thus False
      proof (auto)
        {assume ij:"(i,j) \<in> e" 
         obtain p where ip:"i\<parallel>p" using M3 assms(1)  by auto
         then  have pi:"(p,i)\<in> m^-1" using m by auto
         then have "p \<in> END i" using END_def by auto
         with a0 have pj:"p \<in> (BEGIN j) " by auto
         from ij pi have "(p,j) \<in> m^-1"  by (simp add: e)
         with pj show   ?thesis
         apply (auto simp:BEGIN_def)
         using m_rules by auto[7] }
        next
        {assume ij: "(j,i) \<in> m" 
         obtain p where ip:"i\<parallel>p" using M3  assms(1) by auto
         then  have pi:"(p,i)\<in> m^-1" using m by auto
         then have "p \<in> END i" using END_def by auto
         with a0 have pj:"p \<in> (BEGIN j) " by auto
         from ij have "(i,j) \<in> m^-1" by simp
         with  pi have "(p,j) \<in> b^-1" using cmimi  by auto
         with pj show   ?thesis
         apply (auto simp:BEGIN_def)
           using b_rules by auto
         }
 
        next 
 
        {assume ij:"(i,j)\<in> b"
         have ii:"(i,i)\<in>e" and "i \<in> END i" using assms  intv2 e by auto
         with a0 have j:"i \<in> BEGIN j" by simp
         with ij  show   ?thesis 
         apply (auto simp:BEGIN_def)
           using b_rules by auto
          }
        
         next 
 
         { assume ji:"(j,i) \<in> b" then have ij:"(i,j) \<in> b^-1" by simp
           have ii:"(i,i)\<in>e" and "i \<in> END i" using assms intv2 e by auto
           with a0 have j:"i \<in> BEGIN j" by simp
           with ij  show   ?thesis 
           apply (auto simp:BEGIN_def)
             using b_rules by auto}
         
         next
 
         {assume ij:"(i,j)\<in>ov"
          then obtain u v::"'a" where iu:"i\<parallel>u" and uv:"u\<parallel>v" and uv:"u\<parallel>v" using ov by blast
          from iu have "u \<in> END i" using m END_def by auto
          with a0 have u:"u \<in> BEGIN j" by simp
          from iu have "(u,i) \<in> m^-1" using m by auto
          with ij have uj:"(u,j) \<in> ov^-1 \<union> d \<union> f" using covim by auto
          show ?thesis using u uj 
          apply (auto simp:BEGIN_def)
            using ov_rules eovi apply auto[9]
             using s_rules apply auto[2]
               using d_rules apply auto[5]
                 using f_rules by auto[5]
         }
 
         next 
         
         {assume "(j,i) \<in> ov" then have  ij:"(i,j)\<in>ov^-1" by simp let ?p = i 
         from ij have pi:"(?p, i) \<in> e" by (simp add:e)
         from ij have pj:"(?p,j) \<in> ov^-1" by simp
         from pi have "?p \<in> END i" using END_def by auto
         with a0 have "?p \<in> (BEGIN j) " by auto
         with pj show ?thesis 
         apply (auto simp:BEGIN_def)
           using ov_rules by auto
         }
         next
         {assume ij:"(i,j) \<in> s" 
          then obtain p q t where ip:"i\<parallel>p" and pq:"p\<parallel>q" and  jq:"j\<parallel>q" and ti:"t\<parallel>i" and tj:"t\<parallel>j" using s by blast
          from ip have "(p,i) \<in> m^-1" using m by auto
          then have "p \<in> END i" using END_def by auto
          with a0 have p:"p \<in> BEGIN j" by simp
          from ti ip pq tj jq have "(p,j) \<in> f" using f by blast
          with p show ?thesis 
          apply (auto simp:BEGIN_def)
            using f_rules by auto
             
          }
          next
          {assume "(j,i) \<in> s" then have  ij:"(i,j) \<in> s^-1" by simp
           then obtain u v where ju:"j\<parallel>u" and uv:"u\<parallel>v" and iv:"i\<parallel>v" using s by blast
           from iv have "(v,i) \<in> m^-1" using m by blast
           then have "v \<in> END i" using END_def by auto
           with a0 have v:"v \<in> BEGIN j" by simp
           from ju uv have "(v,j) \<in> b^-1" using b by auto
           with v show ?thesis 
           apply (auto simp:BEGIN_def)
             using b_rules by auto}
          next
          {assume ij:"(i,j) \<in> f"
           have "(i,i) \<in> e" and "i \<in> END i" 
           by (simp add: e)  (auto simp: assms intv2 )
           with a0 have "i \<in> BEGIN j" by simp
           with ij show ?thesis 
           apply (auto simp:BEGIN_def)
            using f_rules by auto 
          }
          next
          {assume "(j,i) \<in> f" then have "(i,j)\<in>f^-1" by simp
           then obtain u where ju:"j\<parallel>u" and iu:"i\<parallel>u" using f by auto
           then have ui:"(u,i) \<in> m^-1" and "u \<in> END i"  
           apply (simp add: converse.intros m)
           using END_def iu m by auto
           with a0 have ubj:"u \<in> BEGIN j" by simp
           from ju have "(u,j) \<in> m^-1"  by (simp add: converse.intros m)
           with ubj show  ?thesis 
           apply (auto simp:BEGIN_def)
             using m_rules by auto
          }
          next
          {assume ij:"(i,j) \<in> d" then 
           have "(i,i) \<in> e" and "i \<in> END i" using assms e by (blast, simp add:  intv2)
           with a0 have "i \<in> BEGIN j" by simp
           with ij show ?thesis 
           apply (auto simp:BEGIN_def)
             using d_rules by auto}
           next
           {assume ji:"(j,i) \<in> d" then have "(i,j) \<in> d^-1" using d by simp
            then obtain u v where ju:"j\<parallel>u" and uv:"u\<parallel>v" and iv:"i\<parallel>v" using d using ji by blast
            then have "(v,i) \<in> m^-1" and "v \<in> END i" using m END_def by auto
            with a0 ju uv have  vj:"(v,j) \<in> b^-1" and  "v \<in> BEGIN j" using b by auto
            with vj show ?thesis 
            apply (auto simp:BEGIN_def)
              using b_rules by auto}
           
         qed
     qed
 qed
 
 
 lemma starts:
 fixes i j
 assumes "\<I> i" and "\<I> j" 
 shows "((i,j) \<in> s \<union> s^-1 \<union> e) = (BEGIN i = BEGIN j)"
 proof 
    assume a3:"(i,j) \<in> s \<union> s^-1 \<union> e" show "BEGIN i = BEGIN j"
    proof -
     { fix x assume "x \<in> BEGIN i" then have "(x,i) \<in> ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" unfolding BEGIN_def by auto
     hence "x \<in> BEGIN j" using a3 ovsmfidiesiOssie
     by (auto simp:BEGIN_def)
     } note c1 = this
 
     { fix x assume "x \<in> BEGIN j" then have xj:"(x,j) \<in> ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" unfolding BEGIN_def by auto
     then have "x \<in> BEGIN i" 
     apply (insert converseI[OF a3] xj)
     apply (subst (asm) converse_Un)+
     apply (subst (asm) converse_converse)
     using ovsmfidiesiOssie  
     by (auto simp:BEGIN_def)
     } note c2 = this
 
     from c1 have "BEGIN i \<subseteq> BEGIN j" by auto
     moreover with c2 have "BEGIN j \<subseteq> BEGIN i" by auto
     ultimately show ?thesis by auto  
  qed
 next
    assume a4:"BEGIN i = BEGIN j"
    with assms have "i \<in> BEGIN j" and "j \<in> BEGIN i" using intv1 by auto
    then have ij:"(i,j) \<in> ov \<union> s \<union> m \<union> f^-1 \<union> d^-1 \<union> e \<union> s^-1" and ji:"(j,i) \<in>  ov \<union> s \<union> m \<union> f^-1 \<union> d^-1 \<union> e \<union> s^-1"
    unfolding BEGIN_def by auto
    then have ijov:"(i,j) \<notin> ov"  
     apply auto
     using ov_rules  by auto
    
    from ij ji have ijm:"(i,j) \<notin> m"  
    apply (simp_all, elim disjE, simp_all)
     using ov_rules apply auto[13]
       using s_rules apply auto[11]
         using m_rules apply auto[9]
           using f_rules apply auto[7]
             using d_rules apply auto[5]
               using m_rules by auto[4]
 
    from ij ji have  ijfi:"(i,j) \<notin> f^-1"  
    apply (simp_all, elim disjE, simp_all)
     using ov_rules apply auto[13]
      using s_rules apply auto[11]
       using m_rules apply auto[9]
           using f_rules apply auto[7]
             using d_rules apply auto[5]
               using f_rules by auto[4]
 
    from ij ji have  ijdi:"(i,j) \<notin> d^-1"  
    apply (simp_all, elim disjE, simp_all)
     using ov_rules apply auto[13]
      using s_rules apply auto[11]
       using m_rules apply auto[9]
           using f_rules apply auto[7]
             using d_rules apply auto[5]
               using d_rules by auto[4]
 
    from ij ijm ijov ijfi ijdi show "(i, j) \<in> s \<union> s\<inverse> \<union> e" by auto 
 
 qed
 
 lemma xj_set:"x \<in> {a |a. (a, j) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>} = ((x,j) \<in>  e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>)"
 by blast
 
 lemma ends:
 fixes i j
 assumes "\<I> i" and "\<I> j"
 shows "((i,j) \<in> f \<union> f^-1 \<union> e) = (END i = END j)"
 proof 
    assume a3:"(i,j) \<in> f \<union> f^-1 \<union> e" show "END i = END j"
    proof -
     { fix x assume "x \<in> END i" then have "(x,i) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def by auto
       then have "x \<in> END j" using a3 unfolding END_def 
       apply (subst xj_set)
       using ceovisidiffimi_ffie_simp by simp
      } note c1 =this
 
     { fix x assume "x \<in> END j" then have "(x,j) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def by auto
       then have "x \<in> END i" using a3 unfolding END_def  
       by (metis Un_iff ceovisidiffimi_ffie_simp converse_iff eei mem_Collect_eq)  
      }  note c2 = this
 
     from c1 have "END i \<subseteq> END j" by auto
     moreover with c2 have "END j \<subseteq> END i" by auto
     ultimately show ?thesis by auto  
   qed (*} note conc = this *)
   next
   assume a4:"END i = END j"
   with assms have "i \<in> END j" and "j \<in> END i" using intv2 by auto
   then have ij:"(i,j) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" and ji:"(j,i) \<in>  e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>"
   unfolding END_def by auto
   then  have ijov:"(i,j) \<notin> ov^-1"  
   apply (simp_all, elim disjE, simp_all)
    using eov es ed efi ef em eov  apply auto[13] 
     using ov_rules apply auto[11]
      using s_rules apply auto[9]
       using d_rules apply auto[7]
         using f_rules apply auto[8]
           using movi by auto
    
   from ij ji have  ijm:"(i,j) \<notin> m^-1"  
   apply (simp_all, elim disjE, simp_all)
     using m_rules by auto
 
   from ij ji have  ijfi:"(i,j) \<notin> s^-1"  
   apply (simp_all, elim disjE, simp_all)
     using s_rules by auto
 
   from ij ji have  ijdi:"(i,j) \<notin> d^-1"  
   apply (simp_all, elim disjE, simp_all)
     using d_rules by auto
 
   from ij ijm ijov ijfi ijdi  show "(i, j) \<in> f \<union> f\<inverse> \<union> e"  by auto
 qed
 
 lemma before_irrefl:
 fixes a
 shows "\<not> a \<lless> a" 
 proof (rule ccontr, auto)
   assume a0:"a \<lless> a"
   then have "NEST a"  unfolding before_def by auto
   then obtain i where   i:"a = BEGIN i \<or> a = END i" unfolding NEST_def by auto
   from i show False
   proof
       assume "a = BEGIN i"
       with a0 have "BEGIN i \<lless> BEGIN i" by simp
       then obtain p q where "p\<in> BEGIN i" and "q \<in> BEGIN i" and b:"(p,q) \<in> b" unfolding before_def by auto
       then  have a1:"(p,i) \<in> ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" and a2:"(i,q) \<in> ov^-1 \<union> s^-1 \<union> m^-1 \<union> f \<union> d \<union> e \<union> s" unfolding BEGIN_def  
       apply auto 
       using eei apply fastforce
       by (simp add: e)+
       with b show False 
       using piiq[of p i q] 
-      apply auto
-        using  b_rules using disjoint_iff_not_equal by auto
+        using  b_rules by safe fast+
       next
       assume "a = END i"
       with a0 have "END i \<lless> END i" by simp
       then obtain p q where "p\<in> END i" and "q \<in> END i" and b:"(p,q) \<in> b" unfolding before_def by auto
       then  have a1:"(p,i) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" and a2:"(q,i) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def  
       by auto 
       with b show False
       apply (subst (asm) converse_iff[THEN sym])
       using cbi_alpha1ialpha4mi neq_bi_alpha1ialpha4mi relcomp.relcompI subsetCE by blast        
      qed
 qed
 
 lemma BEGIN_before:
 fixes i j
 assumes "\<I> i" and "\<I> j" 
 shows "BEGIN i \<lless> BEGIN j = ((i,j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse>)"
 proof 
     
      assume a3:"BEGIN i \<lless> BEGIN j"
      from a3 obtain p q where pa:"p \<in> BEGIN i" and qc:"q \<in> BEGIN j" and pq:"(p,q) \<in> b" unfolding before_def by auto
      then obtain r where "p\<parallel>r" and "r\<parallel>q" using b by auto
      then have pr:"(p,r) \<in> m" and rq:"(r,q) \<in> m" using m by auto
      from pa  have pi:"(p,i) \<in> ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" unfolding BEGIN_def by auto
      moreover with pr have "(r,p) \<in> m^-1" by simp
      ultimately have "(r,i) \<in> d \<union> f \<union> ov^-1 \<union> e \<union> f^-1 \<union> m^-1 \<union> b^-1 \<union> s \<union> s^-1"
      using cmiov cmis cmim cmifi cmidi  cmisi
      apply ( simp_all,elim disjE, auto)
         by (simp add: e)
      
 
      then have ir:"(i,r) \<in> d^-1 \<union> f^-1 \<union> ov \<union> e \<union> f \<union> m \<union> b \<union> s^-1 \<union> s" 
      by (metis (mono_tags, lifting) converseD converse_Un converse_converse eei)
 
      from qc  have "(q,j) \<in>  ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" unfolding BEGIN_def by auto
      with rq have rj:"(r,j) \<in> b \<union> s \<union> m "
      using m_ovsmfidiesi using contra_subsetD relcomp.relcompI by blast
       
      with ir have c1:"(i,j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse> \<union> d \<union> e \<union> s \<union> s\<inverse>"
      using difibs by blast
      {assume "(i,j) \<in> s\<or> (i,j)\<in>s^-1 \<or> (i,j) \<in> e" then have "BEGIN i = BEGIN j" 
       using starts Un_iff assms(1) assms(2) by blast
       with a3 have False  by (simp add: before_irrefl)}
 
       from c1 have c1':"(i,j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse> \<union> d " 
       using \<open>(i, j) \<in> s \<or> (i, j) \<in> s\<inverse> \<or> (i, j) \<in> e \<Longrightarrow> False\<close> by blast
 
      {assume "(i,j) \<in> d" with pi have "(p,j) \<in> e \<union>  s \<union> d \<union> ov \<union> ov^-1 \<union> s^-1 \<union> f \<union> f^-1  \<union> d^-1"
       using ovsmfidiesi_d using relcomp.relcompI subsetCE by blast
       with pq have "(q,j) \<in>  b^-1 \<union> d \<union> f \<union> ov^-1 \<union> m^-1"
       apply (subst (asm) converse_iff[THEN sym])
       using cbi_esdovovisiffidi by blast
       with qc have False unfolding BEGIN_def 
       apply (subgoal_tac "(q, j) \<in> ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>")
         prefer 2
         apply simp 
           using neq_beta2i_alpha2alpha5m by auto
       }
 
      with c1' show "((i, j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse>)"   by auto  
    next
       assume "(i, j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse>"
       then show "BEGIN i \<lless> BEGIN j"
       proof  ( simp_all,elim disjE, simp_all)
         assume "(i,j) \<in> b" thus ?thesis using intv1  using before_def NEST_BEGIN assms by metis
         next
         assume iu:"(i,j) \<in> m" 
         obtain l where li:"(l,i) \<in> m" using M3 m meets_wd assms by blast
         with iu have "(l,j) \<in> b" using cmm by auto
         moreover from li  have "l \<in> (BEGIN i)" using BEGIN_def by auto
         ultimately show ?thesis using intv1  before_def NEST_BEGIN assms by blast
         next
         assume iu:"(i,j) \<in> ov"
         obtain l where li:"(l,i) \<in> m" using M3 m meets_wd assms by blast
         with iu have "(l,j) \<in> b" using cmov by auto
         moreover from li have "l \<in> (BEGIN i)" using BEGIN_def by auto
         ultimately show ?thesis using intv1 before_def NEST_BEGIN assms by blast
         next
         assume iu:"(j,i) \<in> f" 
         obtain l where li:"(l,i) \<in> m" using M3 m meets_wd assms by blast
         with iu have "(l,j) \<in> b" using cmfi by auto
         moreover from li have "l \<in> (BEGIN i)" using BEGIN_def by auto
         ultimately show ?thesis using intv1  before_def NEST_BEGIN assms by blast
         next
         assume iu:"(j,i) \<in> d" 
         obtain l where li:"(l,i) \<in> m" using M3 m meets_wd assms by blast
         with iu have "(l,j) \<in> b" using cmdi by auto
         moreover from li have "l \<in> (BEGIN i)" using BEGIN_def by auto
         ultimately show ?thesis using intv1 before_def NEST_BEGIN assms by blast
         
      qed
 qed
 
 lemma BEGIN_END_before:
 fixes i j
 assumes "\<I> i" and "\<I> j"
 shows  "BEGIN i \<lless> END j = ((i,j) \<in> e \<union> b \<union> m \<union> ov \<union> ov^-1 \<union> s \<union> s^-1 \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>) "
 proof 
      assume a3:"BEGIN i \<lless> END j"
      then obtain p q where pa:"p \<in> BEGIN i" and qc:"q \<in> END j" and pq:"(p,q) \<in> b" unfolding before_def by auto
      then obtain r where "p\<parallel>r" and "r\<parallel>q" using b by auto
      then have pr:"(p,r) \<in> m" and rq:"(r,q) \<in> m" using m by auto
      from pa  have pi:"(p,i) \<in> ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" unfolding BEGIN_def by auto
      moreover with pr have "(r,p) \<in> m^-1" by simp
      ultimately have "(r,i) \<in> d \<union> f \<union> ov^-1 \<union> e \<union> f^-1 \<union> m^-1 \<union> b^-1 \<union> s \<union> s^-1" using cmiov cmis cmim cmifi cmidi e cmisi
      by ( simp_all,elim disjE, auto simp:e)
      
      then have ir:"(i,r) \<in> d^-1 \<union> f^-1 \<union> ov \<union> e \<union> f \<union> m \<union> b \<union> s^-1 \<union> s" 
      by (metis (mono_tags, lifting) converseD converse_Un converse_converse eei)
 
      from qc  have "(q,j) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def by auto
      with rq have rj:"(r,j) \<in> m \<union> ov \<union> s \<union> d \<union> b \<union> f^-1 \<union> f \<union> e" using cm_alpha1ialpha4mi by blast
 
      with ir show  c1:"(i,j) \<in> e \<union> b \<union> m \<union> ov \<union> ov^-1 \<union> s \<union> s^-1 \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>"
      using difimov by blast
      next
      assume a4:"(i, j) \<in> e \<union> b \<union> m \<union> ov \<union> ov\<inverse> \<union> s \<union> s\<inverse> \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>"
      then show "BEGIN i \<lless> END j"
      proof  ( simp_all,elim disjE, simp_all)
            assume "(i,j) \<in> e" 
            obtain l k where l:"l\<parallel>i" and "i\<parallel>k" using M3 meets_wd assms  by blast
            with \<open>(i,j) \<in> e\<close> have k:"j\<parallel>k" by (simp add: e)
            from l k have "(l,i) \<in> m" and "(k,j) \<in> m^-1" using m by auto
            then  have "l \<in> BEGIN i" and "k \<in> END j" using BEGIN_def END_def by auto 
            moreover from l \<open>i\<parallel>k\<close> have "(l,k) \<in> b" using b by auto
            ultimately show ?thesis using before_def assms NEST_BEGIN NEST_END  by blast
           next
            assume "(i,j) \<in> b"
            then show ?thesis using before_def assms NEST_BEGIN NEST_END intv1[of i] intv2[of j] by auto
           next
             assume "(i,j) \<in> m"
             obtain l where "l\<parallel>i" using M3 assms by blast
             then have "l\<in>BEGIN i" using m BEGIN_def by auto
             moreover from \<open>(i,j)\<in>m\<close> \<open>l\<parallel>i\<close> have "(l,j) \<in> b" using b m by blast
             ultimately show ?thesis using intv2[of j] assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(i,j) \<in> ov"
            then obtain l k where li:"l\<parallel>i" and lk:"l\<parallel>k" and ku:"k\<parallel>j" using ov by blast
            from li have "l \<in> BEGIN i" using m BEGIN_def by auto
            moreover from lk ku have "(l,j) \<in> b" using b by auto
            ultimately show ?thesis using intv2[of j] assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(j,i) \<in> ov"
            then obtain l k v where uv:"j\<parallel>v" and lk:"l\<parallel>k" and kv:"k\<parallel>v" and li:"l\<parallel>i" using ov by blast
            from li have "l \<in> BEGIN i" using m BEGIN_def by auto
            moreover from uv have "v \<in> END j" using m END_def by auto
            moreover from lk kv have "(l,v) \<in> b" using b by auto
            ultimately show ?thesis using  assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(i,j) \<in> s"
            then obtain v v' where iv:"i\<parallel>v" and vvp:"v\<parallel>v'" and "j\<parallel>v'" using s by blast
            then have "v' \<in> END j" using END_def m by auto
            moreover from iv vvp have "(i,v') \<in> b" using b by auto
            ultimately show ?thesis using intv1[of i]  assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(j,i) \<in> s"
            then obtain l v where li:"l\<parallel>i" and lu:"l\<parallel>j" and "j\<parallel>v" using s by blast
            then have "v \<in> END j" using m END_def by auto
            moreover from li have "l \<in> BEGIN i" using m BEGIN_def by auto
            moreover from lu \<open>j\<parallel>v\<close> have "(l,v) \<in> b" using b by auto
            ultimately show ?thesis using  assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(i,j) : f"
            then obtain l v where li:"l\<parallel>i" and iv:"i\<parallel>v" and "j\<parallel>v" using f by blast
            then have "v \<in> END j" using m END_def by auto
            moreover from li have "l \<in> BEGIN i" using m BEGIN_def by auto
            moreover from iv li have "(l,v) \<in> b" using b by auto
            ultimately show ?thesis using assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(j,i) \<in> f"
            then obtain l v where li:"l\<parallel>i" and iv:"i\<parallel>v" and "j\<parallel>v" using f by blast
            then have "v \<in> END j" using m END_def by auto
            moreover from li have "l \<in> BEGIN i" using m BEGIN_def by auto
            moreover from iv li have "(l,v) \<in> b" using b by auto
            ultimately show ?thesis using  assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(i,j) : d"
            then obtain k v where ik:"i\<parallel>k" and kv:"k\<parallel>v" and "j\<parallel>v" using d by blast
            then have "v \<in> END j" using END_def m by auto
            moreover from ik kv have "(i,v) \<in> b" using b by auto
            ultimately show ?thesis using intv1[of i]  assms NEST_BEGIN NEST_END before_def by blast
           next
            assume "(j,i) \<in> d"
            then obtain l k where "l\<parallel>i" and lk:"l\<parallel>k" and ku:"k\<parallel>j" using d by blast
            then have "l \<in> BEGIN i" using BEGIN_def m by auto
            moreover from lk ku have "(l,j) \<in> b" using b by auto
            ultimately show ?thesis using intv2[of j] assms NEST_BEGIN NEST_END before_def by blast
        qed           
 qed
 
 lemma END_BEGIN_before:
 fixes i j
 assumes "\<I> i" and "\<I> j"
 shows  "END i \<lless> BEGIN j =  ((i,j) \<in> b) "
 proof 
      assume a3:"END i \<lless> BEGIN j"
      from a3 obtain p q where pa:"p \<in> END i" and qc:"q \<in> BEGIN j" and pq:"(p,q) \<in> b" unfolding before_def by auto
      then obtain r where "p\<parallel>r" and "r\<parallel>q" using b by auto
      then have pr:"(p,r) \<in> m" and rq:"(r,q) \<in> m" using m by auto
      from pa  have pi:"(p,i) \<in>  e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def by auto
      moreover with pr have "(r,p) \<in> m^-1" by simp
      ultimately have "(r,i) \<in> m^-1 \<union> b^-1" using e cmiovi cmisi cmidi cmif cmifi cmimi 
      by ( simp_all,elim disjE, auto simp:e)
      
      then have ir:"(i,r) \<in> m \<union> b" by simp
      
      from qc  have "(q,j) \<in>  ov \<union> s \<union> m \<union> f\<inverse> \<union> d\<inverse> \<union> e \<union> s\<inverse>" unfolding BEGIN_def by auto
      with rq have rj:"(r,j) \<in> b \<union> m " using cmov cms cmm cmfi cmdi e cmsi
      by (simp_all, elim disjE, auto simp:e)
      
      with ir show "(i,j) \<in> b" using cmb cmm cbm cbb by auto
 
    next
      assume "(i,j) \<in> b" thus "END i \<lless> BEGIN j" using intv1[of j] intv2[of i] assms before_def NEST_END NEST_BEGIN by auto
 qed
 
 lemma END_END_before:
 fixes i j
 assumes "\<I> i" and "\<I> j"
 shows "END i \<lless> END j = ((i,j) \<in> b \<union> m \<union> ov \<union> s \<union> d) "
 proof 
      assume a3:"END i \<lless> END j"
      from a3 obtain p q where pa:"p \<in> END i" and qc:"q \<in> END j" and pq:"(p,q) \<in> b" unfolding before_def by auto
      then obtain r where "p\<parallel>r" and "r\<parallel>q" using b by auto
      then have pr:"(p,r) \<in> m" and rq:"(r,q) \<in> m" using m by auto
      from pa  have pi:"(p,i) \<in>  e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def by auto
      moreover with pr have "(r,p) \<in> m^-1" by simp
      ultimately have "(r,i) \<in> m^-1 \<union> b^-1" using e cmiovi cmisi cmidi cmif cmifi cmimi 
      by ( simp_all,elim disjE, auto simp:e)
      
      then have ir:"(i,r) \<in> m \<union> b" by simp
      
      from qc  have "(q,j) \<in> e \<union> ov\<inverse> \<union> s\<inverse> \<union> d\<inverse> \<union> f \<union> f\<inverse> \<union> m\<inverse>" unfolding END_def by auto
      with rq have rj:"(r,j) \<in> m \<union> ov \<union> s \<union> d \<union> b \<union> f^-1 \<union> e \<union> f " using e cmovi cmsi cmdi cmf cmfi cmmi
      by (simp_all, elim disjE, auto simp:e)
      
      with ir show "(i,j) \<in> b \<union> m \<union> ov \<union> s \<union> d" using cmm cmov cms cmd cmb cmfi e cmf cbm cbov cbs cbd cbb cbfi cbf
      by (simp_all, elim disjE, auto simp:e)
     next
      assume "(i, j) \<in> b \<union> m \<union> ov \<union> s \<union> d"
      then show "END i \<lless> END j"
      proof  ( simp_all,elim disjE, simp_all)
         assume "(i,j) \<in> b" thus ?thesis using intv2[of i] intv2[of j] assms NEST_END before_def by blast
        next
         assume "(i,j) \<in> m" 
         obtain v where "j\<parallel>v" using M3 assms by blast
         with \<open>(i,j) \<in> m\<close> have "(i,v) \<in>b" using b m by blast
         moreover from \<open>j\<parallel>v\<close> have "v \<in> END j" using m END_def by auto
         ultimately show ?thesis using intv2[of i] assms NEST_END before_def by blast
        next
         assume "(i,j) : ov"
         then obtain v v' where iv:"i\<parallel>v" and vvp:"v\<parallel>v'" and "j\<parallel>v'" using ov by blast
         then have "v' \<in> END j" using m END_def by auto
         moreover from iv vvp have "(i,v') \<in> b" using b by auto
         ultimately show ?thesis using intv2[of i] assms NEST_END before_def by blast
        next
         assume "(i,j) \<in> s"
         then obtain v v' where iv:"i\<parallel>v" and vvp:"v\<parallel>v'" and "j\<parallel>v'" using s by blast
         then have "v' \<in> END j" using m END_def by auto
         moreover from iv vvp have "(i,v') \<in> b" using b by auto
         ultimately show ?thesis using intv2[of i] assms NEST_END before_def by blast
        next
         assume "(i,j) \<in> d"
         then obtain v v' where iv:"i\<parallel>v" and vvp:"v\<parallel>v'" and "j\<parallel>v'" using d by blast
         then have "v' \<in> END j" using m END_def by auto
         moreover from iv vvp have "(i,v') \<in> b" using b by auto
         ultimately show ?thesis using intv2[of i] assms NEST_END before_def by blast
        qed 
 qed
 
 lemma overlaps:
 assumes "\<I> i" and "\<I> j"
 shows "(i,j) \<in> ov = ((BEGIN i \<lless> BEGIN j) \<and> (BEGIN j \<lless> END i) \<and> (END i \<lless> END j))"
 proof 
 
     assume a:"(i,j) \<in> ov"
     then obtain n t q  u v where nt:"n\<parallel>t" and tj:"t\<parallel>j" and tq:"t\<parallel>q" and qu:"q\<parallel>u" and  iu:"i\<parallel>u" and uv:"u\<parallel>v" and jv:"j\<parallel>v" and "n\<parallel>i" using ov by blast
     then have ni:"(n,i) \<in> m"  using  m  by blast
     then have  n:"n \<in> BEGIN i" unfolding BEGIN_def by auto
     from nt tj have nj:"(n,j) \<in> b" using b by auto
     have  "j \<in> BEGIN j" using assms(2) by (simp add: intv1)
     with assms n nj  have c1:"BEGIN i \<lless> BEGIN j" unfolding before_def using NEST_BEGIN by blast
   
     from tj have a1:"(t,j) \<in> m" and a2:"t \<in> BEGIN j" using m BEGIN_def by auto
     from iu have "(u,i) \<in> m^-1" and "u \<in> END i" using m END_def by auto
     with assms  tq qu a2 have c2:"BEGIN j \<lless> END i"  unfolding before_def using b  NEST_BEGIN NEST_END by blast
 
     have "i \<in> END i" by (simp add: assms  intv2) 
     moreover with jv  have "v \<in> END j" using m END_def by auto
     moreover with iu uv have "(i,v) \<in> b" using b by auto
     ultimately have c3:"END i \<lless> END j" using assms NEST_END before_def by blast
 
     show "((BEGIN i \<lless> BEGIN j) \<and> (BEGIN j \<lless> END i) \<and> (END i \<lless> END j))" using c1 c2 c3 by simp     
   next
     assume a0:"((BEGIN i \<lless> BEGIN j) \<and> (BEGIN j \<lless> END i) \<and> (END i \<lless> END j))"
     then have "(i,j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse> \<and> (i,j) \<in> e \<union> b^-1 \<union> m^-1 \<union> ov^-1 \<union> ov \<union> s^-1 \<union> s \<union> f^-1 \<union> f \<union> d^-1 \<union> d
                                                                                                               \<and> (i,j) \<in> b \<union> m \<union> ov \<union> s \<union> d"
     using BEGIN_before BEGIN_END_before END_END_before assms 
     by (metis (no_types, lifting) converseD converse_Un converse_converse eei)
     then have "(i,j) \<in>  (b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse>) \<inter> (e \<union> b^-1 \<union> m^-1 \<union> ov^-1 \<union> ov \<union> s^-1 \<union> s \<union> f^-1 \<union> f \<union> d^-1 \<union> d) \<inter> (b \<union> m \<union> ov \<union> s \<union> d)" 
     by (auto)
     then show "(i,j) \<in> ov"
     using inter_ov by blast
 
 qed
 
 subsection \<open>Ordering of nests\<close>
 
 class  strict_order =
 fixes ls::"'a nest \<Rightarrow> 'a nest \<Rightarrow> bool"
 assumes 
   irrefl:"\<not> ls a a" and
   trans:"ls a c \<Longrightarrow> ls c g \<Longrightarrow> ls a g" and 
   asym:"ls a c \<Longrightarrow> \<not> ls c a"  
 
 class total_strict_order = strict_order +
 assumes trichotomy: "a = c \<Longrightarrow> (\<not> (ls a  c) \<and> \<not> (ls c  a))"
 
 interpretation nest:total_strict_order "(\<lless>) "
 proof
 { fix a::"'a nest"
 show "\<not> a \<lless> a"
 by (simp add: before_irrefl) } note  irrefl_nest = this
 
 {fix a c::"'a nest"
 assume  "a = c"
 show "\<not> a \<lless> c \<and> \<not> c \<lless> a" 
 by (simp add: \<open>a = c\<close> irrefl_nest)} note trichotomy_nest = this
 
 {fix a c g::"'a nest"
 assume a:"a \<lless> c" and c:" c \<lless> g"
 show " a \<lless> g" 
 proof -
    from a c have na:"NEST a"  and nc:"NEST c" and ng:"NEST g" unfolding before_def by auto
    from na obtain i where  i:"a = BEGIN i \<or> a = END i" and wdi:"\<I> i" unfolding NEST_def by auto
    from nc obtain j where  j:"c = BEGIN j \<or> c = END j" and wdj:"\<I> j" unfolding NEST_def by auto
    from ng obtain u where  u:"g = BEGIN u \<or> g = END u" and wdu:"\<I> u" unfolding NEST_def by auto
    from i j u show ?thesis
    proof (elim disjE, auto)
      assume abi:"a = BEGIN i" and  cbj:"c = BEGIN j" and  gbu:"g = BEGIN u"
      from abi cbj a wdi wdj have "(i,j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse> " using BEGIN_before by auto
      moreover from cbj gbu c wdj wdu have "(j,u) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse>" using BEGIN_before by auto
 
      ultimately have c1:"(i,u) \<in> b \<union> m \<union> ov \<union> f^-1 \<union> d^-1"
      using cbeta2_beta2 by blast
       
      then have "a \<lless> g" by (simp add: BEGIN_before abi gbu wdi wdu)
     
      thus "BEGIN i \<lless> BEGIN u" using abi gbu by auto
     next
      assume  abi:"a = BEGIN i" and  cbj:"c = BEGIN j" and  geu:"g = END u" 
      from abi cbj a wdi wdj have "(i,j) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse> " using BEGIN_before by auto
      moreover from cbj geu c wdj wdu have "(j,u) :  e \<union> b \<union> m \<union> ov \<union> ov\<inverse> \<union> s \<union> s\<inverse> \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>" using BEGIN_END_before by auto
      ultimately have "(i,u) \<in> e \<union> b \<union> m \<union> ov \<union> ov\<inverse> \<union> s \<union> s\<inverse> \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>"
      using cbeta2_gammabm by blast
           
      then have "a \<lless> g" 
      by (simp add: BEGIN_END_before abi geu wdi wdj wdu)
        
      thus "BEGIN i \<lless> END u" using abi geu by auto
     next
      assume abi:"a = BEGIN i" and  cej:"c = END j" and  gbu:"g = BEGIN u"
      from abi cej a wdi wdj  have ij:"(i,j) :  e \<union> b \<union> m \<union> ov \<union> ov\<inverse> \<union> s \<union> s\<inverse> \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>" using BEGIN_END_before by auto
      from cej gbu c wdj wdu  have "(j,u) \<in> b " using END_BEGIN_before by auto
      with ij have "(i,u) \<in> b \<union> m \<union> ov \<union> f^-1 \<union> d^-1" 
      using ebmovovissifsiddib by ( auto)
 
      thus "BEGIN i \<lless> BEGIN u"
      by (simp add: BEGIN_before abi gbu wdi wdu)
     next
      assume abi:"a = BEGIN i" and  cej:"c = END j" and  geu:"g = END u"
      with a  have "(i,j) \<in>  e \<union> b \<union> m \<union> ov \<union> ov\<inverse> \<union> s \<union> s\<inverse> \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>"
      using BEGIN_END_before wdi wdj by auto
      moreover from cej geu c wdj wdu  have "(j,u) \<in> b \<union> m \<union> ov \<union> s \<union> d"
      using END_END_before by auto
      ultimately have "(i,u) \<in> b \<union> m \<union> ov \<union> s \<union> d \<union> f^-1 \<union> d^-1 \<union> ov^-1 \<union> s\<inverse> \<union> f \<union> e"
      using ebmovovissiffiddibmovsd by blast
                   
      thus "BEGIN i \<lless> END u" using BEGIN_END_before wdi wdu  by auto
     next
      assume aei:"a = END i" and cbj:"c = BEGIN j" and gbu:"g = BEGIN u"
      from a  aei cbj wdi wdj have "(i,j) \<in> b"
      using END_BEGIN_before by auto
      moreover from c  cbj gbu wdj wdu have "(j,u) \<in> b \<union> m \<union> ov \<union> f\<inverse> \<union> d\<inverse>" 
      using BEGIN_before by auto 
      ultimately have "(i,u) : b" using cbb cbm cbov cbfi cbdi 
      by (simp_all, elim disjE, auto)
      thus "END i \<lless> BEGIN u" using END_BEGIN_before wdi wdu  by auto
     next
      assume  aei:"a = END i" and cbj:"c = BEGIN j" and  geu:"g = END u"
      from a  aei cbj wdi wdj have "(i,j) \<in> b"
      using END_BEGIN_before by auto
      moreover from c  cbj geu wdj wdu have "(j,u) \<in> e \<union> b \<union> m \<union> ov \<union> ov\<inverse> \<union> s \<union> s\<inverse> \<union> f \<union> f\<inverse> \<union> d \<union> d\<inverse>" 
      using BEGIN_END_before by auto 
      ultimately have "(i,u) \<in> b \<union> m \<union> ov \<union> s \<union> d"
      using bebmovovissiffiddi by blast
      thus "END i \<lless> END u" using END_END_before wdi wdu by auto
     next
      assume aei:"a = END i" and cej:"c = END j" and  gbu:"g = BEGIN u" 
      from aei cej wdi wdj have "(i,j) \<in> b \<union> m \<union> ov \<union> s \<union> d" using END_END_before a by auto
      moreover from cej gbu c wdj wdu have "(j,u) \<in> b" using END_BEGIN_before by auto
      ultimately have "(i,u) \<in> b"
      using cbb cmb covb csb cdb
      by (simp_all, elim disjE, auto)
      thus "END i \<lless> BEGIN u" using END_BEGIN_before wdi wdu  by auto
     next
      assume aei:"a = END i" and cej:"c = END j" and geu:"g = END u"
      from aei cej wdi wdj  have "(i,j) \<in> b \<union> m \<union> ov \<union> s \<union> d" using  END_END_before a by auto
      moreover from cej geu c wdj wdu have "(j,u) \<in>  b \<union> m \<union> ov \<union> s \<union> d" using END_END_before by auto
      ultimately have "(i,u) \<in> b \<union> m \<union> ov \<union> s \<union> d" 
      using calpha1_alpha1 by auto
      thus "END i \<lless> END u" using END_END_before wdi wdu by auto
    qed
 qed} note trans_nest = this    
 
 { fix a c::"'a nest"
   assume a:"a \<lless> c"
   show "\<not> c \<lless> a"
   apply (rule ccontr, auto)
   using a  irrefl_nest trans_nest by blast}
 qed  
          
 end
 
diff --git a/thys/CAVA_LTL_Modelchecker/BoolProgs/BoolProgs.thy b/thys/CAVA_LTL_Modelchecker/BoolProgs/BoolProgs.thy
--- a/thys/CAVA_LTL_Modelchecker/BoolProgs/BoolProgs.thy
+++ b/thys/CAVA_LTL_Modelchecker/BoolProgs/BoolProgs.thy
@@ -1,513 +1,512 @@
 section \<open>Boolean Programs\<close>
 theory BoolProgs
 imports 
   CAVA_Base.CAVA_Base
 begin
 
 subsection \<open>Syntax and Semantics\<close>
 
 datatype bexp = TT | FF | V nat | Not bexp | And bexp bexp | Or bexp bexp
 
 type_synonym state = "bitset"
 
 fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
 "bval TT s = True" |
 "bval FF s = False" |
 "bval (V n) s = bs_mem n s" |
 "bval (Not b) s = (\<not> bval b s)" |
 "bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s & bval b\<^sub>2 s)" |
 "bval (Or b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s | bval b\<^sub>2 s)"
 
 datatype instr =
   AssI "nat list" "bexp list" |
   TestI bexp int |
   ChoiceI "(bexp * int) list" |
   GotoI int
 
 type_synonym config = "nat * state"
 type_synonym bprog = "instr array"
 
 text \<open>
   Semantics Notice:
   To be equivalent in semantics with SPIN, there is no such thing as a
   finite run:
   \begin{itemize}
     \item Deadlocks (i.e. empty Choice) are self-loops
     \item program termination is self-loop
   \end{itemize}
 \<close>
 
 fun exec :: "instr \<Rightarrow> config \<Rightarrow> config list" where
 "exec instr (pc,s) = (case instr of
   AssI ns bs \<Rightarrow> let bvs = zip ns (map (\<lambda>b. bval b s) bs) in
                [(pc + 1, foldl (\<lambda>s (n,bv). set_bit s n bv) s bvs)] |
   TestI b d \<Rightarrow> [if bval b s then (pc+1, s) else (nat(int(pc+1)+d), s)] |
   ChoiceI bis \<Rightarrow> let succs = [(nat(int(pc+1)+i), s) . (b,i) <- bis, bval b s] 
                 in if succs = [] then [(pc,s)] else succs |
   GotoI d \<Rightarrow> [(nat(int(pc+1)+d),s)])"
 
 (* exec' is merely a stuttering optimization. It summarizes chains of choices
   or jumps, as long as they go forward in the program. The forward-condition is
   to ensure termination. 
 
   TODO: Make this explicit, and prove stuttering equivalence!
 *)
 function exec' :: "bprog \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> nat list" where
 "exec' ins s pc = (
   if pc < array_length ins then (
     case (array_get ins pc) of
       AssI ns bs \<Rightarrow> [pc] |
       TestI b d \<Rightarrow> (
         if bval b s then exec' ins s (pc+1) 
         else let pc'=(nat(int(pc+1)+d)) in if pc'>pc then exec' ins s pc'
         else [pc']
       ) |
       ChoiceI bis \<Rightarrow> let succs = [(nat(int(pc+1)+i)) . (b,i) <- bis, bval b s]
                     in if succs = [] then [pc] else concat (map (\<lambda>pc'. if pc'>pc then exec' ins s pc' else [pc']) succs) |
       GotoI d \<Rightarrow> let pc' = nat(int(pc+1)+d) in (if pc'>pc then exec' ins s pc' else [pc'])
   ) else [pc]
 )"
 by pat_completeness auto
 termination 
   apply (relation "measure (%(ins,s,pc). array_length ins - pc)")
   apply auto
   done
 
 fun nexts1 :: "bprog \<Rightarrow> config \<Rightarrow> config list" where
 "nexts1 ins (pc,s) = (
   if pc < array_length ins then 
     exec (array_get ins pc) (pc,s) 
   else 
     [(pc,s)])"
 
 fun nexts :: "bprog \<Rightarrow> config \<Rightarrow> config list" where
   "nexts ins (pc,s) = concat (
     map 
       (\<lambda>(pc,s). map (\<lambda>pc. (pc,s)) (exec' ins s pc)) 
       (nexts1 ins (pc,s))
   )"
 
 declare nexts.simps [simp del]
 
 datatype
   com = SKIP
       | Assign "nat list" "bexp list"    
       | Seq    com  com         
       | GC  "(bexp * com)list"  
       | IfTE  bexp com com      
       | While  bexp com         
 
 locale BoolProg_Syntax begin
   notation 
         Assign       ("_ ::= _" [999, 61] 61)
     and Seq          ("_;/ _"  [60, 61] 60)
     and GC           ("IF _ FI")
     and IfTE         ("(IF _/ THEN _/ ELSE _)"  [0, 61, 61] 61)
     and While        ("(WHILE _/ DO _)"  [0, 61] 61)
 end
 
 context begin interpretation BoolProg_Syntax .
 fun comp' :: "com \<Rightarrow> instr list" where
 "comp' SKIP = []" |
 "comp' (Assign n b) = [AssI n b]" |
 "comp' (c1;c2) = comp' c1 @ comp' c2" |
 "comp' (IF gcs FI) =
   (let cgcs = map (\<lambda>(b,c). (b,comp' c)) gcs in
    let addbc = (\<lambda>(b,cc) (bis,ins).
          let cc' = cc @ (if ins = [] then [] else [GotoI (int(length ins))]) in
          let bis' = map (\<lambda>(b,i). (b, i + int(length cc'))) bis
          in ((b,0)#bis', cc' @ ins)) in
    let (bis,ins) = foldr addbc cgcs ([],[])
    in ChoiceI bis # ins)" |
 "comp' (IF b THEN c1 ELSE c2) =
   (let ins1 = comp' c1 in let ins2 = comp' c2 in
    let i1 = int(length ins1 + 1) in let i2 = int(length ins2)
    in TestI b i1 # ins1 @ GotoI i2 # ins2)" |
 "comp' (WHILE b DO c) =
   (let ins = comp' c in
    let i = int(length ins + 1)
    in TestI b i # ins @ [GotoI (-(i+1))])"
 
 (* a test: *)
 value "comp' (IF [(V 0, [1,0] ::= [TT, FF]), (V 1, [0] ::= [TT])] FI)"
 
 end
 
 definition comp :: "com \<Rightarrow> bprog" where
   "comp = array_of_list \<circ> comp'"
 
 (* 
   Optimization
 
 - Gotos: Resolve Goto-Chains: If a Goto referres to another Goto -- add the second offset to the first one. 
                               If a Goto has a negative offset ignore it, to avoid problems with loops.
 
 *)
 
 fun opt' where
   "opt' (GotoI d) ys = (let next = \<lambda>i. (case i of GotoI d \<Rightarrow> d + 1 | _ \<Rightarrow> 0)
                         in if d < 0 \<or> nat d \<ge> length ys then (GotoI d)#ys
                            else let d' = d + next (ys ! nat d)
                            in (GotoI d' # ys))"
 | "opt' x ys = x#ys"
 
 definition opt :: "instr list \<Rightarrow> instr list" where
   "opt instr = foldr opt' instr []"
 
 definition optcomp :: "com \<Rightarrow> bprog" where
   "optcomp \<equiv> array_of_list \<circ> opt \<circ> comp'"
 
 subsection \<open>Finiteness of reachable configurations\<close>
 
 inductive_set reachable_configs
   for bp :: bprog
   and c\<^sub>s :: config \<comment> \<open>start configuration\<close>
 where
 "c\<^sub>s \<in> reachable_configs bp c\<^sub>s" |
 "c \<in> reachable_configs bp c\<^sub>s \<Longrightarrow> x \<in> set (nexts bp c) \<Longrightarrow> x \<in> reachable_configs bp c\<^sub>s"
 
 lemmas reachable_configs_induct = reachable_configs.induct[split_format(complete),case_names 0 1]
 
 fun offsets :: "instr \<Rightarrow> int set" where
 "offsets (AssI _ _) = {0}" |
 "offsets (TestI _ i) = {0,i}" |
 "offsets (ChoiceI bis) = set(map snd bis) \<union> {0}" |
 "offsets (GotoI i) = {i}"
 
 definition offsets_is :: "instr list \<Rightarrow> int set" where
 "offsets_is ins = (UN instr : set ins. offsets instr)"
 
 definition max_next_pcs :: "instr list \<Rightarrow> nat set" where
 "max_next_pcs ins = {nat(int(length ins + 1) + i) |i. i : offsets_is ins}"
 
 
 lemma finite_max_next_pcs: "finite(max_next_pcs bp)"
 proof-
   { fix instr have "finite (offsets instr)" by(cases instr) auto }
   moreover
   { fix ins have "max_next_pcs ins = (UN i : offsets_is ins. {nat(int(length ins + 1) + i)})"
     by(auto simp add: max_next_pcs_def) }
   ultimately show ?thesis by(auto simp add: offsets_is_def)
 qed
 
 (* TODO: Move *)
 lemma (in linorder) le_Max_insertI1: "\<lbrakk> finite A; x \<le> b \<rbrakk> \<Longrightarrow> x \<le> Max (insert b A)"
 by (metis Max_ge finite.insertI insert_iff order_trans)
 lemma (in linorder) le_Max_insertI2: "\<lbrakk> finite A; A \<noteq> {}; x \<le> Max A \<rbrakk> \<Longrightarrow> x \<le> Max (insert b A)"
 by(auto simp add: max_def not_le simp del: Max_less_iff)
 
 lemma max_next_pcs_not_empty:
   "pc<length bp \<Longrightarrow> x : set (exec (bp!pc) (pc,s)) \<Longrightarrow> max_next_pcs bp \<noteq> {}"
 apply(drule nth_mem)
 apply(fastforce simp: max_next_pcs_def offsets_is_def split: instr.splits)
 done
 
 lemma Max_lem2: 
   assumes "pc < length bp" 
   and "(pc', s') \<in> set (exec (bp!pc) (pc, s))"
   shows "pc' \<le> Max (max_next_pcs bp)"
 using assms
 proof (cases "bp ! pc")
   case (ChoiceI l)
   show ?thesis
   proof (cases "pc' = pc")
     case True with assms ChoiceI show ?thesis
       by (auto simp: Max_ge_iff max_next_pcs_not_empty finite_max_next_pcs) 
          (force simp add: max_next_pcs_def offsets_is_def dest: nth_mem)
   next
     case False with ChoiceI assms obtain b i where 
       bi: "bval b s" "(b,i) \<in> set l" "pc' = nat(int(pc+1)+i)"
       by (auto split: if_split_asm)
     with ChoiceI assms have "i \<in> \<Union>(offsets ` (set bp))" by (force dest: nth_mem)
     with bi assms have "\<exists>a. (a \<in> max_next_pcs bp \<and> pc' \<le> a)"
       unfolding max_next_pcs_def offsets_is_def by force
     thus ?thesis 
       by (auto simp: Max_ge_iff max_next_pcs_not_empty[OF assms] finite_max_next_pcs) 
     qed
 qed (auto simp: Max_ge_iff max_next_pcs_not_empty finite_max_next_pcs,
      (force simp add: max_next_pcs_def offsets_is_def dest: nth_mem split: if_split_asm)+)
 
 lemma Max_lem1: "\<lbrakk> pc < length bp; (pc', s') \<in> set (exec (bp ! pc) (pc, s))\<rbrakk>
     \<Longrightarrow> pc' \<le> Max (insert x (max_next_pcs bp))"
   apply(rule le_Max_insertI2)
   apply (simp add: finite_max_next_pcs)
   apply(simp add: max_next_pcs_not_empty)
   apply(auto intro!: Max_lem2 simp del:exec.simps)
   done
 
 definition "pc_bound bp \<equiv> max 
     (Max (max_next_pcs (list_of_array bp)) + 1)
     (array_length bp + 1)"
 
 declare exec'.simps[simp del]
 
 lemma [simp]: "length (list_of_array a) = array_length a" by (cases a) auto
 
 lemma aux2: 
   assumes A: "pc < array_length ins" 
   assumes B: "ofs \<in> offsets_is (list_of_array ins)"
   shows "nat (1 + int pc + ofs) < pc_bound ins"
 proof -
   have "nat (int (1 + array_length ins) + ofs) 
     \<in> max_next_pcs (list_of_array ins)"
     using B unfolding max_next_pcs_def
     by auto
   with A show ?thesis
     unfolding pc_bound_def
     apply -
     apply (rule max.strict_coboundedI1)
     apply auto
     apply (drule Max_ge[OF finite_max_next_pcs])
     apply simp
     done
 qed
 
 lemma array_idx_in_set: 
   "\<lbrakk> pc < array_length ins; array_get ins pc = x \<rbrakk> 
   \<Longrightarrow> x \<in> set (list_of_array ins)"
   by (induct ins) auto
 
 lemma rcs_aux: 
   assumes "pc < pc_bound bp"    
   assumes "pc'\<in>set (exec' bp s pc)"
   shows "pc' < pc_bound bp"
   using assms
 proof (induction bp s pc arbitrary: pc' rule: exec'.induct[case_names C])
   case (C ins s pc pc')
   from C.prems show ?case
     apply (subst (asm) exec'.simps)
     apply (split if_split_asm instr.split_asm)+
     apply (simp add: pc_bound_def)
 
     apply (simp split: if_split_asm add: Let_def)
     apply (frule (2) C.IH(1), auto) []
     apply (auto simp: pc_bound_def) []
     apply (frule (2) C.IH(2), auto) []
     apply (rename_tac bexp int)
     apply (subgoal_tac "int \<in> offsets_is (list_of_array ins)")
     apply (blast intro: aux2)
     apply (auto simp: offsets_is_def) []
     apply (rule_tac x="TestI bexp int" in bexI, auto simp: array_idx_in_set) []
 
     apply (rename_tac list)
-    apply (clarsimp split: if_split_asm simp add: Let_def)
-    apply (elim disjE conjE, auto) []
+    apply (auto split: if_split_asm)[]
     apply (frule (1) C.IH(3), auto) []
     apply (force)
     apply (force)
     apply (subgoal_tac "ba \<in> offsets_is (list_of_array ins)")
     apply (blast intro: aux2)
     apply (auto simp: offsets_is_def) []
     apply (rule_tac x="ChoiceI list" in bexI, auto simp: array_idx_in_set) []
 
     apply (rename_tac int)
     apply (simp split: if_split_asm add: Let_def)
     apply (frule (1) C.IH(4), auto) []
     apply (subgoal_tac "int \<in> offsets_is (list_of_array ins)")
     apply (blast intro: aux2)
     apply (auto simp: offsets_is_def) []
     apply (rule_tac x="GotoI int" in bexI, auto simp: array_idx_in_set) []
     
     apply simp
     done
 qed
 
 
 primrec bexp_vars :: "bexp \<Rightarrow> nat set" where
   "bexp_vars TT = {}"
 | "bexp_vars FF = {}"
 | "bexp_vars (V n) = {n}"
 | "bexp_vars (Not b) = bexp_vars b"
 | "bexp_vars (And b1 b2) = bexp_vars b1 \<union> bexp_vars b2"
 | "bexp_vars (Or b1 b2) = bexp_vars b1 \<union> bexp_vars b2"
 
 primrec instr_vars :: "instr \<Rightarrow> nat set" where
   "instr_vars (AssI xs bs) = set xs \<union> \<Union>(bexp_vars`set bs)"
 | "instr_vars (TestI b _) = bexp_vars b"
 | "instr_vars (ChoiceI cs) = \<Union>(bexp_vars`fst`set cs)"
 | "instr_vars (GotoI _) = {}"
 
 find_consts "'a array \<Rightarrow> 'a list"
 
 definition bprog_vars :: "bprog \<Rightarrow> nat set" where 
   "bprog_vars bp = \<Union>(instr_vars`set (list_of_array bp))"
 
 
 definition "state_bound bp s0 
   \<equiv> {s. bs_\<alpha> s - bprog_vars bp = bs_\<alpha> s0 - bprog_vars bp}"
 abbreviation "config_bound bp s0 \<equiv> {0..< pc_bound bp} \<times> state_bound bp s0"
 
 lemma exec_bound:
   assumes PCB: "pc < array_length bp"
   assumes SB: "s \<in> state_bound bp s0"
   shows "set (exec (array_get bp pc) (pc,s)) \<subseteq> config_bound bp s0"
 proof (clarsimp simp del: exec.simps, intro conjI)
  
   obtain instrs where BP_eq[simp]: "bp = Array instrs" by (cases bp)
   from PCB have PCB'[simp]: "pc < length instrs" by simp
 
   fix pc' s'
   assume STEP: "(pc',s') \<in> set (exec (array_get bp pc) (pc,s))"
   hence STEP': "(pc',s') \<in> set (exec (instrs!pc) (pc,s))" by simp
 
   show "pc' < pc_bound bp"
     using Max_lem2[OF PCB' STEP']
     unfolding pc_bound_def by simp
 
   show "s' \<in> state_bound bp s0"
     using STEP' SB
   proof (cases "instrs!pc")
     case (AssI xs vs)
 
     have "set xs \<subseteq> instr_vars (instrs!pc)"
       by (simp add: AssI)
     also have "\<dots> \<subseteq> bprog_vars bp"
       apply (simp add: bprog_vars_def)
       by (metis PCB' UN_upper nth_mem)
     finally have XSB: "set xs \<subseteq> bprog_vars bp" .
 
 
     { 
       fix x s v
       assume A: "x \<in> bprog_vars bp" "s \<in> state_bound bp s0"
 
       have SB_CNV: "bs_\<alpha> (set_bit s x v) 
         = (if v then (insert x (bs_\<alpha> s)) else (bs_\<alpha> s - {x}))"
         apply (cases v)
         apply simp_all
         apply (fold bs_insert_def bs_delete_def)
         apply (simp_all add: bs_correct)
         done
 
       from A have "set_bit s x v \<in> state_bound bp s0"
         unfolding state_bound_def
         by (auto simp: SB_CNV)
     } note aux=this
 
     {
       fix vs
       have "foldl (\<lambda>s (x, y). set_bit s x y) s (zip xs vs) 
         \<in> state_bound (Array instrs) s0"
         using SB XSB
         apply (induct xs arbitrary: vs s)
         apply simp
         apply (case_tac vs)
         apply simp
         using aux
         apply (auto)
         done
     } note aux2=this
 
     thus ?thesis using STEP'
       by (simp add: AssI)
   qed (auto split: if_split_asm)
 qed
 
 lemma in_bound_step: 
   notes [simp del] = exec.simps
   assumes BOUND: "c \<in> config_bound bp s0"
   assumes STEP: "c'\<in>set (nexts bp c)"
   shows "c' \<in> config_bound bp s0"
   using BOUND STEP
   apply (cases c)
   apply (auto 
     simp add: nexts.simps 
     split: if_split_asm)
   apply (frule (2) exec_bound[THEN subsetD])
   apply clarsimp
   apply (frule (1) rcs_aux)
   apply simp
 
   apply (frule (2) exec_bound[THEN subsetD])
   apply clarsimp
   
   apply (frule (1) rcs_aux)
   apply simp
   done
 
 lemma reachable_configs_in_bound:
   "c \<in> config_bound bp s0 \<Longrightarrow> reachable_configs bp c \<subseteq> config_bound bp s0"
 proof 
   fix c'
   assume "c' \<in> reachable_configs bp c" "c \<in> config_bound bp s0" 
   thus "c' \<in> config_bound bp s0"
     apply induction
     apply simp
     by (rule in_bound_step)
 qed
     
 lemma reachable_configs_out_of_bound: "(pc',s')\<in>reachable_configs bp (pc,s) 
   \<Longrightarrow> \<not> pc < pc_bound bp \<Longrightarrow> (pc',s') = (pc,s)"
 proof (induct rule: reachable_configs_induct)
   case (1 pc' s' pc'' s'')
   hence [simp]: "pc'=pc" "s'=s" by auto
   from 1(4) have "\<not> pc < array_length bp" unfolding pc_bound_def by auto
   with 1(3) show ?case
     by (auto simp add: nexts.simps exec'.simps)
 qed auto
 
 lemma finite_bexp_vars[simp, intro!]: "finite (bexp_vars be)"
   by (induction be) auto
 
 lemma finite_instr_vars[simp, intro!]: "finite (instr_vars ins)"
   by (cases ins) auto
 
 lemma finite_bprog_vars[simp, intro!]: "finite (bprog_vars bp)"
   unfolding bprog_vars_def by simp
 
 lemma finite_state_bound[simp, intro!]: "finite (state_bound bp s0)"
   unfolding state_bound_def
   apply (rule finite_imageD[where f=bs_\<alpha>])
   apply (rule finite_subset[where 
     B = "{s. s - bprog_vars bp = bs_\<alpha> s0 - bprog_vars bp}"])
   apply auto []
   apply (rule finite_if_eq_beyond_finite)
   apply simp
 
   apply (rule inj_onI)
   apply (fold bs_eq_def)
   apply (auto simp: bs_eq_correct)
   done
 
 lemma finite_config_bound[simp, intro!]: "finite (config_bound bp s0)"
   by blast
 
 lemma reachable_configs_finite[simp, intro!]: 
   "finite (reachable_configs bp c)"
 proof (cases c, clarsimp)
   fix pc s
   show "finite (reachable_configs bp (pc, s))"
   proof (cases "pc < pc_bound bp")
     case False from reachable_configs_out_of_bound[OF _ False, where s=s]
     have "reachable_configs bp (pc, s) \<subseteq> {(pc,s)}" by auto
     thus ?thesis by (rule finite_subset) auto
   next
     case True
     hence "(pc,s) \<in> config_bound bp s"
       by (simp add: state_bound_def)
     thus ?thesis
       by (rule finite_subset[OF reachable_configs_in_bound]) simp
   qed
 qed
 
 definition "bpc_is_run bpc r \<equiv> let (bp,c)=bpc in r 0 = c \<and> (\<forall>i. r (Suc i) \<in> set (BoolProgs.nexts bp (r i)))"
 definition "bpc_props c \<equiv> bs_\<alpha> (snd c)"
 definition "bpc_lang bpc \<equiv> {bpc_props o r | r. bpc_is_run bpc r}"
 
 (* Printing *)
 (*definition print_list where
   "print_list f sep s = (let f' = (\<lambda>str s. if str = [] then f s
                                        else str @ sep @ f s)
                      in ''['' @ (foldl f' [] s) @ '']'')"
 
 fun bool_list_to_prop_list where
   "bool_list_to_prop_list _ [] props = props"
 | "bool_list_to_prop_list n (x#xs) props = (let props' = if x then n#props else props 
                                             in bool_list_to_prop_list (Suc n) xs props')"
 *)
 
 fun print_config :: 
   "(nat \<Rightarrow> string) \<Rightarrow> (bitset \<Rightarrow> string) \<Rightarrow> config \<Rightarrow> string" where
   "print_config f fx (p,s) = f p @ '' '' @ fx s"
 
 end
diff --git a/thys/CAVA_LTL_Modelchecker/SM/Analysis/SM_Variables.thy b/thys/CAVA_LTL_Modelchecker/SM/Analysis/SM_Variables.thy
--- a/thys/CAVA_LTL_Modelchecker/SM/Analysis/SM_Variables.thy
+++ b/thys/CAVA_LTL_Modelchecker/SM/Analysis/SM_Variables.thy
@@ -1,239 +1,240 @@
 section \<open>Accessed Variables\<close>
 theory SM_Variables
 imports "../Refine/SM_Pid"
 begin
 
   subsection "Expressions"
 
   primrec udvars_of_exp :: "exp \<Rightarrow> ident set" where
       "udvars_of_exp (e_var x) = {x}"
     | "udvars_of_exp (e_localvar x) = {}"
     | "udvars_of_exp (e_globalvar x) = {}"
     | "udvars_of_exp (e_const c) = {}"
     | "udvars_of_exp (e_bin bop e1 e2) = (udvars_of_exp e1) \<union> (udvars_of_exp e2)"
     | "udvars_of_exp (e_un uop e) = (udvars_of_exp e)"
 
   primrec lvars_of_exp :: "exp \<Rightarrow> ident set" where
       "lvars_of_exp (e_var x) = {}"
     | "lvars_of_exp (e_localvar x) = {x}"
     | "lvars_of_exp (e_globalvar x) = {}"
     | "lvars_of_exp (e_const c) = {}"
     | "lvars_of_exp (e_bin bop e1 e2) = (lvars_of_exp e1) \<union> (lvars_of_exp e2)"
     | "lvars_of_exp (e_un uop e) = (lvars_of_exp e)"
       
   primrec gvars_of_exp :: "exp \<Rightarrow> ident set" where
       "gvars_of_exp (e_var x) = {}"
     | "gvars_of_exp (e_localvar x) = {}"
     | "gvars_of_exp (e_globalvar x) = {x}"
     | "gvars_of_exp (e_const c) = {}"
     | "gvars_of_exp (e_bin bop e1 e2) = (gvars_of_exp e1) \<union> (gvars_of_exp e2)"
     | "gvars_of_exp (e_un uop e) = (gvars_of_exp e)"
 
   subsection "Commands"
   primrec join_cmd_exp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (exp \<Rightarrow> 'a) \<Rightarrow> cmd \<Rightarrow> 'a" where  
     "join_cmd_exp z join f (Assign c x e) = join (f c) (f e)"
   | "join_cmd_exp z join f (Assign_local c x e) = join (f c) (f e)"
   | "join_cmd_exp z join f (Assign_global c x e) = join (f c) (f e)"
   | "join_cmd_exp z join f (Test e) = f e"
   | "join_cmd_exp z join f (Skip) = z"
   | "join_cmd_exp z join f (Seq c1 c2) 
       = join (join_cmd_exp z join f c1) (join_cmd_exp z join f c2)"
   | "join_cmd_exp z join f (Or c1 c2) 
       = join (join_cmd_exp z join f c1) (join_cmd_exp z join f c2)"
   | "join_cmd_exp z join f (Break) = z"
   | "join_cmd_exp z join f (Continue) = z"
   | "join_cmd_exp z join f (Iterate c1 c2) 
       = join (join_cmd_exp z join f c1) (join_cmd_exp z join f c2)"
   | "join_cmd_exp z join f (Invalid) = z"
 
   abbreviation "union_cmd_exp \<equiv> join_cmd_exp {} (\<union>)"
   abbreviation "all_cmd_exp \<equiv> join_cmd_exp True (\<and>)"
   abbreviation "ex_cmd_exp \<equiv> join_cmd_exp False (\<or>)"
 
   abbreviation "ud_rvars_of_cmd == union_cmd_exp udvars_of_exp"
   abbreviation "g_rvars_of_cmd == union_cmd_exp gvars_of_exp"
   abbreviation "l_rvars_of_cmd == union_cmd_exp lvars_of_exp"
 
   primrec ud_wvars_of_cmd :: "cmd \<Rightarrow> ident set" where  
     "ud_wvars_of_cmd (Assign c x e) = {x}"
   | "ud_wvars_of_cmd (Assign_local c x e) = {}"
   | "ud_wvars_of_cmd (Assign_global c x e) = {}"
   | "ud_wvars_of_cmd (Test e) = {}"
   | "ud_wvars_of_cmd (Skip) = {}"
   | "ud_wvars_of_cmd (Seq c1 c2) = (ud_wvars_of_cmd c1 \<union> ud_wvars_of_cmd c2)"
   | "ud_wvars_of_cmd (Or c1 c2) = (ud_wvars_of_cmd c1 \<union> ud_wvars_of_cmd c2)"
   | "ud_wvars_of_cmd (Break) = {}"
   | "ud_wvars_of_cmd (Continue) = {}"
   | "ud_wvars_of_cmd (Iterate c1 c2) = (ud_wvars_of_cmd c1 \<union> ud_wvars_of_cmd c2)"
   | "ud_wvars_of_cmd (Invalid) = {}"
 
   primrec l_wvars_of_cmd :: "cmd \<Rightarrow> ident set" where  
     "l_wvars_of_cmd (Assign c x e) = {}"
   | "l_wvars_of_cmd (Assign_local c x e) = {x}"
   | "l_wvars_of_cmd (Assign_global c x e) = {}"
   | "l_wvars_of_cmd (Test e) = {}"
   | "l_wvars_of_cmd (Skip) = {}"
   | "l_wvars_of_cmd (Seq c1 c2) = (l_wvars_of_cmd c1 \<union> l_wvars_of_cmd c2)"
   | "l_wvars_of_cmd (Or c1 c2) = (l_wvars_of_cmd c1 \<union> l_wvars_of_cmd c2)"
   | "l_wvars_of_cmd (Break) = {}"
   | "l_wvars_of_cmd (Continue) = {}"
   | "l_wvars_of_cmd (Iterate c1 c2) = (l_wvars_of_cmd c1 \<union> l_wvars_of_cmd c2)"
   | "l_wvars_of_cmd (Invalid) = {}"
 
   primrec g_wvars_of_cmd :: "cmd \<Rightarrow> ident set" where  
     "g_wvars_of_cmd (Assign c x e) = {}"
   | "g_wvars_of_cmd (Assign_local c x e) = {}"
   | "g_wvars_of_cmd (Assign_global c x e) = {x}"
   | "g_wvars_of_cmd (Test e) = {}"
   | "g_wvars_of_cmd (Skip) = {}"
   | "g_wvars_of_cmd (Seq c1 c2) = (g_wvars_of_cmd c1 \<union> g_wvars_of_cmd c2)"
   | "g_wvars_of_cmd (Or c1 c2) = (g_wvars_of_cmd c1 \<union> g_wvars_of_cmd c2)"
   | "g_wvars_of_cmd (Break) = {}"
   | "g_wvars_of_cmd (Continue) = {}"
   | "g_wvars_of_cmd (Iterate c1 c2) = (g_wvars_of_cmd c1 \<union> g_wvars_of_cmd c2)"
   | "g_wvars_of_cmd (Invalid) = {}"
 
 
   definition "udvars_of_cmd c \<equiv> ud_rvars_of_cmd c \<union> ud_wvars_of_cmd c"
   definition "lvars_of_cmd c \<equiv> l_rvars_of_cmd c \<union> l_wvars_of_cmd c"
   definition "gvars_of_cmd c \<equiv> g_rvars_of_cmd c \<union> g_wvars_of_cmd c"
 
   fun read_globals :: "action \<Rightarrow> ident set" where
     "read_globals (AAssign c _ e) = gvars_of_exp c \<union> udvars_of_exp c \<union>
       gvars_of_exp e \<union> udvars_of_exp e"
   | "read_globals (AAssign_local c _ e) = gvars_of_exp c \<union> udvars_of_exp c \<union>
       gvars_of_exp e \<union> udvars_of_exp e"
   | "read_globals (AAssign_global c _ e) = gvars_of_exp c \<union> udvars_of_exp c \<union>
       gvars_of_exp e \<union> udvars_of_exp e"
   | "read_globals (ATest e) = gvars_of_exp e \<union> udvars_of_exp e"
   | "read_globals (ASkip) = {}"
 
   fun write_globals :: "action \<Rightarrow> ident set" where
     "write_globals (AAssign _ x _) = {x}"
   | "write_globals (AAssign_local _ _ _) = {}"
   | "write_globals (AAssign_global _ x _) = {x}"
   | "write_globals (ATest e) = {}"
   | "write_globals (ASkip) = {}"
 
   abbreviation "rw_globals a \<equiv> read_globals a \<union> write_globals a"
 
   definition eq_on :: "ident set \<Rightarrow> valuation \<Rightarrow> valuation \<Rightarrow> bool"
     where "eq_on X s1 s2 \<equiv> \<forall>x\<in>X. s1 x = s2 x"
 
   lemma eq_onD: "\<lbrakk>eq_on X s1 s2; x\<in>X\<rbrakk> \<Longrightarrow> s1 x = s2 x"
     unfolding eq_on_def by auto  
     
   lemma 
     eq_on_refl[simp]: "eq_on X s s" and
     eq_on_sym: "eq_on X s1 s2 \<Longrightarrow> eq_on X s2 s1" and
     eq_on_sym_eq: "eq_on X s1 s2 \<longleftrightarrow> eq_on X s2 s1" and
     eq_on_trans[trans]: "\<lbrakk>eq_on Xa s1 s2; eq_on Xb s2 s3\<rbrakk> 
       \<Longrightarrow> eq_on (Xa\<inter>Xb) s1 s3" and
     eq_on_UNIV_eq[simp]: "eq_on UNIV s1 s2 \<longleftrightarrow> s1=s2"  
     unfolding eq_on_def by auto
 
   lemma eq_on_join: "\<lbrakk>eq_on X s s'; eq_on Y s s'\<rbrakk> \<Longrightarrow> eq_on (X\<union>Y) s s'"
     unfolding eq_on_def by auto
 
   abbreviation ls_eq_on :: "ident set \<Rightarrow> local_state \<Rightarrow> local_state \<Rightarrow> bool"
     where "ls_eq_on X ls1 ls2 \<equiv> 
       eq_on X (local_state.variables ls1) (local_state.variables ls2)"  
 
   abbreviation gs_eq_on :: "ident set \<Rightarrow> global_state \<Rightarrow> global_state \<Rightarrow> bool"
     where "gs_eq_on X ls1 ls2 \<equiv> 
       eq_on X (global_state.variables ls1) (global_state.variables ls2)"  
 
   lemma eval_dep_vars:
     assumes "gs_eq_on X gs gs'"    
     assumes "udvars_of_exp e \<subseteq> X" "gvars_of_exp e \<subseteq> X"
     shows "eval_exp e (ls,gs) = eval_exp e (ls,gs')"
     using assms
     apply (induction e)
     apply (auto split: option.splits simp: eq_on_def)
     done    
 
   lemma en_dep_read:
     assumes "gs_eq_on X gs gs'"
     assumes "read_globals a \<subseteq> X"
     shows "la_en' (ls,gs) a = la_en' (ls,gs') a"
     using assms
     apply (cases a)
     apply (auto 
       simp: la_en'_def eval_dep_vars 
       split: Option.bind_splits)
     done
 
   lemma ex_mod_limit: 
     assumes "la_ex' (ls,gs) a = (ls',gs')"
     shows "gs_eq_on (-write_globals a) gs gs'"
     using assms
     apply (cases a)
     apply (auto 
       simp: la_ex'_def eval_dep_vars eq_on_def 
-      split: option.splits Option.bind_splits if_split_asm)
+      split: option.splits Option.bind_splits)
+    apply (auto split: if_split_asm)
     done    
 
   lemma ex_dep_pres:
     assumes "gs_eq_on X gs1 gs2"
     assumes "read_globals a \<subseteq> X"
     assumes "la_ex' (ls,gs1) a = (ls1',gs1')"
     assumes "la_ex' (ls,gs2) a = (ls2',gs2')"
     shows "ls1'=ls2' \<and> gs_eq_on X gs1' gs2'"
     using assms
     apply (cases a)
     apply (auto 
       simp: la_ex'_def eval_dep_vars eq_on_def
       split: Option.bind_splits option.splits bool.splits if_split_asm)
     done
 
 
   lemma ex_swap_global:
     assumes DJ:
       "write_globals a1 \<inter> read_globals a2 = {}"
       "write_globals a2 \<inter> read_globals a1 = {}"
       "write_globals a1 \<inter> write_globals a2 = {}"
     assumes EXA: 
       "la_ex' (ls1,gs) a1 = (ls1a, gsa)"
       "la_ex' (ls2, gsa) a2 = (ls2a, gsa')"
     assumes EXB:
       "la_ex' (ls2,gs) a2 = (ls2b, gsb)"
       "la_ex' (ls1, gsb) a1 = (ls1b, gsb')"
     shows "ls1a=ls1b" "ls2a=ls2b" "gsa'=gsb'"
   proof -
     from ex_dep_pres[OF ex_mod_limit[OF EXB(1)] _ EXA(1) EXB(2)] DJ
     have "ls1a = ls1b" and E1: "gs_eq_on (- write_globals a2) gsa gsb'"
       by auto
     thus [simp]: "ls1a=ls1b" by simp
       
     from 
       ex_dep_pres[OF 
         ex_mod_limit[OF EXA(1), THEN eq_on_sym] _ EXA(2) EXB(1)
       ] DJ
     have "ls2a = ls2b" and E2: "gs_eq_on (- write_globals a1) gsa' gsb"
       by auto
     thus [simp]: "ls2a=ls2b" by simp
 
     from DJ have [simp]: "- write_globals a1 \<union> - write_globals a2 = UNIV" 
       by auto
 
     from eq_on_trans[OF E2 ex_mod_limit[OF EXB(2)]]
     have "gs_eq_on (- write_globals a1) gsa' gsb'" by simp
     also from eq_on_trans[OF ex_mod_limit[OF EXA(2), THEN eq_on_sym] E1]
     have "gs_eq_on (- write_globals a2) gsa' gsb'" by simp
     finally (eq_on_join) have "gs_eq_on UNIV gsa' gsb'" by simp
     thus "gsa' = gsb'" 
       apply (cases gsa', cases gsb')
       apply simp
       done
   qed
 
   lemma ex_pres_en:
     assumes EX: "la_ex' (ls1,gs) a1 = (ls1',gs')"
     assumes DJ: "write_globals a1 \<inter> read_globals a2 = {}"
     shows "la_en' (ls2,gs') a2 = la_en' (ls2,gs) a2"
     using en_dep_read[OF ex_mod_limit[OF EX], of a2] DJ by auto
 
 
 
 end
 
diff --git a/thys/Circus/Denotational_Semantics.thy b/thys/Circus/Denotational_Semantics.thy
--- a/thys/Circus/Denotational_Semantics.thy
+++ b/thys/Circus/Denotational_Semantics.thy
@@ -1,1055 +1,1039 @@
 section \<open>Denotational semantics of Circus actions\<close>
 
 theory Denotational_Semantics 
 imports Circus_Actions Var_list
 begin
 
 text \<open>In this section, we introduce the definitions of Circus actions denotational semantics.
 We provide the proof of well-formedness of every action. We also provide proofs concerning 
 the monotonicity of operators over actions.\<close>
 
 subsection \<open>Skip\<close>
 
 definition Skip :: "('\<theta>::ev_eq,'\<sigma>) action" where
 "Skip \<equiv> action_of 
                   (R (true \<turnstile> \<lambda>(A, A'). tr A' = tr A \<and> \<not>wait A' \<and> more A = more A'))"
 
 lemma Skip_is_action: 
 "(R (true \<turnstile> \<lambda>(A, A'). tr A' = tr A \<and> \<not>wait A' \<and> more A = more A')) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule rd_is_CSP)
 by auto
 
 lemmas Skip_is_CSP = Skip_is_action[simplified]
 
 lemma relation_of_Skip: 
 "relation_of Skip = 
                   (R (true \<turnstile> \<lambda>(A, A'). tr A' = tr A \<and> \<not>wait A' \<and> more A = more A'))"
 by (simp add: Skip_def action_of_inverse Skip_is_CSP)
 
 definition CSP3::"(('\<theta>::ev_eq,'\<sigma>) alphabet_rp) Healthiness_condition"
 where "CSP3 (P)  \<equiv>  relation_of Skip ;; P"
 
 definition CSP4::"(('\<theta>::ev_eq,'\<sigma>) alphabet_rp) Healthiness_condition"
 where "CSP4 (P)  \<equiv>  P ;; relation_of Skip"
 
 lemma Skip_is_CSP3: "(relation_of Skip) is CSP3 healthy"
 apply (auto simp: relation_of_Skip rp_defs design_defs fun_eq_iff CSP3_def)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 prefer 3
 apply (split cond_splits, simp_all)+
 apply (auto simp add: prefix_def)
 done
 
 lemma Skip_is_CSP4: "(relation_of Skip) is CSP4 healthy"
 apply (auto simp: relation_of_Skip rp_defs design_defs fun_eq_iff CSP4_def)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 prefer 3
 apply (split cond_splits, simp_all)+
 apply (auto simp add: prefix_def)
 done
 
 
 lemma Skip_comp_absorb: "(relation_of Skip ;; relation_of Skip) = relation_of Skip"
 apply (auto simp: relation_of_Skip fun_eq_iff rp_defs true_def design_defs)
 apply (clarsimp split: cond_splits)+
 apply (case_tac "ok aa", simp_all)
 apply (erule disjE)+
 apply (clarsimp simp: prefix_def)
 apply (clarsimp simp: prefix_def)
 apply (erule disjE)+
 apply (clarsimp simp: prefix_def)
 apply (clarsimp simp: prefix_def)
 apply (erule disjE)+
 apply (clarsimp simp: prefix_def)
 apply (clarsimp simp: prefix_def)
 apply (case_tac "ok aa", simp_all)
 apply (clarsimp simp: prefix_def)
 apply (clarsimp split: cond_splits)+
 apply (rule_tac b=a in comp_intro)
 apply (clarsimp split: cond_splits)+
 apply (rule_tac b=a in comp_intro)
 apply (clarsimp split: cond_splits)+
 done
 
 
 subsection \<open>Stop\<close>
 
 definition Stop :: "('\<theta>::ev_eq,'\<sigma>) action"
 where "Stop \<equiv> action_of (R (true \<turnstile> \<lambda>(A, A'). tr A' = tr A \<and> wait A'))"
 
 lemma Stop_is_action:
 "(R (true \<turnstile> \<lambda>(A, A'). tr A' = tr A \<and> wait A')) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule rd_is_CSP)
 by auto
 
 lemmas Stop_is_CSP = Stop_is_action[simplified]
 
 lemma relation_of_Stop:
 "relation_of Stop = (R (true \<turnstile> \<lambda>(A, A'). tr A' = tr A \<and> wait A'))"
 by (simp add: Stop_def action_of_inverse Stop_is_CSP)
 
 
 lemma Stop_is_CSP3: "(relation_of Stop) is CSP3 healthy"
 apply (auto simp: relation_of_Stop relation_of_Skip rp_defs design_defs fun_eq_iff CSP3_def)
 apply (rule_tac b=a in comp_intro)
 apply (split cond_splits, auto)
 apply (split cond_splits)+
 apply (simp_all)
 apply (case_tac "ok aa", simp_all)
 apply (case_tac "tr aa \<le> tr ba", simp_all)
 apply (case_tac "ok ba", simp_all)
 apply (case_tac "tr ba \<le> tr c", simp_all)
 apply (rule disjI1)
 apply (simp add: prefix_def)
 apply (erule exE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (rule disjI1)
 apply (simp add: prefix_def)
 apply (erule exE | erule conjE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (split cond_splits)+
 apply (simp_all add: true_def)
 apply (erule disjE)
 apply (simp add: prefix_def)
 apply (erule exE | erule conjE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (auto simp add: prefix_def)
 done
 
 
 lemma Stop_is_CSP4: "(relation_of Stop) is CSP4 healthy"
 apply (auto simp: relation_of_Stop relation_of_Skip rp_defs design_defs fun_eq_iff CSP4_def)
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (case_tac "ok aa", simp_all)
 apply (case_tac "tr aa \<le> tr ba", simp_all)
 apply (case_tac "ok ba", simp_all)
 apply (case_tac "tr ba \<le> tr c", simp_all)
 apply (rule disjI1)
 apply (simp add: prefix_def)
 apply (erule exE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (rule disjI1)
 apply (simp add: prefix_def)
 apply (erule exE | erule conjE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (split cond_splits)+
 apply (simp_all add: true_def)
 apply (erule disjE)
 apply (simp add: prefix_def)
 apply (erule exE | erule conjE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (auto simp add: prefix_def)
 done
 
 subsection \<open>Chaos\<close>
 
 definition Chaos :: "('\<theta>::ev_eq,'\<sigma>) action"
 where "Chaos \<equiv> action_of (R(false \<turnstile> true))"
 
 lemma Chaos_is_action: "(R(false \<turnstile> true)) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule rd_is_CSP)
 by auto
 
 lemmas Chaos_is_CSP = Chaos_is_action[simplified]
 
 lemma relation_of_Chaos: "relation_of Chaos = (R(false \<turnstile> true))"
 by (simp add: Chaos_def action_of_inverse Chaos_is_CSP)
 
 
 subsection \<open>State update actions\<close>
 
 definition Pre ::"'\<sigma> relation  \<Rightarrow> '\<sigma> predicate"
 where "Pre sc \<equiv> \<lambda>A. \<exists> A'. sc (A, A')"
 
 
 definition state_update_before :: "'\<sigma> relation \<Rightarrow> ('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action"
 where "state_update_before sc Ac = action_of(R ((\<lambda>(A, A'). (Pre sc) (more A)) \<turnstile> 
                       (\<lambda>(A, A'). sc (more A, more A') & \<not>wait A' & tr A = tr A')) ;; relation_of Ac)"
 
 lemma state_update_before_is_action: 
 "(R ((\<lambda>(A, A'). (Pre sc) (more A)) \<turnstile> 
                                (\<lambda>(A, A').sc (more A, more A') & \<not>wait A' & tr A = tr A')) ;; relation_of Ac) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule seq_CSP)
 apply (rule rd_is_CSP1)
 apply (auto simp: R_idem2 Healthy_def relation_of_CSP)
 done
 
 lemmas state_update_before_is_CSP = state_update_before_is_action[simplified]
 
 lemma relation_of_state_update_before:
 "relation_of (state_update_before sc Ac) = (R ((\<lambda>(A, A'). (Pre sc) (more A)) \<turnstile> 
                                (\<lambda>(A, A'). sc (more A, more A') & \<not>wait A' & tr A = tr A')) ;; relation_of Ac)"
 by (simp add: state_update_before_def action_of_inverse state_update_before_is_CSP)
 
 lemma mono_state_update_before: "mono (state_update_before sc)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_state_update_before design_defs rp_defs fun_eq_iff 
             split: cond_splits dest: relation_of_spec_f_f[simplified] 
                                      relation_of_spec_t_f[simplified])
 
 lemma state_update_before_is_CSP3: "relation_of (state_update_before sc Ac) is CSP3 healthy"
 apply (auto simp: relation_of_state_update_before relation_of_Skip rp_defs design_defs fun_eq_iff CSP3_def)
 apply (rule_tac b=aa in comp_intro)
 apply (split cond_splits, auto)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=bb in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (case_tac "ok aa", simp_all)
 apply (case_tac "tr aa \<le> tr ab", simp_all)
 apply (case_tac "ok ab", simp_all)
 apply (case_tac "tr ab \<le> tr bb", simp_all)
 apply (rule disjI1)
 apply (simp add: prefix_def)
 apply (erule exE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (rule_tac b=bb in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule disjI1)
 apply (simp add: prefix_def)
 apply (erule exE | erule conjE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (rule_tac b=bb in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (simp_all add: true_def)
 apply (erule disjE)
 apply (simp add: prefix_def)
 apply (erule exE | erule conjE)+
 apply (rule_tac x="zs@zsa" in exI, simp)
 apply (auto simp add: prefix_def)
 done
 
 
 lemma state_update_before_is_CSP4: 
   assumes A : "relation_of Ac is CSP4 healthy"
   shows "relation_of (state_update_before sc Ac) is CSP4 healthy"
 apply (auto simp: relation_of_state_update_before relation_of_Skip rp_defs design_defs fun_eq_iff CSP4_def)
 apply (rule_tac b=c in comp_intro)
 apply (rule_tac b=ba in comp_intro, simp_all)
 apply (split cond_splits, simp_all)
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (subst A[simplified design_defs rp_defs CSP4_def relation_of_Skip])
 apply (auto simp: rp_defs)
 done
 
 definition state_update_after :: "'\<sigma> relation \<Rightarrow> ('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action"
 where "state_update_after sc Ac = action_of(relation_of Ac ;; R (true \<turnstile> (\<lambda>(A, A'). sc (more A, more A') & \<not>wait A' & tr A = tr A')))"
 
 lemma state_update_after_is_action: 
 "(relation_of Ac ;; R (true \<turnstile> (\<lambda>(A, A'). sc (more A, more A') & \<not>wait A' & tr A = tr A'))) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule seq_CSP)
 apply (auto simp: relation_of_CSP[simplified is_CSP_process_def])
 apply (rule rd_is_CSP, auto)
 done
 
 lemmas state_update_after_is_CSP = state_update_after_is_action[simplified]
 
 lemma relation_of_state_update_after:
 "relation_of (state_update_after sc Ac) = (relation_of Ac ;; R (true \<turnstile> (\<lambda>(A, A'). sc (more A, more A') & \<not>wait A' & tr A = tr A')))"
 by (simp add: state_update_after_def action_of_inverse state_update_after_is_CSP)
 
 lemma mono_state_update_after: "mono (state_update_after sc)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_state_update_after design_defs rp_defs fun_eq_iff 
             split: cond_splits dest: relation_of_spec_f_f[simplified] 
                                      relation_of_spec_t_f[simplified])
 
 
 lemma state_update_after_is_CSP3: 
   assumes A : "relation_of Ac is CSP3 healthy"
   shows "relation_of (state_update_after sc Ac) is CSP3 healthy"
 apply (auto simp: relation_of_state_update_after relation_of_Skip rp_defs design_defs fun_eq_iff CSP3_def)
 apply (rule_tac b=aa in comp_intro)
 apply (split cond_splits, auto)
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (subst A[simplified design_defs rp_defs CSP3_def relation_of_Skip])
 apply (auto simp: rp_defs)
 done
 
 
 lemma state_update_after_is_CSP4: "relation_of (state_update_after sc Ac) is CSP4 healthy"
 apply (auto simp: relation_of_state_update_after relation_of_Skip rp_defs design_defs fun_eq_iff CSP4_def)
 apply (rule_tac b=c in comp_intro)
 apply (rule_tac b=ba in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (case_tac "ok bb", simp_all)
 apply (case_tac "tr bb \<le> tr c", simp_all)
 apply (case_tac "ok ca", simp_all)
 apply (case_tac "tr ca \<le> tr c", simp_all)
-apply (simp add: prefix_def)
-apply (erule exE)+
-apply (erule_tac x="zs@zsa" in allE, simp)
-apply (rule_tac b=bb in comp_intro, simp_all)
-apply (split cond_splits, simp_all add: true_def)+
-apply (case_tac "ok ca", simp_all)
-apply (case_tac "tr ca \<le> tr c", simp_all)
-apply (simp add: prefix_def)
-apply (erule exE | erule conjE)+
-apply (rule_tac x="zsa@zs" in exI, simp)
-apply (rule_tac b=bb in comp_intro, simp_all)
-apply (split cond_splits, simp_all)+
-apply (case_tac "tr bb \<le> tr c", simp_all)
-apply (simp add: prefix_def)
-apply (erule exE | erule conjE)+
-apply (erule_tac x="zsa@zs" in allE, simp)
-apply (auto simp add: prefix_def)
+apply (auto simp add: prefix_def comp_def true_def split: cond_splits)
 done
 
 
 
 subsection \<open>Sequential composition\<close>
 
 definition 
 Seq::"('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action" (infixl "`;`" 24)
 where "P `;` Q \<equiv> action_of (relation_of P ;; relation_of Q)"
 
 lemma Seq_is_action: "(relation_of P ;; relation_of Q) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule seq_CSP[OF relation_of_CSP[THEN CSP_is_CSP1] relation_of_CSP[THEN CSP_is_R] relation_of_CSP])
 done
 
 lemmas Seq_is_CSP = Seq_is_action[simplified]
 
 lemma relation_of_Seq: "relation_of (P `;` Q) = (relation_of P ;; relation_of Q)"
 by (simp add: Seq_def action_of_inverse Seq_is_CSP)
 
 lemma mono_Seq: "mono ((`;`) P)"
   by (auto simp: mono_def less_eq_action ref_def relation_of_Seq)
 
 
 lemma CSP3_imp_left_Skip:
   assumes A: "relation_of P is CSP3 healthy"
   shows "(Skip `;` P) = P"
 apply (subst relation_of_inject[symmetric])
 apply (simp add: relation_of_Seq A[simplified design_defs CSP3_def, symmetric])
 done
 
 lemma CSP4_imp_right_Skip:
   assumes A: "relation_of P is CSP4 healthy"
   shows "(P `;` Skip) = P"
 apply (subst relation_of_inject[symmetric])
 apply (simp add: relation_of_Seq A[simplified design_defs CSP4_def, symmetric])
 done
 
 lemma Seq_assoc: "(A `;` (B `;` C)) = ((A `;` B) `;` C)"
 by (auto simp: relation_of_inject[symmetric] fun_eq_iff relation_of_Seq rp_defs design_defs)
 
 lemma Skip_absorb: "(Skip `;` Skip) = Skip"
 by (auto simp: Skip_comp_absorb relation_of_inject[symmetric] relation_of_Seq)
 
 
 subsection \<open>Internal choice\<close>
 
 definition 
 Ndet::"('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action" (infixl "\<sqinter>" 18) 
 where "P \<sqinter> Q \<equiv> action_of ((relation_of P) \<or> (relation_of Q))"
 
 lemma Ndet_is_action: "((relation_of P) \<or> (relation_of Q)) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule disj_CSP)
 apply (simp_all add: relation_of_CSP)
 done
 
 lemmas Ndet_is_CSP = Ndet_is_action[simplified]
 
 lemma relation_of_Ndet: "relation_of (P \<sqinter> Q) = ((relation_of P) \<or> (relation_of Q))"
 by (simp add: Ndet_def action_of_inverse Ndet_is_CSP)
 
 lemma mono_Ndet: "mono ((\<sqinter>) P)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_Ndet)
 
 subsection \<open>External choice\<close>
 
 definition
 Det::"('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action" (infixl "\<box>" 18)
 where "P \<box> Q \<equiv> action_of(R((\<not>((relation_of P)\<^sup>f\<^sub>f) \<and> \<not>((relation_of Q)\<^sup>f\<^sub>f)) \<turnstile>
                                              (((relation_of P)\<^sup>t\<^sub>f \<and> ((relation_of Q)\<^sup>t\<^sub>f))
                                                 \<triangleleft> \<lambda>(A, A'). tr A = tr A' \<and> wait A' \<triangleright>
                                               ((relation_of P)\<^sup>t\<^sub>f \<or> ((relation_of Q)\<^sup>t\<^sub>f)))))"
 
 lemma Det_is_action: 
 "(R((\<not>((relation_of P)\<^sup>f\<^sub>f) \<and> \<not>((relation_of Q)\<^sup>f\<^sub>f)) \<turnstile>
            (((relation_of P)\<^sup>t\<^sub>f \<and> ((relation_of Q)\<^sup>t\<^sub>f))
               \<triangleleft> \<lambda>(A, A'). tr A = tr A' \<and> wait A' \<triangleright>
             ((relation_of P)\<^sup>t\<^sub>f \<or> ((relation_of Q)\<^sup>t\<^sub>f))))) \<in> {p. is_CSP_process p}"
 apply (simp add: spec_def)
 apply (rule rd_is_CSP)
 apply (auto)
 done
 
 lemmas Det_is_CSP = Det_is_action[simplified]
 
 lemma relation_of_Det:
 "relation_of (P \<box> Q) = (R((\<not>((relation_of P)\<^sup>f\<^sub>f) \<and> \<not>((relation_of Q)\<^sup>f\<^sub>f)) \<turnstile>
                                           (((relation_of P)\<^sup>t\<^sub>f \<and> ((relation_of Q)\<^sup>t\<^sub>f))
                                              \<triangleleft> \<lambda>(A, A'). tr A = tr A' \<and> wait A' \<triangleright>
                                            ((relation_of P)\<^sup>t\<^sub>f \<or> ((relation_of Q)\<^sup>t\<^sub>f)))))"
 apply (unfold Det_def)
 apply (rule action_of_inverse)
 apply (rule Det_is_action)
 done
 
 lemma mono_Det: "mono ((\<box>) P)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_Det design_defs rp_defs fun_eq_iff 
             split: cond_splits dest: relation_of_spec_f_f[simplified] 
                                      relation_of_spec_t_f[simplified])
 
 
 subsection \<open>Reactive design assignment\<close>
 
 
 definition 
 "rd_assign s = action_of (R (true \<turnstile> \<lambda>(A, A'). ref A' = ref A \<and> tr A' = tr A \<and> \<not>wait A' \<and> more A' = s))"
 
 
 lemma rd_assign_is_action: 
 "(R (true \<turnstile> \<lambda>(A, A'). ref A' = ref A \<and> tr A' = tr A \<and> \<not>wait A' \<and> more A' = s)) \<in> {p. is_CSP_process p}"
 apply (auto simp:)
 apply (rule rd_is_CSP)
 by auto
 
 lemmas rd_assign_is_CSP = rd_assign_is_action[simplified]
 
 lemma relation_of_rd_assign: 
 "relation_of (rd_assign s) = 
                   (R (true \<turnstile> \<lambda>(A, A'). ref A' = ref A \<and> tr A' = tr A \<and> \<not>wait A' \<and> more A' = s))"
 by (simp add: rd_assign_def  action_of_inverse rd_assign_is_CSP)
 
 
 
 
 
 subsection \<open>Local state external choice\<close>
 
 definition
 Loc::"'\<sigma> \<Rightarrow> ('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> '\<sigma> \<Rightarrow> ('\<theta>,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action" 
                                         ("'(()loc _ \<bullet> _ ') \<boxplus> '(()loc _ \<bullet> _ ')")
 where "(loc s1 \<bullet> P) \<boxplus> (loc s2 \<bullet> Q) \<equiv> 
                    ((rd_assign s1)`;`P) \<box> ((rd_assign s2)`;` Q)"
 
 
 
 subsection \<open>Schema expression\<close>
 
 
 definition Schema :: "'\<sigma> relation \<Rightarrow> ('\<theta>::ev_eq,'\<sigma>) action" where
 "Schema sc \<equiv> action_of(R ((\<lambda>(A, A'). (Pre sc) (more A)) \<turnstile> 
                            (\<lambda>(A, A'). sc (more A, more A') \<and> \<not>wait A' \<and> tr A = tr A')))"
 
 lemma Schema_is_action: 
 "(R ((\<lambda>(A, A'). (Pre sc) (more A)) \<turnstile> 
                  (\<lambda>(A, A'). sc (more A, more A') & \<not>wait A' & tr A = tr A'))) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule rd_is_CSP)
 apply (auto)
 done
 
 lemmas Schema_is_CSP = Schema_is_action[simplified]
 
 lemma relation_of_Schema:
 "relation_of (Schema sc) = (R ((\<lambda>(A, A'). (Pre sc) (more A)) \<turnstile> 
                           (\<lambda>(A, A'). sc (more A, more A') \<and> \<not>wait A' \<and> tr A = tr A')))"
 by (simp add: Schema_def action_of_inverse Schema_is_CSP)
 
 lemma Schema_is_state_update_before: "Schema u = state_update_before u Skip"
 apply (subst relation_of_inject[symmetric])
 apply (auto simp: relation_of_Schema relation_of_state_update_before relation_of_Skip rp_defs fun_eq_iff
                   design_defs)
 apply (split cond_splits, simp_all)
 apply (rule comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule comp_intro)
 apply (split cond_splits, simp_all)+
 prefer 3
 apply (split cond_splits, simp_all)+
 apply (auto simp: prefix_def)
 done
 
 
 
 subsection \<open>Parallel composition\<close>
 
 type_synonym '\<sigma> local_state = "('\<sigma> \<times> ('\<sigma>  \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>))"
 
 fun MergeSt :: "'\<sigma> local_state \<Rightarrow> '\<sigma> local_state \<Rightarrow> ('\<theta>,'\<sigma>) relation_rp" where 
 "MergeSt (s1,s1') (s2,s2') = ((\<lambda>(S, S'). (s1' s1) (more S) = more S');; 
                             (\<lambda>(S::('\<theta>,'\<sigma>) alphabet_rp, S'). (s2' s2) (more S) = more S'))"
 
 definition listCons ::"'\<theta> \<Rightarrow> '\<theta> list list \<Rightarrow> '\<theta> list list" ("_ ## _") where
 "a ## l = ((map (Cons a)) l)"
 
 fun ParMergel :: "'\<theta>::ev_eq list \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> set \<Rightarrow> '\<theta> list list" where
     "ParMergel [] [] cs = [[]]"
   | "ParMergel [] (b#tr2) cs = (if (filter_chan_set b cs) then [[]]
                                           else (b ## (ParMergel [] tr2 cs)))" 
   | "ParMergel (a#tr1) [] cs = (if (filter_chan_set a cs) then [[]]
                                           else (a ## (ParMergel tr1 [] cs)))"
   | "ParMergel (a#tr1) (b#tr2) cs =
            (if (filter_chan_set a cs)
                    then (if (ev_eq a b)
                               then (a ## (ParMergel tr1 tr2 cs)) 
                                else (if (filter_chan_set b cs) 
                                         then [[]] 
                                          else (b ## (ParMergel (a#tr1) tr2 cs))))
                      else (if (filter_chan_set b cs) 
                                then (a ## (ParMergel tr1 (b#tr2) cs)) 
                                  else (a ## (ParMergel tr1 (b#tr2) cs)) 
                                             @ (b ## (ParMergel (a#tr1) tr2 cs))))"
 
 definition ParMerge::"'\<theta>::ev_eq list \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> set \<Rightarrow> '\<theta> list set" where
 "ParMerge tr1 tr2 cs = set (ParMergel tr1 tr2 cs)"
 
 lemma set_Cons1: "tr1 \<in> set l \<Longrightarrow> a # tr1 \<in> (#) a ` set l"
 by (auto)
 
 lemma tr_in_set_eq: "(tr1 \<in> (#) b ` set l) = (tr1 \<noteq> [] \<and> hd tr1 = b \<and> tl tr1 \<in> set l)"
 by (induct l) auto
 
 
 
 definition M_par::"(('\<theta>::ev_eq), '\<sigma>) alpha_rp_scheme \<Rightarrow> ('\<sigma>  \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>)
                             \<Rightarrow> ('\<theta>, '\<sigma>) alpha_rp_scheme \<Rightarrow> ('\<sigma> \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>)
                                 \<Rightarrow> ('\<theta> set) \<Rightarrow> ('\<theta>, '\<sigma>) relation_rp" where
 "M_par s1 x1 s2 x2 cs = 
 ((\<lambda>(S, S'). ((diff_tr S' S) \<in> ParMerge (diff_tr s1 S) (diff_tr s2 S) cs &
      ev_eq (tr_filter (tr s1) cs) (tr_filter (tr s2) cs))) \<and>
    ((\<lambda>(S, S'). (wait s1 \<or> wait s2) \<and> 
                              ref S' \<subseteq> ((((ref s1)\<union>(ref s2))\<inter>cs)\<union>(((ref s1)\<inter>(ref s2))-cs)))
    \<triangleleft> wait o snd \<triangleright>
    ((\<lambda>(S, S'). (\<not>wait s1 \<or> \<not>wait s2)) \<and> MergeSt ((more s1), x1) ((more s2), x2))))"
 
 definition  Par::"('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> 
                     ('\<sigma>  \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<theta> set \<Rightarrow> ('\<sigma>  \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> 
                     ('\<theta>,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action" ("_ \<lbrakk> _ | _ | _ \<rbrakk> _") where
 "A1 \<lbrakk> ns1 | cs | ns2 \<rbrakk> A2 \<equiv> (action_of (R ((\<lambda> (S, S'). 
  \<not> (\<exists> tr1 tr2. ((relation_of A1)\<^sup>f\<^sub>f ;; (\<lambda> (S, S'). tr1 = (tr S))) (S, S') 
  \<and> (spec False (wait S) (relation_of A2) ;; (\<lambda> (S, _). tr2 = (tr S))) (S, S')
  \<and> ((tr_filter tr1 cs) = (tr_filter tr2 cs))) \<and>
  \<not> (\<exists> tr1 tr2. (spec False (wait S) (relation_of A1);;(\<lambda>(S, _). tr1 = tr S)) (S, S')
  \<and> ((relation_of A2)\<^sup>f\<^sub>f ;; (\<lambda>(S, S'). tr2 = (tr S))) (S, S') 
  \<and> ((tr_filter tr1 cs) = (tr_filter tr2 cs)))) \<turnstile> 
    (\<lambda> (S, S'). (\<exists> s1 s2. ((\<lambda> (A, A'). (relation_of A1)\<^sup>t\<^sub>f (A, s1)
  \<and> ((relation_of A2)\<^sup>t\<^sub>f (A, s2)));; M_par s1 ns1 s2 ns2 cs) (S, S'))))))"
 
 lemma Par_is_action: "(R ((\<lambda> (S, S'). 
  \<not> (\<exists> tr1 tr2. ((relation_of A1)\<^sup>f\<^sub>f ;; (\<lambda> (S, S'). tr1 = (tr S))) (S, S') 
  \<and> (spec False (wait S) (relation_of A2) ;; (\<lambda> (S, S'). tr2 = (tr S))) (S, S')
  \<and> ((tr_filter tr1 cs) = (tr_filter tr2 cs))) \<and>
  \<not> (\<exists> tr1 tr2. (spec False (wait S) (relation_of A1);;(\<lambda>(S, _). tr1 = tr S)) (S, S')
  \<and> ((relation_of A2)\<^sup>f\<^sub>f ;; (\<lambda> (S, S'). tr2 = (tr S))) (S, S') 
  \<and> ((tr_filter tr1 cs) = (tr_filter tr2 cs)))) \<turnstile> 
    (\<lambda> (S, S'). (\<exists> s1 s2. ((\<lambda> (A, A'). (relation_of A1)\<^sup>t\<^sub>f (A, s1)
  \<and> ((relation_of A2)\<^sup>t\<^sub>f (A, s2)));; M_par s1 ns1 s2 ns2 cs) (S, S'))))) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule rd_is_CSP)
 apply (blast)
 done
 
 lemmas Par_is_CSP = Par_is_action[simplified]
 
 lemma relation_of_Par:
 "relation_of (A1 \<lbrakk> ns1 | cs | ns2 \<rbrakk> A2) = (R ((\<lambda> (S, S'). 
  \<not> (\<exists> tr1 tr2. ((relation_of A1)\<^sup>f\<^sub>f ;; (\<lambda> (S, S'). tr1 = (tr S))) (S, S') 
  \<and> (spec False (wait S) (relation_of A2) ;; (\<lambda> (S, S'). tr2 = (tr S))) (S, S') 
  \<and> ((tr_filter tr1 cs) = (tr_filter tr2 cs))) \<and>
  \<not> (\<exists> tr1 tr2. (spec False (wait S) (relation_of A1);;(\<lambda>(S, _). tr1 = tr S)) (S, S') 
  \<and> ((relation_of A2)\<^sup>f\<^sub>f ;; (\<lambda> (S, S'). tr2 = (tr S))) (S, S') 
  \<and> ((tr_filter tr1 cs) = (tr_filter tr2 cs)))) \<turnstile> 
    (\<lambda> (S, S'). (\<exists> s1 s2. ((\<lambda> (A, A'). (relation_of A1)\<^sup>t\<^sub>f (A, s1)
  \<and> ((relation_of A2)\<^sup>t\<^sub>f (A, s2)));; M_par s1 ns1 s2 ns2 cs) (S, S')))))"
 apply (unfold Par_def)
 apply (rule action_of_inverse)
 apply (rule Par_is_action)
 done
 
 lemma mono_Par: "mono (\<lambda>Q. P \<lbrakk> ns1 | cs | ns2 \<rbrakk> Q)"
   apply (auto simp: mono_def less_eq_action ref_def relation_of_Par design_defs fun_eq_iff rp_defs
               split: cond_splits)
   apply (auto simp: rp_defs dest: relation_of_spec_f_f[simplified] relation_of_spec_t_f[simplified])
   apply (erule_tac x="tr ba" in allE, auto)
   apply (erule notE)
   apply (auto dest: relation_of_spec_f_f relation_of_spec_t_f)
 done
 
 
 subsection \<open>Local parallel block\<close>
 
 definition
 ParLoc::"'\<sigma> \<Rightarrow> ('\<sigma> \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> '\<theta> set \<Rightarrow> '\<sigma> \<Rightarrow> ('\<sigma> \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> ('\<theta>,'\<sigma>) action \<Rightarrow> ('\<theta>,'\<sigma>) action"
                                         ("'(()par _ | _ \<bullet> _ ') \<lbrakk> _ \<rbrakk> '(()par _ | _ \<bullet> _ ')")
 where 
 "(par s1 | ns1 \<bullet> P) \<lbrakk> cs \<rbrakk> (par s2 | ns2 \<bullet> Q) \<equiv> ((rd_assign s1)`;`P) \<lbrakk> ns1 | cs | ns2 \<rbrakk> ((rd_assign s2)`;` Q)"
 
 
 
 subsection \<open>Assignment\<close>
 
 definition ASSIGN::"('v, '\<sigma>) var_list \<Rightarrow> ('\<sigma> \<Rightarrow> 'v) \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action" where
 "ASSIGN x e \<equiv> action_of (R (true \<turnstile> (\<lambda> (S, S'). tr S' = tr S \<and> \<not>wait S' \<and> 
                                  (more S' = (update x (\<lambda>_. (e (more S)))) (more S)))))"
 
 syntax "_assign"::"id \<Rightarrow> ('\<sigma> \<Rightarrow> 'v) \<Rightarrow> ('\<theta>, '\<sigma>) action"  ("_ `:=` _")
 translations "y `:=` vv" => "CONST ASSIGN (VAR y) vv"
 
 lemma Assign_is_action: 
 "(R (true \<turnstile> (\<lambda> (S, S'). tr S' = tr S \<and> \<not>wait S' \<and> 
                 (more S' = (update x (\<lambda>_. (e (more S)))) (more S))))) \<in> {p. is_CSP_process p}"
 apply (simp)
 apply (rule rd_is_CSP)
 apply (blast)
 done
 
 lemmas Assign_is_CSP = Assign_is_action[simplified]
 
 lemma relation_of_Assign:
 "relation_of (ASSIGN x e) = (R (true \<turnstile> (\<lambda> (S, S'). tr S' = tr S \<and> \<not>wait S' \<and> 
                                    (more S' = (update x (\<lambda>_. (e (more S)))) (more S)))))"
 by (simp add: ASSIGN_def action_of_inverse Assign_is_CSP)
 
 lemma Assign_is_state_update_before: "ASSIGN x e = state_update_before (\<lambda> (s, s') . s' = (update x (\<lambda>_. (e s))) s) Skip"
 apply (subst relation_of_inject[symmetric])
 apply (auto simp: relation_of_Assign relation_of_state_update_before relation_of_Skip rp_defs fun_eq_iff
                   Pre_def update_def design_defs)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=b in comp_intro)
 apply (split cond_splits, simp_all)+
 defer
 apply (split cond_splits, simp_all)+
 prefer 3
 apply (split cond_splits, simp_all)+
 apply (auto simp add: prefix_def)
 done
 
 
 subsection \<open>Variable scope\<close>
 
 definition Var::"('v, '\<sigma>) var_list \<Rightarrow>('\<theta>, '\<sigma>) action \<Rightarrow> ('\<theta>::ev_eq,'\<sigma>) action" where
 "Var v A \<equiv> action_of(
      (R(true \<turnstile> (\<lambda> (A, A'). \<exists> a. tr A' = tr A \<and> \<not>wait A' \<and> more A' = (increase v a (more A)))));; 
      (relation_of A;;
      (R(true \<turnstile> (\<lambda> (A, A').  tr A' = tr A \<and> \<not>wait A' \<and> more A' = (decrease v (more A)))))))"
 
 syntax "_var"::"idt \<Rightarrow> ('\<theta>, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" ("var _ \<bullet> _" [1000] 999)
 translations "var y \<bullet> Act" => "CONST Var (VAR_LIST y) Act"
 
 lemma Var_is_action:
 "((R(true \<turnstile> (\<lambda> (A, A'). \<exists> a. tr A' = tr A \<and> \<not>wait A' \<and> more A' = (increase v a (more A)))));; 
      (relation_of A;;
      (R(true \<turnstile> (\<lambda> (A, A').  tr A' = tr A \<and> \<not>wait A' \<and> more A' = (decrease v (more A))))))) \<in> {p. is_CSP_process p}"
   apply (simp)
   apply (rule seq_CSP)
   prefer 3
   apply (rule seq_CSP)
   apply (auto simp: relation_of_CSP1 relation_of_R)
   apply (rule rd_is_CSP)
   apply (auto simp: csp_defs rp_defs design_defs fun_eq_iff prefix_def increase_def decrease_def
                split: cond_splits)
 done
 
 lemmas Var_is_CSP = Var_is_action[simplified]
 
 lemma relation_of_Var:
 "relation_of (Var v A) = 
     ((R(true \<turnstile> (\<lambda> (A, A'). \<exists> a. tr A' = tr A \<and> \<not>wait A' \<and> more A' = (increase v a (more A)))));; 
      (relation_of A;;
      (R(true \<turnstile> (\<lambda> (A, A').  tr A' = tr A \<and> \<not>wait A' \<and> more A' = (decrease v (more A)))))))"
 apply (simp only: Var_def)
 apply (rule action_of_inverse)
 apply (rule Var_is_action)
 done
 
 
 lemma mono_Var : "mono (Var x)"
   by (auto simp: mono_def less_eq_action ref_def relation_of_Var)
 
 
 
 definition Let::"('v, '\<sigma>) var_list \<Rightarrow>('\<theta>, '\<sigma>) action \<Rightarrow> ('\<theta>::ev_eq,'\<sigma>) action" where
 "Let v A \<equiv> action_of((relation_of A;;
      (R(true \<turnstile> (\<lambda> (A, A').  tr A' = tr A \<and> \<not>wait A' \<and> more A' = (decrease v (more A)))))))"
 
 syntax "_let"::"idt \<Rightarrow> ('\<theta>, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" ("let _ \<bullet> _" [1000] 999)
 translations "let y \<bullet> Act" => "CONST Let (VAR_LIST y) Act"
 
 lemma Let_is_action:
 "(relation_of A;;
      (R(true \<turnstile> (\<lambda> (A, A').  tr A' = tr A \<and> \<not>wait A' \<and> more A' = (decrease v (more A)))))) \<in> {p. is_CSP_process p}"
   apply (simp)
   apply (rule seq_CSP)
   apply (auto simp: relation_of_CSP1 relation_of_R)
   apply (rule rd_is_CSP)
   apply (auto)
 done
 
 lemmas Let_is_CSP = Let_is_action[simplified]
 
 lemma relation_of_Let:
 "relation_of (Let v A) = 
     (relation_of A;;
      (R(true \<turnstile> (\<lambda> (A, A').  tr A' = tr A \<and> \<not>wait A' \<and> more A' = (decrease v (more A))))))"
 by (simp add: Let_def action_of_inverse Let_is_CSP)
 
 lemma mono_Let : "mono (Let x)"
   by (auto simp: mono_def less_eq_action ref_def relation_of_Let)
 
 
 lemma Var_is_state_update_before: "Var v A = state_update_before (\<lambda> (s, s'). \<exists> a. s' = increase v a s) (Let v A)"
 apply (subst relation_of_inject[symmetric])
 apply (auto simp: relation_of_Var relation_of_Let relation_of_state_update_before relation_of_Skip fun_eq_iff)
 apply (auto simp: rp_defs fun_eq_iff Pre_def design_defs)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+ defer
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+ defer
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (case_tac "\<exists>A' a. A' = increase v a (alpha_rp.more aa)", simp_all add: true_def)
 apply (erule_tac x="increase v a (alpha_rp.more aa)" in allE)
 apply (erule_tac x="a" in allE, simp)
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 apply (rule_tac b=ab in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (case_tac "\<exists>A' a. A' = increase v a (alpha_rp.more aa)", simp_all add: true_def)
 apply (erule_tac x="increase v a (alpha_rp.more aa)" in allE)
 apply (erule_tac x="a" in allE, simp)
 apply (rule_tac b=bb in comp_intro, simp_all)
 apply (split cond_splits, simp_all)+
 done
 
 
 lemma Let_is_state_update_after: "Let v A = state_update_after (\<lambda> (s, s'). s' = decrease v s) A"
 apply (subst relation_of_inject[symmetric])
 apply (auto simp: relation_of_Var relation_of_Let relation_of_state_update_after relation_of_Skip fun_eq_iff)
 apply (auto simp: rp_defs fun_eq_iff Pre_def design_defs)
 apply (auto split: cond_splits)
 done
 
 
 subsection \<open>Guarded action\<close>
 
 definition Guard::"'\<sigma> predicate \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" ("_ `&` _")
 where "g `&` P \<equiv> action_of(R (((g o more o fst) \<longrightarrow> \<not> ((relation_of P)\<^sup>f\<^sub>f)) \<turnstile> 
                              (((g o more o fst) \<and> ((relation_of P)\<^sup>t\<^sub>f)) \<or> 
                          ((\<not>(g o more o fst)) \<and> (\<lambda> (A, A'). tr A' = tr A \<and> wait A')))))"
 
 lemma Guard_is_action: 
 "(R ( ((g o more o fst) \<longrightarrow> \<not> ((relation_of P)\<^sup>f\<^sub>f)) \<turnstile> 
                 (((g o more o fst) \<and> ((relation_of P)\<^sup>t\<^sub>f)) \<or> 
                  ((\<not>(g o more o fst)) \<and> (\<lambda> (A, A'). tr A' = tr A \<and> wait A'))))) \<in> {p. is_CSP_process p}"
   by (auto simp add: spec_def intro: rd_is_CSP)
 
 lemmas Guard_is_CSP = Guard_is_action[simplified]
 
 lemma relation_of_Guard:
 "relation_of (g `&` P) = (R (((g o more o fst) \<longrightarrow>  \<not> ((relation_of P)\<^sup>f\<^sub>f)) \<turnstile> 
                              (((g o more o fst) \<and> ((relation_of P)\<^sup>t\<^sub>f)) \<or>
                           ((\<not>(g o more o fst)) \<and> (\<lambda> (A, A'). tr A' = tr A \<and> wait A')))))"
   apply (unfold Guard_def)
   apply (subst action_of_inverse)
   apply (simp_all only: Guard_is_action)
 done
 
 lemma mono_Guard : "mono (Guard g)"
   apply (auto simp: mono_def less_eq_action ref_def rp_defs design_defs relation_of_Guard 
                 split: cond_splits)
   apply (auto dest: relation_of_spec_f_f relation_of_spec_t_f)
 done
 
 lemma false_Guard: "false `&` P = Stop"
 apply (subst relation_of_inject[symmetric])
 apply (subst relation_of_Stop)
 apply (subst relation_of_Guard)
 apply (simp add: fun_eq_iff utp_defs csp_defs design_defs rp_defs)
 done
 
 lemma false_Guard1: "\<And> a b. g (alpha_rp.more a) = False \<Longrightarrow> 
                                 (relation_of (g `&` P)) (a, b) = (relation_of Stop) (a, b)"
 apply (subst relation_of_Guard)
 apply (subst relation_of_Stop)
 apply (auto simp: fun_eq_iff csp_defs design_defs rp_defs split: cond_splits)
 done
 
 lemma true_Guard: "true `&` P = P"
 apply (subst relation_of_inject[symmetric])
 apply (subst relation_of_Guard)
 apply (subst CSP_is_rd[OF relation_of_CSP]) back back
 apply (simp add: fun_eq_iff utp_defs csp_defs design_defs rp_defs)
 done
 
 lemma true_Guard1: "\<And> a b. g (alpha_rp.more a) = True \<Longrightarrow> 
                                      (relation_of (g `&` P)) (a, b) = (relation_of P) (a, b)"
 apply (subst relation_of_Guard)
 apply (subst CSP_is_rd[OF relation_of_CSP]) back back
 apply (auto simp: fun_eq_iff csp_defs design_defs rp_defs split: cond_splits)
 done
 
 lemma Guard_is_state_update_before: "g `&` P = state_update_before (\<lambda> (s, s') . g s) P"
 apply (subst relation_of_inject[symmetric])
 apply (auto simp: relation_of_Guard relation_of_state_update_before relation_of_Skip rp_defs fun_eq_iff
                   Pre_def update_def design_defs)
 apply (rule_tac b=a in comp_intro)
 apply (split cond_splits, simp_all)+
 apply (subst CSP_is_rd)
 apply (simp_all add: relation_of_CSP rp_defs design_defs fun_eq_iff)
 apply (split cond_splits, simp_all)+
 apply (auto)
 apply (subst (asm) CSP_is_rd)
 apply (simp_all add: relation_of_CSP rp_defs design_defs fun_eq_iff)
 apply (split cond_splits, simp_all)+
 apply (subst (asm) CSP_is_rd)
 apply (simp_all add: relation_of_CSP rp_defs design_defs fun_eq_iff)
 apply (split cond_splits, simp_all)+
 apply (subst CSP_is_rd)
 apply (simp_all add: relation_of_CSP rp_defs design_defs fun_eq_iff)
 apply (split cond_splits, simp_all)+
 apply (subst CSP_is_rd)
 apply (simp_all add: relation_of_CSP rp_defs design_defs fun_eq_iff)
 apply (split cond_splits, simp_all)+
 apply (auto) defer
 apply (split cond_splits, simp_all)+
 apply (subst (asm) CSP_is_rd)
 apply (simp_all add: relation_of_CSP rp_defs design_defs fun_eq_iff)
 apply (split cond_splits, simp_all)+ defer
 apply (rule disjI1) defer
 apply (case_tac "g (alpha_rp.more aa)", simp_all)
 apply (rule)+
 apply (simp add: impl_def) defer
 oops
 
 subsection \<open>Prefixed action\<close>
 
 definition do where
 "do e \<equiv> (\<lambda>(A, A'). tr A = tr A' \<and> (e (more A)) \<notin> (ref A')) \<triangleleft> wait o snd \<triangleright> 
          (\<lambda>(A, A'). tr A' = (tr A @[(e (more A))]))"
 
 definition do_I::"('\<sigma> \<Rightarrow>'\<theta>) \<Rightarrow> '\<theta> set \<Rightarrow> ('\<theta>, '\<sigma>) relation_rp"
 where "do_I c S \<equiv>  ((\<lambda>(A, A'). tr A = tr A' & S \<inter> (ref A') = {})
                                 \<triangleleft> wait o snd \<triangleright> 
   (\<lambda>(A, A'). hd (tr A' - tr A) \<in> S & (c (more A) = (last (tr A')))))"
 
 (*
 definition do_I::"('v \<Rightarrow> '\<theta>) \<Rightarrow> ('v, '\<sigma>) var_list \<Rightarrow> 'v set \<Rightarrow> ('\<theta>, '\<sigma>) relation_rp"
 where "do_I c x P \<equiv>  ((\<lambda>(A, A'). tr A = tr A' \<and> (c`P) \<inter> (ref A') = {})
                                 \<triangleleft> wait o fst \<triangleright> 
   (\<lambda>(A, A'). hd (tr A' - tr A) \<in> (c`P) \<and> (c (select x (more A)) = (last (tr A')))))"
 *)
 
 
 definition
 iPrefix::"('\<sigma> \<Rightarrow>'\<theta>::ev_eq) \<Rightarrow> ('\<sigma> relation) \<Rightarrow> (('\<theta>, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action) \<Rightarrow> ('\<sigma> \<Rightarrow> '\<theta> set) \<Rightarrow> ('\<theta>, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" where
 "iPrefix c i j S P \<equiv> action_of(R(true \<turnstile> (\<lambda> (A, A'). (do_I c (S (more A))) (A, A') & more A' = more A)))`;` P"
 
 definition
 oPrefix::"('\<sigma> \<Rightarrow>'\<theta>) \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" where
 "oPrefix c P \<equiv> action_of(R(true \<turnstile> (do c) \<and> (\<lambda> (A, A'). more A' = more A)))`;` P"
 
 definition Prefix0::"'\<theta> \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" where
 "Prefix0 c P \<equiv> action_of(R(true \<turnstile> (do (\<lambda> _. c)) \<and> (\<lambda> (A, A'). more A' = more A)))`;` P"
 
 definition 
 read::"('v \<Rightarrow> '\<theta>) \<Rightarrow> ('v, '\<sigma>) var_list \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action"
 where  "read c x P  \<equiv> iPrefix (\<lambda> A. c (select x A)) (\<lambda> (s, s'). \<exists> a. s' = increase x a s) (Let x) (\<lambda>_. range c) P"
 
 definition 
 read1::"('v \<Rightarrow> '\<theta>) \<Rightarrow> ('v, '\<sigma>) var_list \<Rightarrow> ('\<sigma> \<Rightarrow> 'v set) \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action"
 where  "read1 c x S P  \<equiv> iPrefix (\<lambda> A. c (select x A)) (\<lambda> (s, s'). \<exists> a. a\<in>(S s) & s' = increase x a s) (Let x) (\<lambda>s. c`(S s)) P"
 
 definition 
 write1::"('v \<Rightarrow> '\<theta>) \<Rightarrow> ('\<sigma> \<Rightarrow> 'v) \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action"
 where "write1 c a P \<equiv> oPrefix (\<lambda> A. c (a A)) P"
 
 definition 
 write0::"'\<theta> \<Rightarrow> ('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> ('\<theta>, '\<sigma>) action" 
 where "write0 c P \<equiv> Prefix0 c P"
 
 syntax
 "_read"  ::"[id, pttrn, ('\<theta>, '\<sigma>) action] => ('\<theta>, '\<sigma>) action" ("(_`?`_ /\<rightarrow> _)")
 "_readS" ::"[id, pttrn, '\<theta> set,('\<theta>, '\<sigma>) action] => ('\<theta>, '\<sigma>) action" ("(_`?`_`:`_ /\<rightarrow> _)")
 "_readSS" ::"[id, pttrn, '\<sigma> => '\<theta> set,('\<theta>, '\<sigma>) action] => ('\<theta>, '\<sigma>) action" ("(_`?`_`\<in>`_ /\<rightarrow> _)")
 "_write" ::"[id, '\<sigma>, ('\<theta>, '\<sigma>) action] => ('\<theta>, '\<sigma>) action" ("(_`!`_ /\<rightarrow> _)")
 "_writeS"::"['\<theta>, ('\<theta>, '\<sigma>) action] => ('\<theta>, '\<sigma>) action" ("(_ /\<rightarrow> _)")
 
 translations
 "_read c p P"    == "CONST read c (VAR_LIST p) P" 
 "_readS c p b P" == "CONST read1 c (VAR_LIST p) (\<lambda>_. b) P"
 "_readSS c p b P" == "CONST read1 c (VAR_LIST p) b P"
 "_write c p P"   == "CONST write1 c p P"
 "_writeS a P"    == "CONST write0 a P"
 
 lemma Prefix_is_action:
 "(R(true \<turnstile> (do c) \<and> (\<lambda> (A, A'). more A' = more A))) \<in> {p. is_CSP_process p}"
 by (auto intro: rd_is_CSP)
 
 lemma Prefix1_is_action:
 "(R(true \<turnstile> \<lambda>(A, A'). do_I c (S (alpha_rp.more A)) (A, A') \<and> alpha_rp.more A' = alpha_rp.more A)) \<in> {p. is_CSP_process p}"
 by (auto intro: rd_is_CSP)
 
 lemma Prefix0_is_action:
 "(R(true \<turnstile> (do c) \<and> (\<lambda> (A, A'). more A' = more A))) \<in> {p. is_CSP_process p}"
 by (auto intro: rd_is_CSP)
 
 lemmas Prefix_is_CSP = Prefix_is_action[simplified]
 
 lemmas Prefix1_is_CSP = Prefix1_is_action[simplified]
 
 lemmas Prefix0_is_CSP = Prefix0_is_action[simplified]
 
 lemma relation_of_iPrefix:
 "relation_of (iPrefix c i j S P) = 
 ((R(true \<turnstile> (\<lambda> (A, A'). (do_I c (S (more A))) (A, A') & more A' = more A)));; relation_of P)"
 by (simp add: iPrefix_def relation_of_Seq action_of_inverse Prefix1_is_CSP)
 
 lemma relation_of_oPrefix:
 "relation_of (oPrefix c P) = 
 ((R(true \<turnstile> (do c) \<and> (\<lambda> (A, A'). more A' = more A)));; relation_of P)"
 by (simp add: oPrefix_def relation_of_Seq action_of_inverse Prefix_is_CSP)
 
 
 lemma relation_of_Prefix0:
 "relation_of (Prefix0 c P) = 
 ((R(true \<turnstile> (do (\<lambda> _. c)) \<and> (\<lambda> (A, A'). more A' = more A)));; relation_of P)"
 by (simp add: Prefix0_def relation_of_Seq action_of_inverse Prefix0_is_CSP)
 
 lemma mono_iPrefix : "mono (iPrefix c i j s)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_iPrefix)
 
 lemma mono_oPrefix : "mono (oPrefix c)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_oPrefix)
 
 lemma mono_Prefix0 : "mono(Prefix0 c)"
 by (auto simp: mono_def less_eq_action ref_def relation_of_Prefix0)
 
 subsection \<open>Hiding\<close>
 
 definition Hide::"('\<theta>::ev_eq, '\<sigma>) action \<Rightarrow> '\<theta> set \<Rightarrow> ('\<theta>, '\<sigma>) action" (infixl "\\" 18) where
 "P \\ cs \<equiv> action_of(R(\<lambda>(S, S'). \<exists> s. (diff_tr S' S) = (tr_filter (s - (tr S)) cs) &
              (relation_of P)(S, S'\<lparr>tr := s, ref := (ref S') \<union> cs \<rparr>));; (relation_of Skip))"
 
 
 definition 
 "hid P cs == (R(\<lambda>(S, S'). \<exists> s. (diff_tr S' S) = (tr_filter (s - (tr S)) cs) & (relation_of P)(S, S'\<lparr>tr := s, ref := (ref S') \<union> cs \<rparr>)) ;; (relation_of Skip))"
 
 lemma hid_is_R: "hid P cs is R healthy"
 apply (simp add: hid_def)
 apply (rule seq_R)
 apply (simp add: Healthy_def R_idem2)
 apply (rule CSP_is_R)
 apply (rule relation_of_CSP)
 done
 
 lemma hid_Skip: "hid P cs = (hid P cs ;; relation_of Skip)"
 by (simp add: hid_def comp_assoc[symmetric] Skip_comp_absorb)
 
 lemma hid_is_CSP1: "hid P cs is CSP1 healthy"
 apply (auto simp: design_defs CSP1_def hid_def rp_defs fun_eq_iff)
 apply (rule_tac b="a" in comp_intro)
 apply (clarsimp split: cond_splits)
 apply (subst CSP_is_rd, auto simp: rp_defs relation_of_CSP design_defs fun_eq_iff split: cond_splits)
 apply (auto simp: diff_tr_def relation_of_Skip rp_defs design_defs true_def split: cond_splits)
 apply (rule_tac x="[]" in exI, auto)
 done
 
 lemma hid_is_CSP2: "hid P cs is CSP2 healthy"
 apply (simp add: hid_def)
 apply (rule seq_CSP2)
 apply (rule CSP_is_CSP2)
 apply (rule relation_of_CSP)
 done
 
 lemma hid_is_CSP: "is_CSP_process (hid P cs)"
 by (auto simp: csp_defs hid_is_CSP1 hid_is_R hid_is_CSP2)
 
 lemma Hide_is_action: 
 "(R(\<lambda>(S, S'). \<exists> s. (diff_tr S' S) = (tr_filter (s - (tr S)) cs) &
    (relation_of P)(S, S'\<lparr>tr := s, ref := (ref S') \<union> cs \<rparr>));; (relation_of Skip)) \<in> {p. is_CSP_process p}"
 by (simp add: hid_is_CSP[simplified hid_def])
 
 lemmas Hide_is_CSP = Hide_is_action[simplified]
 
 lemma relation_of_Hide:
 "relation_of (P \\ cs) = (R(\<lambda>(S, S'). \<exists> s. (diff_tr S' S) = (tr_filter (s - (tr S)) cs)
         & (relation_of P)(S, S'\<lparr>tr :=s, ref := (ref S') \<union> cs \<rparr>));; (relation_of Skip))"
   by (simp add: Hide_def action_of_inverse Hide_is_CSP)
 
 lemma mono_Hide : "mono(\<lambda> P. P \\ cs)"
 by (auto simp: mono_def less_eq_action ref_def prefix_def utp_defs relation_of_Hide rp_defs)
 
 subsection \<open>Recursion\<close>
 
 text \<open>To represent the recursion operator "\<open>\<mu>\<close>" over actions, we use the
 universal least fix-point operator "@{const lfp}" defined in the HOL library for lattices. 
 The operator "@{const lfp}" is inherited from the "Complete Lattice class" under some conditions. 
 All theorems defined over this operator can be reused.\<close>
 
 text \<open>In the @{theory Circus.Circus_Actions} theory, we presented the proof that Circus actions 
 form a complete lattice. The Knaster-Tarski Theorem (in its simplest formulation) states 
 that any monotone function on a complete lattice has a least fixed-point. 
 This is a consequence of the basic boundary properties of the complete lattice operations. 
 Instantiating the complete lattice class allows one to inherit these properties with the 
 definition of the least fixed-point for monotonic functions over Circus actions.
 \<close>
 
 syntax "_MU"::"[idt, idt \<Rightarrow> ('\<theta>, '\<sigma>) action] \<Rightarrow> ('\<theta>, '\<sigma>) action"  ("\<mu> _ \<bullet> _")
 translations "_MU X P" == "CONST lfp (\<lambda> X. P)"
 
 
 (*<*)
 text\<open>Instead fo the following:\<close>
 lemma is_action_REP_Mu:
   shows "is_CSP_process (relation_of (lfp P))"
 oops 
 
 text\<open>... we refer to the proof of @{thm Sup_is_action} and its 
 analogue who capture the essence of this proof at the level of the
 type instantiation.\<close>
 
 text\<open>Monotonicity: STATUS: probably critical.  Does not seem to be necessary for 
 parameterless Circus.\<close>
 lemma mono_Mu:
   assumes A : "mono P"
   and     B : "\<And> X. mono (P X)"
   shows  "mono (lfp P)"
 apply (subst lfp_unfold)
 apply (auto simp: A B)
 done 
 
 term Nat.Suc
 (*>*)
 end
diff --git a/thys/Farkas/Farkas.thy b/thys/Farkas/Farkas.thy
--- a/thys/Farkas/Farkas.thy
+++ b/thys/Farkas/Farkas.thy
@@ -1,1633 +1,1633 @@
 (* Authors: R. Bottesch, M. W. Haslbeck, R. Thiemann *)
 
 section \<open>Farkas Coefficients via the Simplex Algorithm of Duterte and de~Moura\<close>
 
 text \<open>Let $c_1,\dots,c_n$ be a finite list of linear inequalities. 
   Let $C$ be a list of pairs $(r_i,c_i)$ where $r_i$ is a rational number.
   We say that $C$ is a list of \emph{Farkas coefficients} if
   the sum of all products $r_i \cdot c_i$ results in an inequality that is 
   trivially unsatisfiable.
 
   Farkas' Lemma  
   states that a finite set of non-strict linear inequalities is
   unsatisfiable if and only if Farkas coefficients exist. We will prove this lemma
   with the help of the simplex algorithm of Dutertre and de~Moura's.
 
   Note that the simplex implementation works on four layers, and we will formulate and prove 
   a variant of Farkas' Lemma for each of these layers.\<close>
 
 theory Farkas
   imports Simplex.Simplex
 begin
 
 subsection \<open>Linear Inequalities\<close>
 
 text \<open>Both Farkas' Lemma and Motzkin's Transposition Theorem require linear combinations 
   of inequalities. To this end we define one type that permits strict and non-strict 
   inequalities which are always of the form ``polynomial R constant'' where R is either 
   $\leq$ or $<$. On this type we can then define a commutative monoid.\<close>
 
 text \<open>A type for the two relations: less-or-equal and less-than.\<close>
 
 datatype le_rel = Leq_Rel | Lt_Rel
 
 primrec rel_of :: "le_rel \<Rightarrow> 'a :: lrv \<Rightarrow> 'a \<Rightarrow> bool" where 
   "rel_of Leq_Rel = (\<le>)" 
 | "rel_of Lt_Rel = (<)" 
 
 instantiation le_rel :: comm_monoid_add begin
 definition "zero_le_rel = Leq_Rel"
 fun plus_le_rel where 
   "plus_le_rel Leq_Rel Leq_Rel = Leq_Rel" 
 | "plus_le_rel _ _ = Lt_Rel" 
 instance
 proof
   fix a b c :: le_rel
   show "a + b + c = a + (b + c)" by (cases a; cases b; cases c, auto)
   show "a + b = b + a" by (cases a; cases b, auto)
   show "0 + a = a" unfolding zero_le_rel_def by (cases a, auto)
 qed
 end
 
 lemma Leq_Rel_0: "Leq_Rel = 0" unfolding zero_le_rel_def by simp
 
 datatype 'a le_constraint = Le_Constraint (lec_rel: le_rel) (lec_poly: linear_poly) (lec_const: 'a)
 
 abbreviation (input) "Leqc \<equiv> Le_Constraint Leq_Rel" 
 
 instantiation le_constraint :: (lrv) comm_monoid_add begin
 fun plus_le_constraint :: "'a le_constraint \<Rightarrow> 'a le_constraint \<Rightarrow> 'a le_constraint" where
   "plus_le_constraint (Le_Constraint r1 p1 c1) (Le_Constraint r2 p2 c2) = 
     (Le_Constraint (r1 + r2) (p1 + p2) (c1 + c2))"
 
 definition zero_le_constraint :: "'a le_constraint" where
   "zero_le_constraint = Leqc 0 0"
 
 instance proof
   fix a b c :: "'a le_constraint"
   show "0 + a = a"
     by (cases a, auto simp: zero_le_constraint_def Leq_Rel_0)
   show "a + b = b + a" by (cases a; cases b, auto simp: ac_simps)
   show "a + b + c = a + (b + c)" by (cases a; cases b; cases c, auto simp: ac_simps)
 qed
 end 
 
 primrec satisfiable_le_constraint :: "'a::lrv valuation \<Rightarrow> 'a le_constraint \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>l\<^sub>e" 100) where
   "(v \<Turnstile>\<^sub>l\<^sub>e (Le_Constraint rel l r)) \<longleftrightarrow> (rel_of rel (l\<lbrace>v\<rbrace>) r)"
 
 lemma satisfies_zero_le_constraint: "v \<Turnstile>\<^sub>l\<^sub>e 0"
   by (simp add: valuate_zero zero_le_constraint_def)
 
 lemma satisfies_sum_le_constraints:
   assumes "v \<Turnstile>\<^sub>l\<^sub>e c" "v \<Turnstile>\<^sub>l\<^sub>e d"
   shows "v \<Turnstile>\<^sub>l\<^sub>e (c + d)"
 proof -
   obtain lc rc ld rd rel1 rel2 where cd: "c = Le_Constraint rel1 lc rc" "d = Le_Constraint rel2 ld rd" 
     by (cases c; cases d, auto)
   have 1: "rel_of rel1 (lc\<lbrace>v\<rbrace>) rc" using assms cd by auto
   have 2: "rel_of rel2 (ld\<lbrace>v\<rbrace>) rd" using assms cd by auto
   from 1 have le1: "lc\<lbrace>v\<rbrace> \<le> rc" by (cases rel1, auto)
   from 2 have le2: "ld\<lbrace>v\<rbrace> \<le> rd" by (cases rel2, auto)
   from 1 2 le1 le2 have "rel_of (rel1 + rel2) ((lc\<lbrace>v\<rbrace>) + (ld\<lbrace>v\<rbrace>)) (rc + rd)" 
     apply (cases rel1; cases rel2; simp add: add_mono)
     by (metis add.commute le_less_trans order.strict_iff_order plus_less)+
   thus ?thesis by (auto simp: cd valuate_add)
 qed
 
 lemma satisfies_sumlist_le_constraints:
   assumes "\<And> c. c \<in> set (cs :: 'a :: lrv le_constraint list) \<Longrightarrow> v \<Turnstile>\<^sub>l\<^sub>e c"
   shows "v \<Turnstile>\<^sub>l\<^sub>e sum_list cs"
   using assms 
   by (induct cs, auto intro: satisfies_zero_le_constraint satisfies_sum_le_constraints)
 
 lemma sum_list_lec:
   "sum_list ls = Le_Constraint 
     (sum_list (map lec_rel ls)) 
     (sum_list (map lec_poly ls)) 
     (sum_list (map lec_const ls))"
 proof (induct ls)
   case Nil
   show ?case by (auto simp: zero_le_constraint_def Leq_Rel_0) 
 next
   case (Cons l ls)
   show ?case by (cases l, auto simp: Cons)
 qed
 
 lemma sum_list_Leq_Rel: "((\<Sum>x\<leftarrow>C. lec_rel (f x)) = Leq_Rel) \<longleftrightarrow> (\<forall> x \<in> set C. lec_rel (f x) = Leq_Rel)" 
 proof (induct C)
   case (Cons c C)
   show ?case 
   proof (cases "lec_rel (f c)")
     case Leq_Rel
     show ?thesis using Cons by (simp add: Leq_Rel Leq_Rel_0)
   qed simp
 qed (simp add: Leq_Rel_0)
 
 
 subsection \<open>Farkas' Lemma on Layer 4\<close>
 
 text \<open>On layer 4 the algorithm works on a state containing a tableau, atoms (or bounds), 
   an assignment and a satisfiability flag. Only non-strict inequalities appear at this level.
   In order to even state a variant of Farkas' Lemma on layer 4, we 
   need conversions from atoms to non-strict constraints and then further
   to linear inequalities of type @{type le_constraint}. 
   The latter conversion is a partial operation, since non-strict constraints
   of type @{type ns_constraint} permit greater-or-equal constraints, whereas @{type le_constraint}
   allows only less-or-equal.\<close>
 
 text \<open>The advantage of first going via @{type ns_constraint} is that this type permits a multiplication
   with arbitrary rational numbers (the direction of the inequality must be flipped when
   multiplying by a negative number, which is not possible with @{type le_constraint}).\<close>
 
 instantiation ns_constraint :: (scaleRat) scaleRat
 begin
 fun scaleRat_ns_constraint :: "rat \<Rightarrow> 'a ns_constraint \<Rightarrow> 'a ns_constraint" where
   "scaleRat_ns_constraint r (LEQ_ns p c) = 
     (if (r < 0) then GEQ_ns (r *R p) (r *R c) else LEQ_ns (r *R p) (r *R c))"
 | "scaleRat_ns_constraint r (GEQ_ns p c) = 
     (if (r > 0) then GEQ_ns (r *R p) (r *R c) else LEQ_ns (r *R p) (r *R c))"
 
 instance ..
 end
 
 lemma sat_scale_rat_ns: assumes "v \<Turnstile>\<^sub>n\<^sub>s ns"
   shows "v \<Turnstile>\<^sub>n\<^sub>s (f *R ns)"
 proof -
   have "f < 0 | f = 0 | f > 0" by auto
   then show ?thesis using assms by (cases ns, auto simp: valuate_scaleRat scaleRat_leq1 scaleRat_leq2)
 qed
 
 lemma scaleRat_scaleRat_ns_constraint: assumes "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0" 
   shows "a *R (b *R (c :: 'a :: lrv ns_constraint)) = (a * b) *R c" 
 proof - 
   have "b > 0 \<or> b < 0 \<or> b = 0" by linarith
   moreover have "a > 0 \<or> a < 0 \<or> a = 0" by linarith
   ultimately show ?thesis using assms
     by (elim disjE; cases c, auto simp add: not_le not_less
         mult_neg_pos mult_neg_neg mult_nonpos_nonneg mult_nonpos_nonpos mult_nonneg_nonpos mult_pos_neg)
 qed
 
 fun lec_of_nsc where
   "lec_of_nsc (LEQ_ns p c) = (Leqc p c)"
 
 fun is_leq_ns where
   "is_leq_ns (LEQ_ns p c) = True"
 | "is_leq_ns (GEQ_ns p c) = False"
 
 lemma lec_of_nsc: 
   assumes "is_leq_ns c"
   shows "(v \<Turnstile>\<^sub>l\<^sub>e lec_of_nsc c) \<longleftrightarrow> (v \<Turnstile>\<^sub>n\<^sub>s c)"
   using assms by (cases c, auto)
 
 fun nsc_of_atom where
   "nsc_of_atom (Leq var b) = LEQ_ns (lp_monom 1 var) b"
 | "nsc_of_atom (Geq var b) = GEQ_ns (lp_monom 1 var) b"
 
 lemma nsc_of_atom: "v \<Turnstile>\<^sub>n\<^sub>s nsc_of_atom a \<longleftrightarrow> v \<Turnstile>\<^sub>a a"
   by (cases a, auto)
 
 
 text \<open>We say that $C$ is a list of Farkas coefficients \emph{for a given tableau $t$ and atom set $as$}, if
   it is a list of pairs $(r,a)$ such that $a \in as$, $r$ is non-zero, $r \cdot a$ is a
   `less-than-or-equal'-constraint, and the linear combination
   of inequalities must result in an inequality of the form $p \leq c$, where $c < 0$ and $t \models
   p = 0$.\<close>
 
 definition farkas_coefficients_atoms_tableau where 
   "farkas_coefficients_atoms_tableau (as :: 'a :: lrv atom set) t C = (\<exists> p c. 
     (\<forall>(r,a) \<in> set C. a \<in> as \<and> is_leq_ns (r *R nsc_of_atom a) \<and> r \<noteq> 0) \<and>
     (\<Sum>(r,a) \<leftarrow> C. lec_of_nsc (r *R nsc_of_atom a)) = Leqc p c \<and>
     c < 0 \<and>
     (\<forall> v :: 'a valuation. v \<Turnstile>\<^sub>t t \<longrightarrow>(p\<lbrace>v\<rbrace> = 0)))"
 
 text \<open>We first prove that if the check-function detects a conflict, then 
   Farkas coefficients do exist for the tableau and atom set for which the
   conflict is detected.\<close>
 
 definition bound_atoms :: "('i, 'a) state \<Rightarrow> 'a atom set" ("\<B>\<^sub>A") where
   "bound_atoms s = (\<lambda>(v,x). Geq v x) ` (set_of_map (\<B>\<^sub>l s)) \<union> 
                    (\<lambda>(v,x). Leq v x) ` (set_of_map (\<B>\<^sub>u s))"
 
 context PivotUpdateMinVars
 begin
 
 lemma farkas_check: 
   assumes check: "check s' = s" and U: "\<U> s" "\<not> \<U> s'"
     and inv: "\<nabla> s'" "\<triangle> (\<T> s')" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'" "\<diamond> s'" 
     and index: "index_valid as s'" 
   shows "\<exists> C. farkas_coefficients_atoms_tableau (snd ` as) (\<T> s') C"
 proof -
   let ?Q = "\<lambda> s f p c C. set C \<subseteq> \<B>\<^sub>A s \<and>
     distinct C \<and>
     (\<forall>a \<in> set C. is_leq_ns (f (atom_var a) *R nsc_of_atom a) \<and> f (atom_var a) \<noteq> 0) \<and>
     (\<Sum>a \<leftarrow> C. lec_of_nsc (f (atom_var a) *R nsc_of_atom a)) = Leqc p c \<and>
     c < 0 \<and>
     (\<forall> v :: 'a valuation. v \<Turnstile>\<^sub>t \<T> s \<longrightarrow>(p\<lbrace>v\<rbrace> = 0))" 
   let ?P = "\<lambda> s. \<U> s \<longrightarrow> (\<exists> f p c C. ?Q s f p c C)" 
   have "?P (check s')"
   proof (induct rule: check_induct''[OF inv, of ?P])
     case (3 s x\<^sub>i dir I)
     have dir: "dir = Positive \<or> dir = Negative" by fact
     let ?eq = "(eq_for_lvar (\<T> s) x\<^sub>i)"
     define X\<^sub>j where "X\<^sub>j = rvars_eq ?eq"
     define XL\<^sub>j where "XL\<^sub>j = Abstract_Linear_Poly.vars_list (rhs ?eq)"
     have [simp]: "set XL\<^sub>j = X\<^sub>j" unfolding XL\<^sub>j_def X\<^sub>j_def 
       using set_vars_list by blast
     have XL\<^sub>j_distinct: "distinct XL\<^sub>j"
       unfolding XL\<^sub>j_def using distinct_vars_list by simp
     define A where "A = coeff (rhs ?eq)"
     have bounds_id: "\<B>\<^sub>A (set_unsat I s) = \<B>\<^sub>A s" "\<B>\<^sub>u (set_unsat I s) = \<B>\<^sub>u s" "\<B>\<^sub>l (set_unsat I s) = \<B>\<^sub>l s"
       by (auto simp: boundsl_def boundsu_def bound_atoms_def)
     have t_id: "\<T> (set_unsat I s) = \<T> s" by simp
     have u_id: "\<U> (set_unsat I s) = True" by simp
     let ?p = "rhs ?eq - lp_monom 1 x\<^sub>i"
     have p_eval_zero: "?p \<lbrace> v \<rbrace> = 0" if "v \<Turnstile>\<^sub>t \<T> s" for v :: "'a valuation"
     proof -
       have eqT: "?eq \<in> set (\<T> s)" 
         by (simp add: 3(7) eq_for_lvar local.min_lvar_not_in_bounds_lvars)
       have "v \<Turnstile>\<^sub>e ?eq" using that eqT satisfies_tableau_def by blast
       also have "?eq = (lhs ?eq, rhs ?eq)" by (cases ?eq, auto)
       also have "lhs ?eq = x\<^sub>i" by (simp add: 3(7) eq_for_lvar local.min_lvar_not_in_bounds_lvars)
       finally have "v \<Turnstile>\<^sub>e (x\<^sub>i, rhs ?eq)" .
       then show ?thesis by (auto simp: satisfies_eq_iff valuate_minus)
     qed
     have Xj_rvars: "X\<^sub>j \<subseteq> rvars (\<T> s)" unfolding X\<^sub>j_def
       using 3 min_lvar_not_in_bounds_lvars rvars_of_lvar_rvars by blast 
     have xi_lvars: "x\<^sub>i \<in> lvars (\<T> s)" 
       using 3 min_lvar_not_in_bounds_lvars rvars_of_lvar_rvars by blast 
     have "lvars (\<T> s) \<inter> rvars (\<T> s) = {}"
       using 3 normalized_tableau_def by auto
     with xi_lvars Xj_rvars have xi_Xj: "x\<^sub>i \<notin> X\<^sub>j"
       by blast
     have rhs_eval_xi: "(rhs (eq_for_lvar (\<T> s) x\<^sub>i)) \<lbrace>\<langle>\<V> s\<rangle>\<rbrace> = \<langle>\<V> s\<rangle> x\<^sub>i"
     proof -
       have *: "(rhs eq) \<lbrace> v \<rbrace> = v (lhs eq)" if "v \<Turnstile>\<^sub>e eq" for v :: "'a valuation" and eq
         using satisfies_eq_def that by metis
       moreover have "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>e eq_for_lvar (\<T> s) x\<^sub>i"
         using 3 satisfies_tableau_def eq_for_lvar curr_val_satisfies_no_lhs_def xi_lvars
         by blast
       ultimately show ?thesis
         using eq_for_lvar xi_lvars by simp
     qed
     let ?\<B>\<^sub>l = "Direction.LB dir" 
     let ?\<B>\<^sub>u = "Direction.UB dir" 
     let ?lt = "Direction.lt dir" 
     let ?le = "Simplex.le ?lt" 
     let ?Geq = "Direction.GE dir" 
     let ?Leq = "Direction.LE dir" 
 
     have 0: "(if A x < 0 then ?\<B>\<^sub>l s x = Some (\<langle>\<V> s\<rangle> x) else ?\<B>\<^sub>u s x = Some (\<langle>\<V> s\<rangle> x)) \<and> A x \<noteq> 0"
       if x: "x \<in> X\<^sub>j" for x
     proof -
       have "Some (\<langle>\<V> s\<rangle> x) = (?\<B>\<^sub>l s x)" if "A x < 0" 
       proof -
         have cmp: "\<not> \<rhd>\<^sub>l\<^sub>b ?lt (\<langle>\<V> s\<rangle> x) (?\<B>\<^sub>l s x)" 
           using x that dir min_rvar_incdec_eq_None[OF 3(9)] unfolding X\<^sub>j_def A_def by auto
         then obtain c where c: "?\<B>\<^sub>l s x = Some c"
           by (cases "?\<B>\<^sub>l s x", auto simp: bound_compare_defs)
         also have "c = \<langle>\<V> s\<rangle> x"
         proof -
           have "x \<in> rvars (\<T> s)" using that x Xj_rvars by blast
           then have "x \<in> (- lvars (\<T> s))"
             using 3 unfolding normalized_tableau_def by auto
           moreover have "\<forall>x\<in>(- lvars (\<T> s)). in_bounds x \<langle>\<V> s\<rangle> (\<B>\<^sub>l s, \<B>\<^sub>u s)"
             using 3 unfolding curr_val_satisfies_no_lhs_def 
             by (simp add: satisfies_bounds_set.simps)
           ultimately have "in_bounds x \<langle>\<V> s\<rangle> (\<B>\<^sub>l s, \<B>\<^sub>u s)"
             by blast
           moreover have "?le (\<langle>\<V> s\<rangle> x) c"
             using cmp c dir unfolding bound_compare_defs by auto
           ultimately show ?thesis
-            using c dir by auto
+            using c dir by (auto simp del: Simplex.bounds_lg)
         qed
         then show ?thesis
           using c by simp
       qed
       moreover have "Some (\<langle>\<V> s\<rangle> x) = (?\<B>\<^sub>u s x)" if "0 < A x" 
       proof -
         have cmp: "\<not> \<lhd>\<^sub>u\<^sub>b ?lt (\<langle>\<V> s\<rangle> x) (?\<B>\<^sub>u s x)" 
           using x that min_rvar_incdec_eq_None[OF 3(9)] unfolding X\<^sub>j_def A_def by auto
         then obtain c where c: "?\<B>\<^sub>u s x = Some c"
           by (cases "?\<B>\<^sub>u s x", auto simp: bound_compare_defs)
         also have "c = \<langle>\<V> s\<rangle> x"
         proof -
           have "x \<in> rvars (\<T> s)" using that x Xj_rvars by blast
           then have "x \<in> (- lvars (\<T> s))"
             using 3 unfolding normalized_tableau_def by auto
           moreover have "\<forall>x\<in>(- lvars (\<T> s)). in_bounds x \<langle>\<V> s\<rangle> (\<B>\<^sub>l s, \<B>\<^sub>u s)"
             using 3 unfolding curr_val_satisfies_no_lhs_def 
             by (simp add: satisfies_bounds_set.simps)
           ultimately have "in_bounds x \<langle>\<V> s\<rangle> (\<B>\<^sub>l s, \<B>\<^sub>u s)"
             by blast
           moreover have "?le c (\<langle>\<V> s\<rangle> x)"
             using cmp c dir unfolding bound_compare_defs by auto
           ultimately show ?thesis
-            using c dir by auto
+            using c dir by (auto simp del: Simplex.bounds_lg)
         qed
         then show ?thesis
           using c by simp
       qed
       moreover have "A x \<noteq> 0"
         using that coeff_zero unfolding A_def X\<^sub>j_def by auto
       ultimately show ?thesis
         using that by auto
     qed
 
     have l_Ba: "l \<in> \<B>\<^sub>A s" if "l \<in> {?Geq x\<^sub>i (the (?\<B>\<^sub>l s x\<^sub>i))}" for l 
     proof -
       from that have l: "l = ?Geq x\<^sub>i (the (?\<B>\<^sub>l s x\<^sub>i))" by simp
       from 3(8) obtain c where bl': "?\<B>\<^sub>l s x\<^sub>i = Some c" 
         by (cases "?\<B>\<^sub>l s x\<^sub>i", auto simp: bound_compare_defs)
       hence bl: "(x\<^sub>i, c) \<in> set_of_map (?\<B>\<^sub>l s)" unfolding set_of_map_def by auto
       show "l \<in> \<B>\<^sub>A s" unfolding l bound_atoms_def using bl bl' dir by auto
     qed
 
     let ?negA = "filter (\<lambda> x. A x < 0) XL\<^sub>j" 
     let ?posA = "filter (\<lambda> x. \<not> A x < 0) XL\<^sub>j"
 
     define neg where "neg = (if dir = Positive then (\<lambda> x :: rat. x) else uminus)" 
     define negP where "negP = (if dir = Positive then (\<lambda> x :: linear_poly. x) else uminus)" 
     define nega where "nega = (if dir = Positive then (\<lambda> x :: 'a. x) else uminus)" 
     from dir have dirn: "dir = Positive \<and> neg = (\<lambda> x. x) \<and> negP = (\<lambda> x. x) \<and> nega = (\<lambda> x. x)
       \<or> dir = Negative \<and> neg = uminus \<and> negP = uminus \<and> nega = uminus" 
       unfolding neg_def negP_def nega_def by auto
 
     define C where "C = map (\<lambda>x. ?Geq x (the (?\<B>\<^sub>l s x))) ?negA 
                         @ map (\<lambda> x. ?Leq x (the (?\<B>\<^sub>u s x)))  ?posA
                         @ [?Geq x\<^sub>i (the (?\<B>\<^sub>l s x\<^sub>i))]"  
     define f where "f = (\<lambda>x. if x = x\<^sub>i then neg (-1) else neg (A x))"
     define c where "c = (\<Sum>x\<leftarrow>C. lec_const (lec_of_nsc (f (atom_var x) *R nsc_of_atom x)))"
     let ?q = "negP ?p" 
 
     show ?case unfolding bounds_id t_id u_id
     proof (intro exI impI conjI allI)
       show "v \<Turnstile>\<^sub>t \<T> s \<Longrightarrow> ?q \<lbrace> v \<rbrace> = 0" for v :: "'a valuation" using dirn p_eval_zero[of v] 
         by (auto simp: valuate_minus)
 
       show "set C \<subseteq> \<B>\<^sub>A s"
         unfolding C_def set_append set_map set_filter list.simps using 0 l_Ba dir
         by (intro Un_least subsetI) (force simp: bound_atoms_def set_of_map_def)+
 
       show is_leq: "\<forall>a\<in>set C. is_leq_ns (f (atom_var a) *R nsc_of_atom a) \<and> f (atom_var a) \<noteq> 0"
         using dirn xi_Xj 0 unfolding C_def f_def 
         by (elim disjE, auto)
 
       show "(\<Sum>a \<leftarrow> C. lec_of_nsc (f (atom_var a) *R nsc_of_atom a)) = Leqc ?q c"
         unfolding sum_list_lec le_constraint.simps map_map o_def
       proof (intro conjI)
         define scale_poly :: "'a atom \<Rightarrow> linear_poly" where 
           "scale_poly = (\<lambda>x. lec_poly (lec_of_nsc (f (atom_var x) *R nsc_of_atom x)))"
         have "(\<Sum>x\<leftarrow>C. scale_poly x) =
             (\<Sum>x\<leftarrow>?negA. scale_poly (?Geq x (the (?\<B>\<^sub>l s x))))
           + (\<Sum>x\<leftarrow>?posA. scale_poly (?Leq x (the (?\<B>\<^sub>u s x))))
           - negP (lp_monom 1 x\<^sub>i)"
           unfolding C_def using dirn by (auto simp add: comp_def scale_poly_def f_def)
         also have "(\<Sum>x\<leftarrow>?negA. scale_poly (?Geq x (the (?\<B>\<^sub>l s x))))
           =  (\<Sum>x\<leftarrow> ?negA. negP (A x *R lp_monom 1 x))"
           unfolding scale_poly_def f_def using dirn xi_Xj by (subst map_cong) auto
         also have "(\<Sum>x\<leftarrow>?posA. scale_poly (?Leq x (the (?\<B>\<^sub>u s x))))
           =  (\<Sum>x\<leftarrow> ?posA. negP (A x *R lp_monom 1 x))"
           unfolding scale_poly_def f_def using dirn xi_Xj by (subst map_cong) auto
         also have "(\<Sum>x\<leftarrow> ?negA. negP (A x *R lp_monom 1 x)) +
               (\<Sum>x\<leftarrow> ?posA. negP (A x *R lp_monom 1 x))
              = negP (rhs (eq_for_lvar (\<T> s) x\<^sub>i))"
           using dirn XL\<^sub>j_distinct coeff_zero            
           by (elim disjE; intro poly_eqI, auto intro!: poly_eqI simp add: coeff_sum_list A_def X\<^sub>j_def 
               uminus_sum_list_map[unfolded o_def, symmetric])
         finally show "(\<Sum>x\<leftarrow>C. lec_poly (lec_of_nsc (f (atom_var x) *R nsc_of_atom x))) = ?q"
           unfolding scale_poly_def using dirn by auto
         show "(\<Sum>x\<leftarrow>C. lec_rel (lec_of_nsc (f (atom_var x) *R nsc_of_atom x))) = Leq_Rel"  
           unfolding sum_list_Leq_Rel 
         proof
           fix c
           assume c: "c \<in> set C" 
           show "lec_rel (lec_of_nsc (f (atom_var c) *R nsc_of_atom c)) = Leq_Rel" 
             using is_leq[rule_format, OF c] by (cases "f (atom_var c) *R nsc_of_atom c", auto)
         qed
       qed (simp add: c_def)
 
       show "c < 0"
       proof -
         define scale_const_f :: "'a atom \<Rightarrow> 'a" where
           "scale_const_f x = lec_const (lec_of_nsc (f (atom_var x) *R nsc_of_atom x))" for x
         obtain d where bl': "?\<B>\<^sub>l s x\<^sub>i = Some d" 
           using 3 by (cases "?\<B>\<^sub>l s x\<^sub>i", auto simp: bound_compare_defs)
         have "c = (\<Sum>x\<leftarrow>map (\<lambda>x. ?Geq x (the (?\<B>\<^sub>l s x))) ?negA. scale_const_f x)
                      + (\<Sum>x\<leftarrow> map (\<lambda>x. ?Leq x (the (?\<B>\<^sub>u s x))) ?posA. scale_const_f x) 
                    - nega d"
           unfolding c_def C_def f_def scale_const_f_def using dirn rhs_eval_xi bl' by auto
         also have "(\<Sum>x\<leftarrow>map (\<lambda>x. ?Geq x (the (?\<B>\<^sub>l s x))) ?negA. scale_const_f x) =
               (\<Sum>x\<leftarrow> ?negA. nega (A x *R the (?\<B>\<^sub>l s x)))"
           using xi_Xj dirn by (subst map_cong) (auto simp add: f_def scale_const_f_def)
         also have "\<dots> = (\<Sum>x\<leftarrow>?negA. nega (A x *R \<langle>\<V> s\<rangle> x))"
           using 0 by (subst map_cong) auto
         also have "(\<Sum>x\<leftarrow>map (\<lambda>x. ?Leq x (the (?\<B>\<^sub>u s x))) ?posA. scale_const_f x) =
               (\<Sum>x\<leftarrow> ?posA. nega (A x *R the (?\<B>\<^sub>u s x)))"
           using xi_Xj dirn by (subst map_cong) (auto simp add: f_def scale_const_f_def)
         also have "\<dots> = (\<Sum>x\<leftarrow> ?posA. nega (A x *R \<langle>\<V> s\<rangle> x))"
           using 0 by (subst map_cong) auto
         also have "(\<Sum>x\<leftarrow>?negA. nega (A x *R \<langle>\<V> s\<rangle> x)) + (\<Sum>x\<leftarrow>?posA. nega (A x *R \<langle>\<V> s\<rangle> x))
              = (\<Sum>x\<leftarrow>?negA @ ?posA. nega (A x *R \<langle>\<V> s\<rangle> x))"
           by auto
         also have "\<dots> = (\<Sum>x\<in> X\<^sub>j. nega (A x *R \<langle>\<V> s\<rangle> x))"
           using XL\<^sub>j_distinct by (subst sum_list_distinct_conv_sum_set) (auto intro!: sum.cong)
         also have "\<dots> = nega (\<Sum>x\<in> X\<^sub>j. (A x *R \<langle>\<V> s\<rangle> x))" using dirn by (auto simp: sum_negf) 
         also have "(\<Sum>x\<in> X\<^sub>j. (A x *R \<langle>\<V> s\<rangle> x)) = ((rhs ?eq) \<lbrace>\<langle>\<V> s\<rangle>\<rbrace>)"
           unfolding A_def X\<^sub>j_def by (subst linear_poly_sum) (auto simp add: sum_negf)
         also have "\<dots> = \<langle>\<V> s\<rangle> x\<^sub>i"
           using rhs_eval_xi by blast
         also have "nega (\<langle>\<V> s\<rangle> x\<^sub>i) - nega d < 0"
         proof -
           have "?lt (\<langle>\<V> s\<rangle> x\<^sub>i) d" 
             using dirn 3(2-) bl' by (elim disjE, auto simp: bound_compare_defs)   
           thus ?thesis using dirn unfolding minus_lt[symmetric] by auto
         qed
         finally show ?thesis .
       qed
 
       show "distinct C"
         unfolding C_def using XL\<^sub>j_distinct xi_Xj dirn by (auto simp add: inj_on_def distinct_map)
     qed
   qed (insert U, blast+)
   then obtain f p c C where Qs: "?Q s f p c C" using U unfolding check by blast
   from index[folded check_tableau_index_valid[OF U(2) inv(3,4,2,1)]] check 
   have index: "index_valid as s" by auto
   from check_tableau_equiv[OF U(2) inv(3,4,2,1), unfolded check]
   have id: "v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> s'" for v :: "'a valuation" by auto
   let ?C = "map (\<lambda> a. (f (atom_var a), a)) C"
   have "set C \<subseteq> \<B>\<^sub>A s" using Qs by blast
   also have "\<dots> \<subseteq> snd ` as" using index 
     unfolding bound_atoms_def index_valid_def set_of_map_def boundsl_def boundsu_def o_def by force
   finally have sub: "snd ` set ?C \<subseteq> snd ` as" by force
   show ?thesis unfolding farkas_coefficients_atoms_tableau_def
     by (intro exI[of _ p] exI[of _ c] exI[of _ ?C] conjI,
         insert Qs[unfolded id] sub, (force simp: o_def)+)
 qed
 
 end
 
 text \<open>Next, we show that a conflict found by the assert-bound function also gives rise to
   Farkas coefficients.\<close>
 
 context Update
 begin
 
 lemma farkas_assert_bound: assumes inv: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
   and index: "index_valid as s" 
   and U: "\<U> (assert_bound ia s)" 
 shows "\<exists> C. farkas_coefficients_atoms_tableau (snd ` (insert ia as)) (\<T> s) C"
 proof -
   obtain i a where ia[simp]: "ia = (i,a)" by force
   let ?A = "snd ` insert ia as" 
   have "\<exists> x c d. Leq x c \<in> ?A \<and> Geq x d \<in> ?A \<and> c < d" 
   proof (cases a)
     case (Geq x d)
     let ?s = "update\<B>\<I> (Direction.UBI_upd (Direction (\<lambda>x y. y < x) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<I>\<^sub>u \<I>\<^sub>l \<B>\<^sub>i\<^sub>l_update Geq Leq (\<le>)))
                         i x d s" 
     have id: "\<U> ?s = \<U> s" by auto
     have norm: "\<triangle> (\<T> ?s)" using inv by auto
     have val: "\<nabla> ?s" using inv(4) unfolding tableau_valuated_def by simp
     have idd: "x \<notin> lvars (\<T> ?s) \<Longrightarrow> \<U> (update x d ?s) = \<U> ?s"
       by (rule update_unsat_id[OF norm val])
     from U[unfolded ia Geq] inv(1) id idd 
     have "\<lhd>\<^sub>l\<^sub>b (\<lambda>x y. y < x) d (\<B>\<^sub>u s x)" by (auto split: if_splits simp: Let_def)
     then obtain c where Bu: "\<B>\<^sub>u s x = Some c" and lt: "c < d" 
       by (cases "\<B>\<^sub>u s x", auto simp: bound_compare_defs)
     from Bu obtain j where "Mapping.lookup (\<B>\<^sub>i\<^sub>u s) x = Some (j,c)"  
       unfolding boundsu_def by auto
     with index[unfolded index_valid_def] have "(j, Leq x c) \<in> as" by auto
     hence xc: "Leq x c \<in> ?A" by force
     have xd: "Geq x d \<in> ?A" unfolding ia Geq by force
     from xc xd lt show ?thesis by auto
   next
     case (Leq x c)
     let ?s = "update\<B>\<I> (Direction.UBI_upd (Direction (<) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<I>\<^sub>l \<I>\<^sub>u \<B>\<^sub>i\<^sub>u_update Leq Geq (\<ge>))) i x c s" 
     have id: "\<U> ?s = \<U> s" by auto
     have norm: "\<triangle> (\<T> ?s)" using inv by auto
     have val: "\<nabla> ?s" using inv(4) unfolding tableau_valuated_def by simp
     have idd: "x \<notin> lvars (\<T> ?s) \<Longrightarrow> \<U> (update x c ?s) = \<U> ?s"
       by (rule update_unsat_id[OF norm val])
     from U[unfolded ia Leq] inv(1) id idd 
     have "\<lhd>\<^sub>l\<^sub>b (<) c (\<B>\<^sub>l s x)" by (auto split: if_splits simp: Let_def)
     then obtain d where Bl: "\<B>\<^sub>l s x = Some d" and lt: "c < d" 
       by (cases "\<B>\<^sub>l s x", auto simp: bound_compare_defs)
     from Bl obtain j where "Mapping.lookup (\<B>\<^sub>i\<^sub>l s) x = Some (j,d)"  
       unfolding boundsl_def by auto
     with index[unfolded index_valid_def] have "(j, Geq x d) \<in> as" by auto
     hence xd: "Geq x d \<in> ?A" by force
     have xc: "Leq x c \<in> ?A" unfolding ia Leq by force
     from xc xd lt show ?thesis by auto
   qed
   then obtain x c d where c: "Leq x c \<in> ?A" and d: "Geq x d \<in> ?A" and cd: "c < d" by blast
   show ?thesis unfolding farkas_coefficients_atoms_tableau_def
   proof (intro exI conjI allI)
     let ?C = "[(-1, Geq x d), (1,Leq x c)]" 
     show "\<forall>(r,a)\<in>set ?C. a \<in> ?A \<and> is_leq_ns (r *R nsc_of_atom a) \<and> r \<noteq> 0" using c d by auto
     show "c - d < 0" using cd using minus_lt by auto
   qed (auto simp: valuate_zero)
 qed
 end
 
 
 text \<open>Moreover, we prove that all other steps of the simplex algorithm on layer~4, such as pivoting,
   asserting bounds without conflict, etc., preserve Farkas coefficients.\<close>
 
 lemma farkas_coefficients_atoms_tableau_mono: assumes "as \<subseteq> bs" 
   shows "farkas_coefficients_atoms_tableau as t C \<Longrightarrow> farkas_coefficients_atoms_tableau bs t C" 
   using assms unfolding farkas_coefficients_atoms_tableau_def by force
 
 locale AssertAllState''' = AssertAllState'' init ass_bnd chk + Update update + 
   PivotUpdateMinVars eq_idx_for_lvar min_lvar_not_in_bounds min_rvar_incdec_eq pivot_and_update
   for init and ass_bnd :: "'i \<times> 'a :: lrv atom \<Rightarrow> _" and chk :: "('i, 'a) state \<Rightarrow> ('i, 'a) state" and update :: "nat \<Rightarrow> 'a :: lrv \<Rightarrow> ('i, 'a) state \<Rightarrow> ('i, 'a) state" 
     and eq_idx_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> nat" and
     min_lvar_not_in_bounds :: "('i,'a::lrv) state \<Rightarrow> var option" and
     min_rvar_incdec_eq :: "('i,'a) Direction \<Rightarrow> ('i,'a) state \<Rightarrow> eq \<Rightarrow> 'i list + var" and
     pivot_and_update :: "var \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
     + assumes ass_bnd: "ass_bnd = Update.assert_bound update" and
     chk: "chk = PivotUpdateMinVars.check eq_idx_for_lvar min_lvar_not_in_bounds min_rvar_incdec_eq pivot_and_update"
 
 context AssertAllState'''
 begin
 
 lemma farkas_assert_bound_loop: assumes "\<U> (assert_bound_loop as (init t))" 
   and norm: "\<triangle> t" 
 shows "\<exists> C. farkas_coefficients_atoms_tableau (snd ` set as) t C" 
 proof -
   let ?P = "\<lambda> as s. \<U> s \<longrightarrow> (\<exists> C. farkas_coefficients_atoms_tableau (snd ` as) (\<T> s) C)" 
   let ?s = "assert_bound_loop as (init t)" 
   have "\<not> \<U> (init t)" by (rule init_unsat_flag)
   have "\<T> (assert_bound_loop as (init t)) = t \<and> 
     (\<U> (assert_bound_loop as (init t)) \<longrightarrow> (\<exists> C. farkas_coefficients_atoms_tableau (snd ` set as) (\<T> (init t)) C))" 
   proof (rule AssertAllState''Induct[OF norm], unfold ass_bnd, goal_cases)
     case 1
     have "\<not> \<U> (init t)" by (rule init_unsat_flag)
     moreover have "\<T> (init t) = t" by (rule init_tableau_id)
     ultimately show ?case by auto
   next
     case (2 as bs s)
     hence "snd ` as \<subseteq> snd ` bs" by auto
     from farkas_coefficients_atoms_tableau_mono[OF this] 2(2) show ?case by auto
   next
     case (3 s a ats)
     let ?s = "assert_bound a s" 
     have tab: "\<T> ?s = \<T> s" unfolding ass_bnd by (rule assert_bound_nolhs_tableau_id, insert 3, auto)
     have t: "t = \<T> s" using 3 by simp
     show ?case unfolding t tab
     proof (intro conjI impI refl)
       assume "\<U> ?s"
       from farkas_assert_bound[OF 3(1,3-6,8) this]
       show "\<exists> C. farkas_coefficients_atoms_tableau (snd ` insert a (set ats)) (\<T> (init (\<T> s))) C" 
         unfolding t[symmetric] init_tableau_id .
     qed
   qed
   thus ?thesis unfolding init_tableau_id using assms by blast
 qed
 
 text \<open>Now we get to the main result for layer~4: If the main algorithm returns unsat,
   then there are Farkas coefficients for the tableau and atom set that were given as
   input for this layer.\<close>
 
 lemma farkas_assert_all_state: assumes U: "\<U> (assert_all_state t as)" 
   and norm: "\<triangle> t" 
 shows "\<exists> C. farkas_coefficients_atoms_tableau (snd ` set as) t C" 
 proof -
   let ?s = "assert_bound_loop as (init t)" 
   show ?thesis
   proof (cases "\<U> (assert_bound_loop as (init t))")
     case True
     from farkas_assert_bound_loop[OF this norm]
     show ?thesis by auto
   next
     case False
     from AssertAllState''_tableau_id[OF norm]
     have T: "\<T> ?s = t" unfolding init_tableau_id .
     from U have U: "\<U> (check ?s)" unfolding chk[symmetric] by simp
     show ?thesis
     proof (rule farkas_check[OF refl U False, unfolded T, OF _ norm])
       from AssertAllState''_precond[OF norm, unfolded Let_def] False
       show "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s" "\<diamond> ?s" "\<nabla> ?s" by blast+
       from AssertAllState''_index_valid[OF norm]
       show "index_valid (set as) ?s" .
     qed
   qed
 qed
 
 subsection \<open>Farkas' Lemma on Layer 3\<close>
 
 text \<open>There is only a small difference between layers 3 and 4, namely that there is no 
   simplex algorithm (@{const assert_all_state}) on layer 3, but just a tableau and atoms.\<close>
 
 text \<open>Hence, one task is to link the unsatisfiability flag 
   on layer 4 with unsatisfiability of the original tableau and atoms (layer 3). This can
   be done via the existing soundness results of the simplex algorithm.
   Moreover, we give an easy proof that the existence of Farkas coefficients for a tableau and 
   set of atoms implies unsatisfiability.\<close>
 
 end
 
 lemma farkas_coefficients_atoms_tableau_unsat: 
   assumes "farkas_coefficients_atoms_tableau as t C" 
   shows "\<nexists> v. v \<Turnstile>\<^sub>t t \<and> v \<Turnstile>\<^sub>a\<^sub>s as"
 proof
   assume "\<exists> v. v \<Turnstile>\<^sub>t t \<and> v \<Turnstile>\<^sub>a\<^sub>s as"  
   then obtain v where *: "v \<Turnstile>\<^sub>t t \<and> v \<Turnstile>\<^sub>a\<^sub>s as" by auto
   then obtain p c where isleq: "(\<forall>(r,a) \<in> set C. a \<in> as \<and> is_leq_ns (r *R nsc_of_atom a) \<and> r \<noteq> 0)"
     and leq: "(\<Sum>(r,a) \<leftarrow> C. lec_of_nsc (r *R nsc_of_atom a)) = Leqc p c" 
     and cltz: "c < 0"
     and p0: "p\<lbrace>v\<rbrace> = 0"
     using assms farkas_coefficients_atoms_tableau_def by blast 
   have fa: "\<forall>(r,a) \<in> set C. v \<Turnstile>\<^sub>a a" using * isleq leq
       satisfies_atom_set_def by force
   {
     fix r a
     assume a: "(r,a) \<in> set C" 
     from a fa have va: "v \<Turnstile>\<^sub>a a" unfolding satisfies_atom_set_def by auto 
     hence v: "v \<Turnstile>\<^sub>n\<^sub>s (r *R nsc_of_atom a)" by (auto simp: nsc_of_atom sat_scale_rat_ns)
     from a isleq have "is_leq_ns (r *R nsc_of_atom a)" by auto
     from lec_of_nsc[OF this] v have "v \<Turnstile>\<^sub>l\<^sub>e lec_of_nsc (r *R nsc_of_atom a)" by blast
   } note v = this
   have "v \<Turnstile>\<^sub>l\<^sub>e Leqc p c" unfolding leq[symmetric]
     by (rule satisfies_sumlist_le_constraints, insert v, auto)
   then have "0 \<le> c" using p0 by auto
   then show False using cltz by auto
 qed
 
 text \<open>Next is the main result for layer~3: a tableau and a finite set of atoms are unsatisfiable
   if and only if there is a list of Farkas coefficients for the set of atoms and the tableau.\<close>
 
 lemma farkas_coefficients_atoms_tableau: assumes norm: "\<triangle> t"
   and fin: "finite as"
 shows "(\<exists> C. farkas_coefficients_atoms_tableau as t C) \<longleftrightarrow> (\<nexists> v. v \<Turnstile>\<^sub>t t \<and> v \<Turnstile>\<^sub>a\<^sub>s as)"
 proof 
   from finite_list[OF fin] obtain bs where as: "as = set bs" by auto
   assume unsat: "\<nexists> v. v \<Turnstile>\<^sub>t t \<and> v \<Turnstile>\<^sub>a\<^sub>s as" 
   let ?as = "map (\<lambda> x. ((),x)) bs" 
   interpret AssertAllState''' init_state assert_bound_code check_code update_code
     eq_idx_for_lvar min_lvar_not_in_bounds min_rvar_incdec_eq pivot_and_update_code
     by (unfold_locales, auto simp: assert_bound_code_def check_code_def)
   let ?call = "assert_all t ?as" 
   have id: "snd ` set ?as = as" unfolding as by force
   from assert_all_sat[OF norm, of ?as, unfolded id] unsat
   obtain I where "?call = Inl I" by (cases ?call, auto)
   from this[unfolded assert_all_def Let_def]
   have "\<U> (assert_all_state_code t ?as)" 
     by (auto split: if_splits simp: assert_all_state_code_def)
   from farkas_assert_all_state[OF this[unfolded assert_all_state_code_def] norm, unfolded id]
   show "\<exists> C. farkas_coefficients_atoms_tableau as t C" .
 qed (insert farkas_coefficients_atoms_tableau_unsat, auto)
 
 
 
 subsection \<open>Farkas' Lemma on Layer 2\<close>
 
 text \<open>The main difference between layers 2 and 3 is the introduction of slack-variables in layer 3
   via the preprocess-function. Our task here is to show that Farkas coefficients at layer 3 (where 
   slack-variables are used) can be converted into Farkas coefficients for layer 2 (before the
   preprocessing).\<close>
 
 
 text \<open>We also need to adapt the previos notion of Farkas coefficients, which was used in 
   @{const farkas_coefficients_atoms_tableau}, for layer~2. At layer 3, Farkas coefficients
   are the coefficients in a linear combination of atoms that evaluates to an inequality of
   the form $p \leq c$, where $p$ is a linear polynomial, $c < 0$, and $t \models p = 0$ holds.
   At layer 2, the atoms are replaced by non-strict constraints where the left-hand side is a
   polynomial in the original variables, but the corresponding linear combination (with Farkas
   coefficients) evaluates directly to the inequality $0 \leq c$, with $c < 0$. The implication
   $t \models p = 0$ is no longer possible in this layer, since there is no tableau $t$, nor is it
   needed, since $p$ is $0$. Thus, the statement defining Farkas coefficients must be changed
   accordingly.\<close>
 
 definition farkas_coefficients_ns where 
   "farkas_coefficients_ns ns C = (\<exists> c.
     (\<forall>(r, n) \<in> set C. n \<in> ns \<and> is_leq_ns (r *R n) \<and> r \<noteq> 0) \<and>
     (\<Sum>(r, n) \<leftarrow> C. lec_of_nsc (r *R n)) = Leqc 0 c \<and>
     c < 0)"
 
 text \<open>The easy part is to prove that Farkas coefficients imply unsatisfiability.\<close>
 
 lemma farkas_coefficients_ns_unsat: 
   assumes "farkas_coefficients_ns ns C" 
   shows "\<nexists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ns" 
 proof
   assume "\<exists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ns"
   then obtain v where *: "v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ns" by auto
   obtain c where
     isleq: "(\<forall>(a,n) \<in> set C. n \<in> ns \<and> is_leq_ns (a *R n) \<and> a \<noteq> 0)" and
     leq: "(\<Sum>(a,n) \<leftarrow> C. lec_of_nsc (a *R n)) = Leqc 0 c" and
     cltz: "c < 0" using assms farkas_coefficients_ns_def by blast
   {
     fix a n
     assume n: "(a,n) \<in> set C" 
     from n * isleq have "v \<Turnstile>\<^sub>n\<^sub>s n" by auto
     hence v: "v \<Turnstile>\<^sub>n\<^sub>s (a *R n)" by (rule sat_scale_rat_ns)
     from n isleq have "is_leq_ns (a *R n)" by auto
     from lec_of_nsc[OF this] v 
     have "v \<Turnstile>\<^sub>l\<^sub>e lec_of_nsc (a *R n)" by blast
   } note v = this
   have "v \<Turnstile>\<^sub>l\<^sub>e Leqc 0 c" unfolding leq[symmetric]
     by (rule satisfies_sumlist_le_constraints, insert v, auto)
   then show False using cltz
     by (metis leD satisfiable_le_constraint.simps valuate_zero rel_of.simps(1))
 qed
 
 text \<open>In order to eliminate the need for a tableau, we require the notion of an arbitrary substitution
   on polynomials, where all variables can be replaced at once. The existing simplex formalization 
   provides only a function to replace one variable at a time.\<close>
 
 definition subst_poly :: "(var \<Rightarrow> linear_poly) \<Rightarrow> linear_poly \<Rightarrow> linear_poly" where
   "subst_poly \<sigma> p = (\<Sum> x \<in> vars p. coeff p x *R \<sigma> x)"
 
 lemma subst_poly_0[simp]: "subst_poly \<sigma> 0 = 0" unfolding subst_poly_def by simp
 
 lemma valuate_subst_poly: "(subst_poly \<sigma> p) \<lbrace> v \<rbrace> = (p \<lbrace> (\<lambda> x. ((\<sigma> x) \<lbrace> v \<rbrace>)) \<rbrace>)"
   by (subst (2) linear_poly_sum, unfold subst_poly_def valuate_sum valuate_scaleRat, simp)
 
 lemma subst_poly_add: "subst_poly \<sigma> (p + q) = subst_poly \<sigma> p + subst_poly \<sigma> q"
   by (rule linear_poly_eqI, unfold valuate_add valuate_subst_poly, simp)
 
 fun subst_poly_lec :: "(var \<Rightarrow> linear_poly) \<Rightarrow> 'a le_constraint \<Rightarrow> 'a le_constraint" where
   "subst_poly_lec \<sigma> (Le_Constraint rel p c) = Le_Constraint rel (subst_poly \<sigma> p) c" 
 
 lemma subst_poly_lec_0[simp]: "subst_poly_lec \<sigma> 0 = 0" unfolding zero_le_constraint_def by simp
 
 lemma subst_poly_lec_add: "subst_poly_lec \<sigma> (c1 + c2) = subst_poly_lec \<sigma> c1 + subst_poly_lec \<sigma> c2" 
   by (cases c1; cases c2, auto simp: subst_poly_add)
 
 lemma subst_poly_lec_sum_list: "subst_poly_lec \<sigma> (sum_list ps) = sum_list (map (subst_poly_lec \<sigma>) ps)" 
   by (induct ps, auto simp: subst_poly_lec_add)
 
 lemma subst_poly_lp_monom[simp]: "subst_poly \<sigma> (lp_monom r x) = r *R \<sigma> x"
   unfolding subst_poly_def by (simp add: vars_lp_monom)
 
 lemma subst_poly_scaleRat: "subst_poly \<sigma> (r *R p) = r *R (subst_poly \<sigma> p)"
   by (rule linear_poly_eqI, unfold valuate_scaleRat valuate_subst_poly, simp)
 
 text \<open>We need several auxiliary properties of the preprocess-function which are not present
   in the simplex formalization.\<close>
 
 lemma Tableau_is_monom_preprocess':
   assumes "(x, p) \<in> set (Tableau (preprocess' cs start))"
   shows "\<not> is_monom p"
   using assms 
   by(induction cs start rule: preprocess'.induct)
     (auto simp add: Let_def split: if_splits option.splits)
 
 lemma preprocess'_atoms_to_constraints': assumes "preprocess' cs start = S" 
   shows "set (Atoms S) \<subseteq> {(i,qdelta_constraint_to_atom c v) | i c v. (i,c) \<in> set cs \<and> 
      (\<not> is_monom (poly c) \<longrightarrow> Poly_Mapping S (poly c) = Some v)}"
   unfolding assms(1)[symmetric]
   by (induct cs start rule: preprocess'.induct, auto simp: Let_def split: option.splits, force+) 
 
 lemma monom_of_atom_coeff:
   assumes "is_monom (poly ns)" "a = qdelta_constraint_to_atom ns v"
   shows "(monom_coeff (poly ns)) *R nsc_of_atom a = ns"
   using assms is_monom_monom_coeff_not_zero 
   by(cases a; cases ns)
     (auto split: atom.split ns_constraint.split simp add: monom_poly_assemble field_simps)
 
 text \<open>The next lemma provides the functionality that is required to convert an
   atom back to a non-strict constraint, i.e., it is a kind of inverse of the preprocess-function.\<close>
 
 lemma preprocess'_atoms_to_constraints: assumes S: "preprocess' cs start = S" 
   and start: "start = start_fresh_variable cs" 
   and ns: "ns = (case a of Leq v c \<Rightarrow> LEQ_ns q c | Geq v c \<Rightarrow> GEQ_ns q c)" 
   and "a \<in> snd ` set (Atoms S)" 
 shows "(atom_var a \<notin> fst ` set (Tableau S) \<longrightarrow> (\<exists> r. r \<noteq> 0 \<and> r *R nsc_of_atom a \<in> snd ` set cs))
     \<and>  ((atom_var a, q) \<in> set (Tableau S) \<longrightarrow> ns \<in> snd ` set cs)" 
 proof -
   let ?S = "preprocess' cs start" 
   from assms(4) obtain i where ia: "(i,a) \<in> set (Atoms S)" by auto
   with preprocess'_atoms_to_constraints'[OF assms(1)] obtain c v 
     where a: "a = qdelta_constraint_to_atom c v" and c: "(i,c) \<in> set cs" 
       and nmonom: "\<not> is_monom (poly c) \<Longrightarrow> Poly_Mapping S (poly c) = Some v" by blast
   hence c': "c \<in> snd ` set cs" by force
   let ?p = "poly c" 
   show ?thesis
   proof (cases "is_monom ?p")
     case True
     hence av: "atom_var a = monom_var ?p" unfolding a by (cases c, auto)
     from Tableau_is_monom_preprocess'[of _ ?p cs start] True 
     have "(x, ?p) \<notin> set (Tableau ?S)" for x by blast
     {
       assume "(atom_var a, q) \<in> set (Tableau S)" 
       hence "(monom_var ?p, q) \<in> set (Tableau S)" unfolding av by simp
       hence "monom_var ?p \<in> lvars (Tableau S)" unfolding lvars_def by force
       from lvars_tableau_ge_start[rule_format, OF this[folded S]]
       have "monom_var ?p \<ge> start" unfolding S .
       moreover have "monom_var ?p \<in> vars_constraints (map snd cs)" using True c
         by (auto intro!: bexI[of _ "(i,c)"] simp: monom_var_in_vars)
       ultimately have False using start_fresh_variable_fresh[of cs, folded start] by force
     } 
     moreover 
     from monom_of_atom_coeff[OF True a] True
     have "\<exists>r. r \<noteq> 0 \<and> r *R nsc_of_atom a = c" 
       by (intro exI[of _ "monom_coeff ?p"], auto, cases a, auto)
     ultimately show ?thesis using c' by auto
   next
     case False
     hence av: "atom_var a = v" unfolding a by (cases c, auto)
     from nmonom[OF False] have "Poly_Mapping S ?p = Some v" .
     from preprocess'_Tableau_Poly_Mapping_Some[OF this[folded S]]
     have tab: "(atom_var a, ?p) \<in> set (Tableau (preprocess' cs start))" unfolding av by simp
     hence "atom_var a \<in> fst ` set (Tableau S)" unfolding S by force
     moreover
     {
       assume "(atom_var a, q) \<in> set (Tableau S)"
       from tab this have qp: "q = ?p" unfolding S using lvars_distinct[of cs start, unfolded S lhs_def]
         by (simp add: case_prod_beta' eq_key_imp_eq_value)
       have "ns = c" unfolding ns qp using av a False by (cases c, auto)
       hence "ns \<in> snd ` set cs" using c' by blast
     }
     ultimately show ?thesis by blast
   qed
 qed
 
 text \<open>Next follows the major technical lemma of this part, 
   namely that Farkas coefficients on layer~3 for preprocessed constraints can
   be converted into Farkas coefficients on layer~2.\<close>
 
 lemma farkas_coefficients_preprocess': 
   assumes pp: "preprocess' cs (start_fresh_variable cs) = S" and
     ft: "farkas_coefficients_atoms_tableau (snd ` set (Atoms S)) (Tableau S) C"
   shows "\<exists> C. farkas_coefficients_ns (snd ` set cs) C"
 proof -
   note ft[unfolded farkas_coefficients_atoms_tableau_def]
   obtain p c where 0: "\<forall> (r,a) \<in> set C. a \<in> snd ` set (Atoms S) \<and> is_leq_ns (r *R nsc_of_atom a) \<and> r \<noteq> 0"
     "(\<Sum>(r,a)\<leftarrow>C. lec_of_nsc (r *R nsc_of_atom a)) = Leqc p c"
     "c < 0"
     "\<And>v :: QDelta valuation. v \<Turnstile>\<^sub>t Tableau S \<Longrightarrow> p \<lbrace> v \<rbrace> = 0"
     using ft unfolding farkas_coefficients_atoms_tableau_def by blast
   note 0 = 0(1)[rule_format, of "(a, b)" for a b, unfolded split] 0(2-)
   let ?T = "Tableau S"
   define \<sigma> :: "var \<Rightarrow> linear_poly" where "\<sigma> = (\<lambda> x. case map_of ?T x of Some p \<Rightarrow> p | None \<Rightarrow> lp_monom 1 x)"
   let ?P = "(\<lambda>r a s ns. ns \<in> (snd ` set cs) \<and> is_leq_ns (s *R ns) \<and> s \<noteq> 0 \<and>
       subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a)) = lec_of_nsc (s *R ns))"
   have "\<exists>s ns. ?P r a s ns" if ra: "(r,a) \<in> set C" for r a
   proof -
     have a: "a \<in> snd ` set (Atoms S)"
       using ra 0 by force
     from 0 ra have is_leq: "is_leq_ns (r *R nsc_of_atom a)" and r0: "r \<noteq> 0" by auto
     let ?x = "atom_var a" 
     show ?thesis
     proof (cases "map_of ?T ?x")
       case (Some q)
       hence \<sigma>: "\<sigma> ?x = q" unfolding \<sigma>_def by auto
       from Some have xqT: "(?x, q) \<in> set ?T" by (rule map_of_SomeD)
       define ns where "ns = (case a of Leq v c \<Rightarrow> LEQ_ns q c
                                      | Geq v c \<Rightarrow> GEQ_ns q c)"
       from preprocess'_atoms_to_constraints[OF pp refl ns_def a] xqT
       have ns_mem: "ns \<in> snd ` set cs" by blast
       have id: "subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a))
                = lec_of_nsc (r *R ns)" using is_leq \<sigma>
         by (cases a, auto simp: ns_def subst_poly_scaleRat)
       from id is_leq \<sigma> have is_leq: "is_leq_ns (r *R ns)" by (cases a, auto simp: ns_def)  
       show ?thesis by (intro exI[of _ r] exI[of _ ns] conjI ns_mem id is_leq conjI r0)
     next
       case None
       hence "?x \<notin> fst ` set ?T" by (meson map_of_eq_None_iff)
       from preprocess'_atoms_to_constraints[OF pp refl refl a] this
       obtain rr where rr: "rr *R nsc_of_atom a \<in> (snd ` set cs)" and rr0: "rr \<noteq> 0" 
         by blast
       from None have \<sigma>: "\<sigma> ?x = lp_monom 1 ?x" unfolding \<sigma>_def by simp
       define ns where "ns = rr *R nsc_of_atom a"
       define s where "s = r / rr"
       from rr0 r0 have s0: "s \<noteq> 0" unfolding s_def by auto
       from is_leq \<sigma>
       have "subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a)) 
         = lec_of_nsc (r *R nsc_of_atom a)"
         by (cases a, auto simp: subst_poly_scaleRat)
       moreover have "r *R nsc_of_atom a = s *R ns" unfolding ns_def s_def
           scaleRat_scaleRat_ns_constraint[OF rr0] using rr0 by simp
       ultimately have "subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a))
             = lec_of_nsc (s *R ns)" "is_leq_ns (s *R ns)" using is_leq by auto
       then show ?thesis
         unfolding ns_def using rr s0 by blast
     qed
   qed
   hence "\<forall> ra. \<exists> s ns. (fst ra, snd ra) \<in> set C \<longrightarrow> ?P (fst ra) (snd ra) s ns" by blast
   from choice[OF this] obtain s where s: "\<forall> ra. \<exists> ns. (fst ra, snd ra) \<in> set C \<longrightarrow> ?P (fst ra) (snd ra) (s ra) ns" by blast
   from choice[OF this] obtain ns where ns: "\<And> r a. (r,a) \<in> set C \<Longrightarrow> ?P r a (s (r,a)) (ns (r,a))" by force
   define NC where "NC = map (\<lambda>(r,a). (s (r,a), ns (r,a))) C"
   have "(\<Sum>(s, ns)\<leftarrow>map (\<lambda>(r,a). (s (r,a), ns (r,a))) C'. lec_of_nsc (s *R ns)) =
         (\<Sum>(r, a)\<leftarrow>C'. subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a)))"
     if "set C' \<subseteq> set C" for C'
     using that proof (induction C')
     case Nil
     then show ?case by simp
   next
     case (Cons a C')
     have "(\<Sum>x\<leftarrow>a # C'. lec_of_nsc (s x *R ns x)) = 
           lec_of_nsc (s a *R ns a) + (\<Sum>x\<leftarrow>C'. lec_of_nsc (s x *R ns x))"
       by simp
     also have "(\<Sum>x\<leftarrow>C'. lec_of_nsc (s x *R ns x)) = (\<Sum>(r, a)\<leftarrow>C'. subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a)))"
       using Cons by (auto simp add: case_prod_beta' comp_def)
     also have "lec_of_nsc (s a *R ns a) = subst_poly_lec \<sigma> (lec_of_nsc (fst a *R nsc_of_atom (snd a)))"
     proof -
       have "a \<in> set C"
         using Cons by simp
       then show ?thesis
         using ns by auto
     qed
     finally show ?case
       by (auto simp add: case_prod_beta' comp_def)
   qed
   also have "(\<Sum>(r, a)\<leftarrow>C. subst_poly_lec \<sigma> (lec_of_nsc (r *R nsc_of_atom a)))
              = subst_poly_lec \<sigma> (\<Sum>(r, a)\<leftarrow>C. (lec_of_nsc (r *R nsc_of_atom a)))"
     by (auto simp add: subst_poly_lec_sum_list case_prod_beta' comp_def)
   also have "(\<Sum>(r, a)\<leftarrow>C. (lec_of_nsc (r *R nsc_of_atom a))) = Leqc p c"
     using 0 by blast
   also have "subst_poly_lec \<sigma> (Leqc p c) = Leqc (subst_poly \<sigma> p) c" by simp
   also have "subst_poly \<sigma> p = 0" 
   proof (rule all_valuate_zero)
     fix v :: "QDelta valuation" 
     have "(subst_poly \<sigma> p) \<lbrace> v \<rbrace> = (p \<lbrace> \<lambda>x. ((\<sigma> x) \<lbrace> v \<rbrace>) \<rbrace>)" by (rule valuate_subst_poly)
     also have "\<dots> = 0" 
     proof (rule 0(4))
       have "(\<sigma> a) \<lbrace> v \<rbrace> = (q \<lbrace> \<lambda>x. ((\<sigma> x) \<lbrace> v \<rbrace>) \<rbrace>)" if "(a, q) \<in> set (Tableau S)" for a q
       proof -
         have "distinct (map fst ?T)"
           using normalized_tableau_preprocess' assms unfolding normalized_tableau_def lhs_def
           by (auto simp add: case_prod_beta')
         then have 0: "\<sigma> a = q"
           unfolding \<sigma>_def using that by auto
         have "q \<lbrace> v \<rbrace> = (q \<lbrace> \<lambda>x. ((\<sigma> x) \<lbrace> v \<rbrace>) \<rbrace>)"
         proof -
           have "vars q \<subseteq> rvars ?T"
             unfolding rvars_def using that by force
           moreover have "(\<sigma> x) \<lbrace> v \<rbrace> = v x" if "x \<in> rvars ?T" for x
           proof -
             have "x \<notin> lvars (Tableau S)"
               using that normalized_tableau_preprocess' assms
               unfolding normalized_tableau_def by blast
             then have "x \<notin> fst ` set (Tableau S)"
               unfolding lvars_def by force
             then have "map_of ?T x = None"
               using map_of_eq_None_iff by metis
             then have "\<sigma> x = lp_monom 1 x"
               unfolding \<sigma>_def by auto
             also have "(lp_monom 1 x) \<lbrace> v \<rbrace> = v x"
               by auto
             finally show ?thesis .
           qed
           ultimately show ?thesis
             by (auto intro!: valuate_depend)
         qed
         then show ?thesis
           using 0 by blast
       qed
       then show "(\<lambda>x. ((\<sigma> x) \<lbrace> v \<rbrace>)) \<Turnstile>\<^sub>t ?T" 
         using 0 by (auto simp add: satisfies_tableau_def satisfies_eq_def)
     qed
     finally show "(subst_poly \<sigma> p) \<lbrace> v \<rbrace> = 0" .
   qed
   finally have "(\<Sum>(s, n)\<leftarrow>NC. lec_of_nsc (s *R n)) = Le_Constraint Leq_Rel 0 c"
     unfolding NC_def by blast
   moreover have "ns (r,a) \<in> snd ` set cs" "is_leq_ns (s (r, a) *R ns (r, a))" "s (r, a) \<noteq> 0" if "(r, a) \<in> set C" for r a
     using ns that by force+
   ultimately have "farkas_coefficients_ns (snd ` set cs) NC"
     unfolding farkas_coefficients_ns_def NC_def using 0 by force
   then show ?thesis
     by blast
 qed
 
 lemma preprocess'_unsat_indexD: "i \<in> set (UnsatIndices (preprocess' ns j)) \<Longrightarrow> 
   \<exists> c. poly c = 0 \<and> \<not> zero_satisfies c \<and> (i,c) \<in> set ns" 
   by (induct ns j rule: preprocess'.induct, auto simp: Let_def split: if_splits option.splits)
 
 lemma preprocess'_unsat_index_farkas_coefficients_ns: 
   assumes "i \<in> set (UnsatIndices (preprocess' ns j))" 
   shows "\<exists> C. farkas_coefficients_ns (snd ` set ns) C" 
 proof -
   from preprocess'_unsat_indexD[OF assms]
   obtain c where contr: "poly c = 0" "\<not> zero_satisfies c" and mem: "(i,c) \<in> set ns" by auto
   from mem have mem: "c \<in> snd ` set ns" by force
   let ?c = "ns_constraint_const c" 
   define r where "r = (case c of LEQ_ns _ _ \<Rightarrow> 1 | _ \<Rightarrow> (-1 :: rat))" 
   define d where "d = (case c of LEQ_ns _ _ \<Rightarrow> ?c | _ \<Rightarrow> - ?c)" 
   have [simp]: "(- x < 0) = (0 < x)" for x :: QDelta using uminus_less_lrv[of _ 0] by simp
   show ?thesis unfolding farkas_coefficients_ns_def 
     by (intro exI[of _ "[(r,c)]"] exI[of _ d], insert mem contr, cases "c", 
         auto simp: r_def d_def)
 qed
 
 text \<open>The combination of the previous results easily provides the main result of this section:
   a finite set of non-strict constraints on layer~2 is unsatisfiable if and only if there are Farkas coefficients.
   Again, here we use results from the simplex formalization, namely soundness of the preprocess-function.\<close>
 
 lemma farkas_coefficients_ns: assumes "finite (ns :: QDelta ns_constraint set)" 
   shows "(\<exists> C. farkas_coefficients_ns ns C) \<longleftrightarrow> (\<nexists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ns)" 
 proof 
   assume "\<exists> C. farkas_coefficients_ns ns C" 
   from farkas_coefficients_ns_unsat this show "\<nexists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ns" by blast
 next
   assume unsat: "\<nexists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ns" 
   from finite_list[OF assms] obtain nsl where ns: "ns = set nsl" by auto
   let ?cs = "map (Pair ()) nsl" 
   obtain I t ias where part1: "preprocess_part_1 ?cs = (t,ias,I)" by (cases "preprocess_part_1 ?cs", auto)
   let ?as = "snd ` set ias" 
   let ?s = "start_fresh_variable ?cs" 
   have fin: "finite ?as" by auto
   have id: "ias = Atoms (preprocess' ?cs ?s)" "t = Tableau (preprocess' ?cs ?s)" 
     "I = UnsatIndices (preprocess' ?cs ?s)" 
     using part1 unfolding preprocess_part_1_def Let_def by auto
   have norm: "\<triangle> t" using normalized_tableau_preprocess'[of ?cs] unfolding  id .
   {
     fix v
     assume "v \<Turnstile>\<^sub>a\<^sub>s ?as" "v \<Turnstile>\<^sub>t t" 
     from preprocess'_sat[OF this[unfolded id], folded id] unsat[unfolded ns] 
     have "set I \<noteq> {}" by auto
     then obtain i where "i \<in> set I" using all_not_in_conv by blast
     from preprocess'_unsat_index_farkas_coefficients_ns[OF this[unfolded id]]
     have "\<exists>C. farkas_coefficients_ns (snd ` set ?cs) C" by simp
   }    
   with farkas_coefficients_atoms_tableau[OF norm fin]
   obtain C where "farkas_coefficients_atoms_tableau ?as t C
      \<or> (\<exists>C. farkas_coefficients_ns (snd ` set ?cs) C)" by blast
   from farkas_coefficients_preprocess'[of ?cs, OF refl] this
   have "\<exists> C. farkas_coefficients_ns (snd ` set ?cs) C" 
     using part1 unfolding preprocess_part_1_def Let_def by auto
   also have "snd ` set ?cs = ns" unfolding ns by force
   finally show "\<exists> C. farkas_coefficients_ns ns C" .
 qed
 
 subsection \<open>Farkas' Lemma on Layer 1\<close>
 
 text \<open>The main difference of layers 1 and 2 is the restriction to non-strict constraints via delta-rationals.
   Since we now work with another constraint type, @{type constraint}, we again need translations into
   linear inequalities of type @{type le_constraint}. Moreover, we also need to define scaling of constraints
   where flipping the comparison sign may be required.\<close>
 
 fun is_le :: "constraint \<Rightarrow> bool" where
   "is_le (LT _ _) = True" 
 | "is_le (LEQ _ _) = True" 
 | "is_le _ = False" 
 
 fun lec_of_constraint where
   "lec_of_constraint (LEQ p c) = (Le_Constraint Leq_Rel p c)"
 | "lec_of_constraint (LT p c) = (Le_Constraint Lt_Rel p c)" 
 
 lemma lec_of_constraint: 
   assumes "is_le c"
   shows "(v \<Turnstile>\<^sub>l\<^sub>e (lec_of_constraint c)) \<longleftrightarrow> (v \<Turnstile>\<^sub>c c)"
   using assms by (cases c, auto)
 
 instantiation constraint :: scaleRat
 begin
 fun scaleRat_constraint :: "rat \<Rightarrow> constraint \<Rightarrow> constraint" where
   "scaleRat_constraint r cc = (if r = 0 then LEQ 0 0 else 
   (case cc of 
     LEQ p c \<Rightarrow>
      (if (r < 0) then GEQ (r *R p) (r *R c) else LEQ (r *R p) (r *R c))
   | LT p c \<Rightarrow>
      (if (r < 0) then GT (r *R p) (r *R c) else LT (r *R p) (r *R c))
   | GEQ p c \<Rightarrow> 
     (if (r > 0) then GEQ (r *R p) (r *R c) else LEQ (r *R p) (r *R c))
   | GT p c \<Rightarrow> 
     (if (r > 0) then GT (r *R p) (r *R c) else LT (r *R p) (r *R c))
   | LTPP p q \<Rightarrow>
      (if (r < 0) then GT (r *R (p - q)) 0 else LT (r *R (p - q)) 0)
   | LEQPP p q \<Rightarrow>
      (if (r < 0) then GEQ (r *R (p - q)) 0 else LEQ (r *R (p - q)) 0)
   | GTPP p q \<Rightarrow>
      (if (r > 0) then GT (r *R (p - q)) 0 else LT (r *R (p - q)) 0)
   | GEQPP p q \<Rightarrow>
      (if (r > 0) then GEQ (r *R (p - q)) 0 else LEQ (r *R (p - q)) 0)
   | EQPP p q \<Rightarrow> LEQ (r *R (p - q)) 0 \<comment> \<open>We do not keep equality, since the aim is 
         to convert the scaled constraints into inequalities, which will then be summed up.\<close>
   | EQ p c \<Rightarrow> LEQ (r *R p) (r *R c) 
 ))"
 
 instance ..
 end
 
 lemma sat_scale_rat: assumes "(v :: rat valuation) \<Turnstile>\<^sub>c c"
   shows "v \<Turnstile>\<^sub>c (r *R c)"
 proof -
   have "r < 0 \<or> r = 0 \<or> r > 0" by auto
   then show ?thesis using assms by (cases c, auto simp: right_diff_distrib 
         valuate_minus valuate_scaleRat scaleRat_leq1 scaleRat_leq2 valuate_zero)
 qed
 
 text \<open>In the following definition of Farkas coefficients (for layer 1), the main difference to
   @{const farkas_coefficients_ns} is that the linear combination evaluates either to
   a strict inequality where the constant must be non-positive, or to a non-strict inequality where
   the constant must be negative.\<close>
 
 definition farkas_coefficients where 
   "farkas_coefficients cs C = (\<exists> d rel. 
     (\<forall> (r,c) \<in> set C. c \<in> cs \<and> is_le (r *R c) \<and> r \<noteq> 0) \<and>
     (\<Sum> (r,c) \<leftarrow> C. lec_of_constraint (r *R c)) = Le_Constraint rel 0 d \<and> 
     (rel = Leq_Rel \<and> d < 0 \<or> rel = Lt_Rel \<and> d \<le> 0))"
 
 text \<open>Again, the existence Farkas coefficients immediately implies unsatisfiability.\<close>
 
 lemma farkas_coefficients_unsat: 
   assumes "farkas_coefficients cs C" 
   shows "\<nexists> v. v \<Turnstile>\<^sub>c\<^sub>s cs" 
 proof
   assume "\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s cs"
   then obtain v where *: "v \<Turnstile>\<^sub>c\<^sub>s cs" by auto
   obtain d rel where
     isleq: "(\<forall>(r,c) \<in> set C. c \<in> cs \<and> is_le (r *R c) \<and> r \<noteq> 0)" and
     leq: "(\<Sum> (r,c) \<leftarrow> C. lec_of_constraint (r *R c)) = Le_Constraint rel 0 d" and
     choice: "rel = Lt_Rel \<and> d \<le> 0 \<or> rel = Leq_Rel \<and> d < 0" using assms farkas_coefficients_def by blast
   {
     fix r c
     assume c: "(r,c) \<in> set C" 
     from c * isleq have "v \<Turnstile>\<^sub>c c" by auto
     hence v: "v \<Turnstile>\<^sub>c (r *R c)" by (rule sat_scale_rat)
     from c isleq have "is_le (r *R c)" by auto
     from lec_of_constraint[OF this] v 
     have "v \<Turnstile>\<^sub>l\<^sub>e lec_of_constraint (r *R c)" by blast
   } note v = this
   have "v \<Turnstile>\<^sub>l\<^sub>e Le_Constraint rel 0 d" unfolding leq[symmetric]
     by (rule satisfies_sumlist_le_constraints, insert v, auto)
   then show False using choice
     by (cases rel, auto simp: valuate_zero)
 qed
 
 text \<open>Now follows the difficult implication. 
   The major part is proving that the translation @{const constraint_to_qdelta_constraint} 
   preserves the existence of Farkas coefficients via pointwise compatibility of the sum.
   Here, compatibility links a strict or non-strict inequality from the input constraint to
   a translated non-strict inequality over delta-rationals.\<close>
 
 fun compatible_cs where 
   "compatible_cs (Le_Constraint Leq_Rel p c) (Le_Constraint Leq_Rel q d) = (q = p \<and> d = QDelta c 0)" 
 | "compatible_cs (Le_Constraint Lt_Rel p c) (Le_Constraint Leq_Rel q d) = (q = p \<and> qdfst d = c)" 
 | "compatible_cs _ _ = False" 
 
 lemma compatible_cs_0_0: "compatible_cs 0 0" by code_simp
 
 lemma compatible_cs_plus: "compatible_cs c1 d1 \<Longrightarrow> compatible_cs c2 d2 \<Longrightarrow> compatible_cs (c1 + c2) (d1 + d2)" 
   by (cases c1; cases d1; cases c2; cases d2; cases "lec_rel c1"; cases "lec_rel d1"; cases "lec_rel c2"; 
       cases "lec_rel d2"; auto simp: plus_QDelta_def)
 
 lemma unsat_farkas_coefficients: assumes "\<nexists> v. v \<Turnstile>\<^sub>c\<^sub>s cs" 
   and fin: "finite cs" 
 shows "\<exists> C. farkas_coefficients cs C" 
 proof -
   from finite_list[OF fin] obtain csl where cs: "cs = set csl" by blast
   let ?csl = "map (Pair ()) csl" 
   let ?ns = "(snd ` set (to_ns ?csl))" 
   let ?nsl = "concat (map constraint_to_qdelta_constraint csl)" 
   have id: "snd ` set ?csl = cs" unfolding cs by force
   have id2: "?ns = set ?nsl" unfolding to_ns_def set_concat by force
   from SolveExec'Default.to_ns_sat[of ?csl, unfolded id] assms
   have unsat: "\<nexists> v. \<langle>v\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ?ns" by metis
   have fin: "finite ?ns" by auto
   have "\<nexists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ?ns" 
   proof
     assume "\<exists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ?ns" 
     then obtain v where model: "v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ?ns" by blast
     let ?v = "Mapping.Mapping (\<lambda> x. Some (v x))" 
     have "v = \<langle>?v\<rangle>" by (intro ext, auto simp: map2fun_def Mapping.lookup.abs_eq) 
     from model this unsat show False by metis
   qed    
   from farkas_coefficients_ns[OF fin] this id2 obtain N where
     farkas: "farkas_coefficients_ns (set ?nsl) N" by metis
   from this[unfolded farkas_coefficients_ns_def]
   obtain d where 
     is_leq: "\<And> a n. (a,n) \<in> set N \<Longrightarrow> n \<in> set ?nsl \<and> is_leq_ns (a *R n) \<and> a \<noteq> 0" and 
     sum: "(\<Sum>(a,n)\<leftarrow>N. lec_of_nsc (a *R n)) = Le_Constraint Leq_Rel 0 d" and
     d0: "d < 0" by blast
   let ?prop = "\<lambda> NN C. (\<forall> (a,c) \<in> set C. c \<in> cs \<and> is_le (a *R c) \<and> a \<noteq> 0)
       \<and> compatible_cs (\<Sum> (a,c) \<leftarrow> C. lec_of_constraint (a *R c)) 
           (\<Sum>(a,n)\<leftarrow>NN. lec_of_nsc (a *R n))" 
   have "set NN \<subseteq> set N \<Longrightarrow> \<exists> C. ?prop NN C" for NN
   proof (induct NN)
     case Nil
     have "?prop Nil Nil" by (simp add: compatible_cs_0_0)
     thus ?case by blast
   next
     case (Cons an NN)
     obtain a n where an: "an = (a,n)" by force
     from Cons an obtain C where IH: "?prop NN C" and n: "(a,n) \<in> set N" by auto
     have compat_CN: "compatible_cs (\<Sum>(f, c)\<leftarrow>C. lec_of_constraint (f *R c)) 
       (\<Sum>(a,n)\<leftarrow>NN. lec_of_nsc (a *R n))" 
       using IH by blast
     from n is_leq obtain c where c: "c \<in> cs" and nc: "n \<in> set (constraint_to_qdelta_constraint c)" 
       unfolding cs by force
     from is_leq[OF n] have is_leq: "is_leq_ns (a *R n) \<and> a \<noteq> 0" by blast
     have is_less: "is_le (a *R c)" and 
       a0: "a \<noteq> 0" and
       compat_cn: "compatible_cs (lec_of_constraint (a *R c)) (lec_of_nsc (a *R n))" 
       by (atomize(full), cases c, insert is_leq nc, auto simp: QDelta_0_0 scaleRat_QDelta_def qdsnd_0 qdfst_0)
     let ?C = "Cons (a, c) C" 
     let ?N = "Cons (a, n) NN" 
     have "?prop ?N ?C" unfolding an
     proof (intro conjI)
       show "\<forall> (a,c) \<in> set ?C. c \<in> cs \<and> is_le (a *R c) \<and> a \<noteq> 0" using IH is_less a0 c by auto
       show "compatible_cs (\<Sum>(a, c)\<leftarrow>?C. lec_of_constraint (a *R c)) (\<Sum>(a,n)\<leftarrow>?N. lec_of_nsc (a *R n))" 
         using compatible_cs_plus[OF compat_cn compat_CN] by simp
     qed
     thus ?case unfolding an by blast
   qed
   from this[OF subset_refl, unfolded sum]
   obtain C where 
     is_less: "(\<forall>(a, c)\<in>set C. c \<in> cs \<and> is_le (a *R c) \<and> a \<noteq> 0)" and
     compat: "compatible_cs (\<Sum>(f, c)\<leftarrow>C. lec_of_constraint (f *R c)) (Le_Constraint Leq_Rel 0 d)" 
     (is "compatible_cs ?sum _")
     by blast
   obtain rel p e where "?sum = Le_Constraint rel p e" by (cases ?sum)
   with compat have sum: "?sum = Le_Constraint rel 0 e" by (cases rel, auto)
   have e: "(rel = Leq_Rel \<and> e < 0 \<or> rel = Lt_Rel \<and> e \<le> 0)" using compat[unfolded sum] d0
     by (cases rel, auto simp: less_QDelta_def qdfst_0 qdsnd_0) 
   show ?thesis unfolding farkas_coefficients_def
     by (intro exI conjI, rule is_less, rule sum, insert e, auto)
 qed
 
 text \<open>Finally we can prove on layer 1 that a finite set of constraints is 
   unsatisfiable if and only if there are Farkas coefficients.\<close>
 
 lemma farkas_coefficients: assumes "finite cs" 
   shows "(\<exists> C. farkas_coefficients cs C) \<longleftrightarrow> (\<nexists> v. v \<Turnstile>\<^sub>c\<^sub>s cs)" 
   using farkas_coefficients_unsat unsat_farkas_coefficients[OF _ assms] by blast
 
 section \<open>Corollaries from the Literature\<close>
 
 text \<open>In this section, we convert the previous variations of Farkas' Lemma into more 
   well-known forms of this result.
   Moreover, instead of referring to the various constraint types of the simplex formalization, we
   now speak solely about constraints of type @{type le_constraint}.\<close>
 
 subsection \<open>Farkas' Lemma on Delta-Rationals\<close>
 
 text \<open>We start with Lemma~2 of \cite{Bromberger2017}, a
   variant of Farkas' Lemma for delta-rationals. To be more precise, it states
   that a set of non-strict inequalities over delta-rationals is unsatisfiable
   if and only if there is a linear combination of the inequalities that results
   in a trivial unsatisfiable constraint $0 < const$ for some negative constant $const$.
   We can easily prove this statement via the lemma @{thm [source] farkas_coefficients_ns} 
   and some conversions between the 
   different constraint types.\<close>
 
 lemma Farkas'_Lemma_Delta_Rationals: fixes cs :: "QDelta le_constraint set"
   assumes only_non_strict: "lec_rel ` cs \<subseteq> {Leq_Rel}"  
     and fin: "finite cs" 
   shows "(\<nexists> v. \<forall> c \<in> cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> 
        (\<exists> C const. (\<forall> (r, c) \<in> set C. r > 0 \<and> c \<in> cs)
          \<and> (\<Sum> (r,c) \<leftarrow> C. Leqc (r *R lec_poly c) (r *R lec_const c)) = Leqc 0 const
          \<and> const < 0)" 
     (is "?lhs = ?rhs")
 proof -
   {
     fix c
     assume "c \<in> cs" 
     with only_non_strict have "lec_rel c = Leq_Rel" by auto
     then have "\<exists> p const. c = Leqc p const" by (cases c, auto)
   } note leqc = this
   let ?to_ns = "\<lambda> c. LEQ_ns (lec_poly c) (lec_const c)" 
   let ?ns = "?to_ns ` cs" 
   from fin have fin: "finite ?ns" by auto
   have "v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ?ns \<longleftrightarrow> (\<forall> c \<in> cs. v \<Turnstile>\<^sub>l\<^sub>e c)" for v using leqc by fastforce
   hence "?lhs = (\<nexists> v. v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s ?ns)" by simp
   also have "\<dots> = (\<exists>C. farkas_coefficients_ns ?ns C)" unfolding farkas_coefficients_ns[OF fin] ..
   also have "\<dots> = ?rhs" 
   proof
     assume "\<exists> C. farkas_coefficients_ns ?ns C" 
     then obtain C const where is_leq: "\<forall> (s, n) \<in> set C. n \<in> ?ns \<and> is_leq_ns (s *R n) \<and> s \<noteq> 0" 
       and sum: "(\<Sum>(s, n)\<leftarrow>C. lec_of_nsc (s *R n)) = Leqc 0 const"
       and c0: "const < 0" unfolding farkas_coefficients_ns_def by blast
     let ?C = "map (\<lambda> (s,n). (s,lec_of_nsc n)) C" 
     show ?rhs 
     proof (intro exI[of _ ?C] exI[of _ const] conjI c0, unfold sum[symmetric] map_map o_def set_map, 
         intro ballI, clarify)
       {
         fix s n 
         assume sn: "(s, n) \<in> set C" 
         with is_leq
         have n_ns: "n \<in> ?ns" and is_leq: "is_leq_ns (s *R n)" "s \<noteq> 0" by force+
         from n_ns obtain c where c: "c \<in> cs" and n: "n = LEQ_ns (lec_poly c) (lec_const c)" by auto
         with leqc[OF c] obtain p d where cs: "Leqc p d \<in> cs" and n: "n = LEQ_ns p d" by auto
         from is_leq[unfolded n] have s0: "s > 0" by (auto split: if_splits) 
         let ?n = "lec_of_nsc n" 
         from cs n have mem: "?n \<in> cs" by auto
         show "0 < s \<and> ?n \<in> cs" using s0 mem by blast        
         have "Leqc (s *R lec_poly ?n) (s *R lec_const ?n) = lec_of_nsc (s *R n)" 
           unfolding n using s0 by simp
       } note id = this
       show "(\<Sum>x\<leftarrow>C. case case x of (s, n) \<Rightarrow> (s, lec_of_nsc n) of
              (r, c) \<Rightarrow> Leqc (r *R lec_poly c) (r *R lec_const c)) =
              (\<Sum>(s, n)\<leftarrow>C. lec_of_nsc (s *R n))" (is "sum_list (map ?f C) = sum_list (map ?g C)")
       proof (rule arg_cong[of _ _ sum_list], rule map_cong[OF refl])
         fix pair
         assume mem: "pair \<in> set C" 
         then obtain s n where pair: "pair = (s,n)" by force
         show "?f pair = ?g pair" unfolding pair split using id[OF mem[unfolded pair]] .
       qed
     qed
   next
     assume ?rhs
     then obtain C const 
       where C: "\<And> r c. (r,c) \<in> set C \<Longrightarrow> 0 < r \<and> c \<in> cs" 
         and sum: "(\<Sum>(r, c)\<leftarrow>C. Leqc (r *R lec_poly c) (r *R lec_const c)) = Leqc 0 const"
         and const: "const < 0" 
       by blast
     let ?C = "map (\<lambda> (r,c). (r, ?to_ns c)) C"  
     show "\<exists> C. farkas_coefficients_ns ?ns C" unfolding farkas_coefficients_ns_def
     proof (intro exI[of _ ?C] exI[of _ const] conjI const, unfold sum[symmetric])
       show "\<forall>(s, n)\<in>set ?C. n \<in> ?ns \<and> is_leq_ns (s *R n) \<and> s \<noteq> 0" using C by fastforce
       show "(\<Sum>(s, n)\<leftarrow>?C. lec_of_nsc (s *R n)) 
         = (\<Sum>(r, c)\<leftarrow>C. Leqc (r *R lec_poly c) (r *R lec_const c))"
         unfolding map_map o_def
         by (rule arg_cong[of _ _ sum_list], rule map_cong[OF refl], insert C, force)
     qed
   qed
   finally show ?thesis .
 qed
 
 
 
 subsection \<open>Motzkin's Transposition Theorem or the Kuhn-Fourier Theorem\<close>
 
 text \<open>Next, we prove a generalization of Farkas' Lemma that permits arbitrary combinations
   of strict and non-strict inequalities: Motzkin's Transposition Theorem
   which is also known as the Kuhn--Fourier Theorem.
 
   The proof is mainly based on the lemma @{thm [source] farkas_coefficients}, 
   again requiring conversions between constraint types.\<close>
 
 theorem Motzkin's_transposition_theorem: fixes cs :: "rat le_constraint set"
   assumes fin: "finite cs" 
   shows "(\<nexists> v. \<forall> c \<in> cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> 
        (\<exists> C const rel. (\<forall> (r, c) \<in> set C. r > 0 \<and> c \<in> cs)
          \<and> (\<Sum> (r,c) \<leftarrow> C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) 
                = Le_Constraint rel 0 const
          \<and> (rel = Leq_Rel \<and> const < 0 \<or> rel = Lt_Rel \<and> const \<le> 0))" 
     (is "?lhs = ?rhs")
 proof -
   let ?to_cs = "\<lambda> c. (case lec_rel c of Leq_Rel \<Rightarrow> LEQ | _ \<Rightarrow> LT) (lec_poly c) (lec_const c)" 
   have to_cs: "v \<Turnstile>\<^sub>c ?to_cs c \<longleftrightarrow> v \<Turnstile>\<^sub>l\<^sub>e c" for v c by (cases c, cases "lec_rel c", auto)
   let ?cs = "?to_cs ` cs" 
   from fin have fin: "finite ?cs" by auto
   have "v \<Turnstile>\<^sub>c\<^sub>s ?cs \<longleftrightarrow> (\<forall> c \<in> cs. v \<Turnstile>\<^sub>l\<^sub>e c)" for v using to_cs by auto
   hence "?lhs = (\<nexists> v. v \<Turnstile>\<^sub>c\<^sub>s ?cs)" by simp
   also have "\<dots> = (\<exists>C. farkas_coefficients ?cs C)" unfolding farkas_coefficients[OF fin] ..
   also have "\<dots> = ?rhs" 
   proof
     assume "\<exists> C. farkas_coefficients ?cs C" 
     then obtain C const rel where is_leq: "\<forall> (s, n) \<in> set C. n \<in> ?cs \<and> is_le (s *R n) \<and> s \<noteq> 0" 
       and sum: "(\<Sum>(s, n)\<leftarrow>C. lec_of_constraint (s *R n)) = Le_Constraint rel 0 const"
       and c0: "(rel = Leq_Rel \<and> const < 0 \<or> rel = Lt_Rel \<and> const \<le> 0)" 
       unfolding farkas_coefficients_def by blast
     let ?C = "map (\<lambda> (s,n). (s,lec_of_constraint n)) C" 
     show ?rhs 
     proof (intro exI[of _ ?C] exI[of _ const] exI[of _ rel] conjI c0, unfold map_map o_def set_map sum[symmetric], 
         intro ballI, clarify)
       {
         fix s n 
         assume sn: "(s, n) \<in> set C" 
         with is_leq 
         have n_ns: "n \<in> ?cs" and is_leq: "is_le (s *R n)" and s0: "s \<noteq> 0" by force+
         from n_ns obtain c where c: "c \<in> cs" and n: "n = ?to_cs c" by auto
         from is_leq[unfolded n] have "s \<ge> 0" by (cases "lec_rel c", auto split: if_splits) 
         with s0 have s0: "s > 0" by auto
         let ?c = "lec_of_constraint n" 
         from c n have mem: "?c \<in> cs" by (cases c, cases "lec_rel c", auto)
         show "0 < s \<and> ?c \<in> cs" using s0 mem by blast        
         have "lec_of_constraint (s *R n) = Le_Constraint (lec_rel ?c) (s *R lec_poly ?c) (s *R lec_const ?c)" 
           unfolding n using s0 by (cases c, cases "lec_rel c", auto)
       } note id = this
       show "(\<Sum>x\<leftarrow>C. case case x of (s, n) \<Rightarrow> (s, lec_of_constraint n) of
              (r, c) \<Rightarrow> Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) =
             (\<Sum>(s, n)\<leftarrow>C. lec_of_constraint (s *R n))" 
         (is "sum_list (map ?f C) = sum_list (map ?g C)")  
       proof (rule arg_cong[of _ _ sum_list], rule map_cong[OF refl])
         fix pair
         assume mem: "pair \<in> set C" 
         obtain r c where pair: "pair = (r,c)" by force
         show "?f pair = ?g pair" unfolding pair split id[OF mem[unfolded pair]] ..
       qed
     qed
   next
     assume ?rhs
     then obtain C const rel 
       where C: "\<And> r c. (r,c) \<in> set C \<Longrightarrow> 0 < r \<and> c \<in> cs" 
         and sum: "(\<Sum>(r, c)\<leftarrow>C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) 
            = Le_Constraint rel 0 const"
         and const: "rel = Leq_Rel \<and> const < 0 \<or> rel = Lt_Rel \<and> const \<le> 0" 
       by blast
     let ?C = "map (\<lambda> (r,c). (r, ?to_cs c)) C"  
     show "\<exists> C. farkas_coefficients ?cs C" unfolding farkas_coefficients_def
     proof (intro exI[of _ ?C] exI[of _ const] exI[of _ rel] conjI const, unfold sum[symmetric])
       show "\<forall>(s, n)\<in>set ?C. n \<in> ?cs \<and> is_le (s *R n) \<and> s \<noteq> 0" using C by (fastforce split: le_rel.splits) 
       show "(\<Sum>(s, n)\<leftarrow>?C. lec_of_constraint (s *R n)) 
         = (\<Sum>(r, c)\<leftarrow>C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c))"
         unfolding map_map o_def
         by (rule arg_cong[of _ _ sum_list], rule map_cong[OF refl], insert C, fastforce split: le_rel.splits)
     qed
   qed
   finally show ?thesis .
 qed
 
 subsection \<open>Farkas' Lemma\<close>
 
 text \<open>Finally we derive the commonly used form of Farkas' Lemma,
   which easily follows from @{thm [source] Motzkin's_transposition_theorem}. 
   It only permits non-strict inequalities and, as a result, 
   the sum of inequalities will always be non-strict.\<close>
 
 lemma Farkas'_Lemma: fixes cs :: "rat le_constraint set"
   assumes only_non_strict: "lec_rel ` cs \<subseteq> {Leq_Rel}"  
     and fin: "finite cs" 
   shows "(\<nexists> v. \<forall> c \<in> cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> 
        (\<exists> C const. (\<forall> (r, c) \<in> set C. r > 0 \<and> c \<in> cs)
          \<and> (\<Sum> (r,c) \<leftarrow> C. Leqc (r *R lec_poly c) (r *R lec_const c)) = Leqc 0 const
          \<and> const < 0)" 
     (is "_ = ?rhs")
 proof -
   {
     fix c
     assume "c \<in> cs" 
     with only_non_strict have "lec_rel c = Leq_Rel" by auto
     then have "\<exists> p const. c = Leqc p const" by (cases c, auto)
   } note leqc = this
   let ?lhs = "\<exists>C const rel.
        (\<forall>(r, c)\<in>set C. 0 < r \<and> c \<in> cs) \<and>
        (\<Sum>(r, c)\<leftarrow>C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) 
            = Le_Constraint rel 0 const \<and>
        (rel = Leq_Rel \<and> const < 0 \<or> rel = Lt_Rel \<and> const \<le> 0)" 
   show ?thesis unfolding Motzkin's_transposition_theorem[OF fin]
   proof
     assume ?rhs
     then obtain C const where C: "\<And> r c. (r, c)\<in>set C \<Longrightarrow> 0 < r \<and> c \<in> cs" and
       sum: "(\<Sum>(r, c)\<leftarrow>C. Leqc (r *R lec_poly c) (r *R lec_const c)) = Leqc 0 const"  and
       const: "const < 0" by blast
     show ?lhs 
     proof (intro exI[of _ C] exI[of _ const] exI[of _ Leq_Rel] conjI)
       show "\<forall> (r,c) \<in> set C. 0 < r \<and> c \<in> cs" using C by force
       show "(\<Sum>(r, c)\<leftarrow> C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) =
         Leqc 0 const" unfolding sum[symmetric]
         by (rule arg_cong[of _ _ sum_list], rule map_cong[OF refl], insert C, force dest!: leqc)
     qed (insert const, auto)
   next
     assume ?lhs
     then obtain C const rel where C: "\<And> r c. (r, c)\<in>set C \<Longrightarrow> 0 < r \<and> c \<in> cs" and
       sum: "(\<Sum>(r, c)\<leftarrow>C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) 
         = Le_Constraint rel 0 const"  and
       const: "rel = Leq_Rel \<and> const < 0 \<or> rel = Lt_Rel \<and> const \<le> 0" by blast
     have id: "(\<Sum>(r, c)\<leftarrow>C. Le_Constraint (lec_rel c) (r *R lec_poly c) (r *R lec_const c)) = 
           (\<Sum>(r, c)\<leftarrow>C. Leqc (r *R lec_poly c) (r *R lec_const c))" (is "_  = ?sum")
       by (rule arg_cong[of _ _ sum_list], rule map_cong, auto dest!: C leqc)
     have "lec_rel ?sum = Leq_Rel" unfolding sum_list_lec by (auto simp add: sum_list_Leq_Rel o_def)
     with sum[unfolded id] have rel: "rel = Leq_Rel" by auto
     with const have const: "const < 0" by auto
     show ?rhs
       by (intro exI[of _ C] exI[of _ const] conjI const, insert sum id C rel, force+)
   qed
 qed
 
 text \<open>We also present slightly modified versions\<close>
 
 lemma sum_list_map_filter_sum: fixes f :: "'a \<Rightarrow> 'b :: comm_monoid_add" 
   shows "sum_list (map f (filter g xs)) + sum_list (map f (filter (Not o g) xs)) = sum_list (map f xs)" 
   by (induct xs, auto simp: ac_simps)
 
 text \<open>A version where every constraint obtains exactly one coefficient and where 0 coefficients are allowed.\<close>
 
 lemma Farkas'_Lemma_set_sum: fixes cs :: "rat le_constraint set"
   assumes only_non_strict: "lec_rel ` cs \<subseteq> {Leq_Rel}"  
     and fin: "finite cs" 
   shows "(\<nexists> v. \<forall> c \<in> cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> 
        (\<exists> C const. (\<forall> c \<in> cs. C c \<ge> 0)
          \<and> (\<Sum> c \<in> cs. Leqc ((C c) *R lec_poly c) ((C c) *R lec_const c)) = Leqc 0 const
          \<and> const < 0)" 
   unfolding Farkas'_Lemma[OF only_non_strict fin] 
 proof ((standard; elim exE conjE), goal_cases)
   case (2 C const)
   from finite_distinct_list[OF fin] obtain csl where csl: "set csl = cs" and dist: "distinct csl" 
     by auto
   let ?list = "filter (\<lambda> c. C c \<noteq> 0) csl" 
   let ?C = "map (\<lambda> c. (C c, c)) ?list" 
   show ?case
   proof (intro exI[of _ ?C] exI[of _ const] conjI)
     have "(\<Sum>(r, c)\<leftarrow>?C. Le_Constraint Leq_Rel (r *R lec_poly c) (r *R lec_const c))
       = (\<Sum>(r, c)\<leftarrow>map (\<lambda>c. (C c, c)) csl. Le_Constraint Leq_Rel (r *R lec_poly c) (r *R lec_const c))" 
       unfolding map_map
       by (rule sum_list_map_filter, auto simp: zero_le_constraint_def)
     also have "\<dots> = Le_Constraint Leq_Rel 0 const" unfolding 2(2)[symmetric] csl[symmetric]
       unfolding sum.distinct_set_conv_list[OF dist] map_map o_def split ..
     finally 
     show "(\<Sum>(r, c)\<leftarrow>?C. Le_Constraint Leq_Rel (r *R lec_poly c) (r *R lec_const c)) = Le_Constraint Leq_Rel 0 const"  
       by auto
     show "const < 0" by fact
     show "\<forall>(r, c)\<in>set ?C. 0 < r \<and> c \<in> cs" using 2(1) unfolding set_map set_filter csl by auto
   qed
 next
   case (1 C const)
   define CC where "CC = (\<lambda> c. sum_list (map fst (filter (\<lambda> rc. snd rc = c) C)))" 
   show "(\<exists> C const. (\<forall> c \<in> cs. C c \<ge> 0)
          \<and> (\<Sum> c \<in> cs. Leqc ((C c) *R lec_poly c) ((C c) *R lec_const c)) = Leqc 0 const
          \<and> const < 0)" 
   proof (intro exI[of _ CC] exI[of _ const] conjI)
     show "\<forall>c\<in>cs. 0 \<le> CC c" unfolding CC_def using 1(1) 
       by (force intro!: sum_list_nonneg)
     show "const < 0" by fact
     from 1 have snd: "snd ` set C \<subseteq> cs" by auto
     show "(\<Sum>c\<in>cs. Le_Constraint Leq_Rel (CC c *R lec_poly c) (CC c *R lec_const c)) = Le_Constraint Leq_Rel 0 const" 
       unfolding 1(2)[symmetric] using fin snd unfolding CC_def
     proof (induct cs arbitrary: C rule: finite_induct)
       case empty
       hence C: "C = []" by auto
       thus ?case by simp
     next
       case *: (insert c cs C)
       let ?D = "filter (Not \<circ> (\<lambda>rc. snd rc = c)) C" 
       from * have "snd ` set ?D \<subseteq> cs" by auto
       note IH = *(3)[OF this]
       have id: "(\<Sum>a\<leftarrow> ?D. case a of (r, c) \<Rightarrow> Le_Constraint Leq_Rel (r *R lec_poly c) (r *R lec_const c)) = 
         (\<Sum>(r, c)\<leftarrow>?D. Le_Constraint Leq_Rel (r *R lec_poly c) (r *R lec_const c))" 
         by (induct C, force+)
       show ?case
         unfolding sum.insert[OF *(1,2)]
         unfolding sum_list_map_filter_sum[of _ "\<lambda> rc. snd rc = c" C, symmetric]
       proof (rule arg_cong2[of _ _ _ _ "(+)"], goal_cases)
         case 2
         show ?case unfolding IH[symmetric] 
           by (rule sum.cong, insert *(2,1), auto intro!: arg_cong[of _ _ "\<lambda> xs. sum_list (map _ xs)"], (induct C, auto)+)
       next
         case 1
         show ?case
         proof (rule sym, induct C)
           case (Cons rc C)
           thus ?case by (cases "rc", cases "snd rc = c", auto simp: field_simps scaleRat_left_distrib)
         qed (auto simp: zero_le_constraint_def)
       qed
     qed
   qed
 qed
 
 text \<open>A version with indexed constraints, i.e., in particular where constraints may occur several
   times.\<close>
 
 lemma Farkas'_Lemma_indexed: fixes c :: "nat \<Rightarrow> rat le_constraint"
   assumes only_non_strict: "lec_rel ` c ` Is \<subseteq> {Leq_Rel}"  
   and fin: "finite Is" 
   shows "(\<nexists> v. \<forall> i \<in> Is. v \<Turnstile>\<^sub>l\<^sub>e c i) \<longleftrightarrow> 
        (\<exists> C const. (\<forall> i \<in> Is. C i \<ge> 0)
          \<and> (\<Sum> i \<in> Is. Leqc ((C i) *R lec_poly (c i)) ((C i) *R lec_const (c i))) = Leqc 0 const
          \<and> const < 0)" 
 proof -
   let ?C = "c ` Is" 
   have fin: "finite ?C" using fin by auto
   have "(\<nexists> v. \<forall> i \<in> Is. v \<Turnstile>\<^sub>l\<^sub>e c i) = (\<nexists> v. \<forall> cc \<in> ?C. v \<Turnstile>\<^sub>l\<^sub>e cc)" by force
   also have "\<dots> = (\<exists> C const. (\<forall> i \<in> Is. C i \<ge> 0)
          \<and> (\<Sum> i \<in> Is. Leqc ((C i) *R lec_poly (c i)) ((C i) *R lec_const (c i))) = Leqc 0 const
          \<and> const < 0)" (is "?l = ?r")
   proof
     assume ?r
     then obtain C const where r: "(\<forall> i \<in> Is. C i \<ge> 0)" 
          and eq: "(\<Sum> i \<in> Is. Leqc ((C i) *R lec_poly (c i)) ((C i) *R lec_const (c i))) = Leqc 0 const" 
          and "const < 0" by auto
     from finite_distinct_list[OF \<open>finite Is\<close>] 
       obtain Isl where isl: "set Isl = Is" and dist: "distinct Isl" by auto
     let ?CC = "filter (\<lambda> rc. fst rc \<noteq> 0) (map (\<lambda> i. (C i, c i)) Isl)" 
     show ?l unfolding Farkas'_Lemma[OF only_non_strict fin]
     proof (intro exI[of _ ?CC] exI[of _ const] conjI)
       show "const < 0" by fact
       show "\<forall> (r, ca) \<in> set ?CC. 0 < r \<and> ca \<in> ?C" using r(1) isl by auto
       show "(\<Sum>(r, c)\<leftarrow>?CC. Le_Constraint Leq_Rel (r *R lec_poly c) (r *R lec_const c)) =
         Le_Constraint Leq_Rel 0 const" unfolding eq[symmetric]
         by (subst sum_list_map_filter, force simp: zero_le_constraint_def,
           unfold map_map o_def, subst sum_list_distinct_conv_sum_set[OF dist], rule sum.cong, auto simp: isl)
     qed
   next
     assume ?l
     from this[unfolded Farkas'_Lemma_set_sum[OF only_non_strict fin]]
     obtain C const where nonneg: "(\<forall>c\<in> ?C. 0 \<le> C c)" 
      and sum: "(\<Sum>c\<in> ?C. Le_Constraint Leq_Rel (C c *R lec_poly c) (C c *R lec_const c)) =
         Le_Constraint Leq_Rel 0 const" 
      and const: "const < 0" 
       by blast
     define I where "I = (\<lambda> i. (C (c i) / rat_of_nat (card (Is \<inter> { j. c i = c j}))))" 
     show ?r
     proof (intro exI[of _ I] exI[of _ const] conjI const)
       show "\<forall>i \<in> Is. 0 \<le> I i" using nonneg unfolding I_def by auto
       show "(\<Sum> i \<in> Is. Le_Constraint Leq_Rel (I i *R lec_poly (c i)) (I i *R lec_const (c i))) =
         Le_Constraint Leq_Rel 0 const" unfolding sum[symmetric]
         unfolding sum.image_gen[OF \<open>finite Is\<close>, of _ c]
       proof (rule sum.cong[OF refl], goal_cases)
         case (1 cc)
         define II where "II = (Is \<inter> {j. cc = c j})" 
         from 1 have "II \<noteq> {}" unfolding II_def by auto
         moreover have finII: "finite II" using \<open>finite Is\<close> unfolding II_def by auto
         ultimately have card: "card II \<noteq> 0" by auto
         let ?C = "\<lambda> II. rat_of_nat (card II)" 
         define ii where "ii = C cc / rat_of_nat (card II)" 
         have "(\<Sum>i\<in>{x \<in> Is. c x = cc}. Le_Constraint Leq_Rel (I i *R lec_poly (c i)) (I i *R lec_const (c i)))
           = (\<Sum> i\<in> II. Le_Constraint Leq_Rel (ii *R lec_poly cc) (ii *R lec_const cc))"
           unfolding I_def ii_def II_def by (rule sum.cong, auto)
         also have "\<dots> = Le_Constraint Leq_Rel ((?C II * ii) *R lec_poly cc) ((?C II * ii) *R lec_const cc)" 
           using finII by (induct II rule: finite_induct, auto simp: zero_le_constraint_def field_simps
             scaleRat_left_distrib)
         also have "?C II * ii = C cc" unfolding ii_def using card by auto
         finally show ?case .
       qed
     qed
   qed
   finally show ?thesis .
 qed
 
 
-end
\ No newline at end of file
+end
diff --git a/thys/Gabow_SCC/Gabow_GBG.thy b/thys/Gabow_SCC/Gabow_GBG.thy
--- a/thys/Gabow_SCC/Gabow_GBG.thy
+++ b/thys/Gabow_SCC/Gabow_GBG.thy
@@ -1,2101 +1,2102 @@
 section \<open>Lasso Finding Algorithm for Generalized B\"uchi Graphs \label{sec:gbg}\<close>
 theory Gabow_GBG
 imports 
   Gabow_Skeleton 
   CAVA_Automata.Lasso
   Find_Path
 begin
 
 (* TODO: convenience locale, consider merging this with invariants *)
 locale igb_fr_graph = 
   igb_graph G + fr_graph G
   for G :: "('Q,'more) igb_graph_rec_scheme"
 
 lemma igb_fr_graphI:
   assumes "igb_graph G"
   assumes "finite ((g_E G)\<^sup>* `` g_V0 G)"
   shows "igb_fr_graph G"
 proof -
   interpret igb_graph G by fact
   show ?thesis using assms(2) by unfold_locales
 qed
 
 text \<open>
   We implement an algorithm that computes witnesses for the 
   non-emptiness of Generalized B\"uchi Graphs (GBG).
 \<close>
 
 section \<open>Specification\<close>
 context igb_graph
 begin
   definition ce_correct 
     \<comment> \<open>Specifies a correct counter-example\<close>
     where
     "ce_correct Vr Vl \<equiv> (\<exists>pr pl. 
         Vr \<subseteq> E\<^sup>*``V0 \<and> Vl \<subseteq> E\<^sup>*``V0 \<comment> \<open>Only reachable nodes are covered\<close>
       \<and> set pr\<subseteq>Vr \<and> set pl\<subseteq>Vl     \<comment> \<open>The paths are inside the specified sets\<close>
       \<and> Vl\<times>Vl \<subseteq> (E \<inter> Vl\<times>Vl)\<^sup>*      \<comment> \<open>\<open>Vl\<close> is mutually connected\<close>
       \<and> Vl\<times>Vl \<inter> E \<noteq> {}            \<comment> \<open>\<open>Vl\<close> is non-trivial\<close>
       \<and> is_lasso_prpl (pr,pl))    \<comment> \<open>Paths form a lasso\<close>
     "     
 
   definition find_ce_spec :: "('Q set \<times> 'Q set) option nres" where
     "find_ce_spec \<equiv> SPEC (\<lambda>r. case r of
       None \<Rightarrow> (\<forall>prpl. \<not>is_lasso_prpl prpl)
     | Some (Vr,Vl) \<Rightarrow> ce_correct Vr Vl
     )"
 
   definition find_lasso_spec :: "('Q list \<times> 'Q list) option nres" where
     "find_lasso_spec \<equiv> SPEC (\<lambda>r. case r of
       None \<Rightarrow> (\<forall>prpl. \<not>is_lasso_prpl prpl)
     | Some prpl \<Rightarrow> is_lasso_prpl prpl
     )"
 
 end
 
 section \<open>Invariant Extension\<close>
 
 text \<open>Extension of the outer invariant:\<close>
 context igb_fr_graph
 begin
   definition no_acc_over
     \<comment> \<open>Specifies that there is no accepting cycle touching a set of nodes\<close>
     where
     "no_acc_over D \<equiv> \<not>(\<exists>v\<in>D. \<exists>pl. pl\<noteq>[] \<and> path E v pl v \<and> 
     (\<forall>i<num_acc. \<exists>q\<in>set pl. i\<in>acc q))"
 
   definition "fgl_outer_invar_ext \<equiv> \<lambda>it (brk,D). 
     case brk of None \<Rightarrow> no_acc_over D | Some (Vr,Vl) \<Rightarrow> ce_correct Vr Vl"
 
   definition "fgl_outer_invar \<equiv> \<lambda>it (brk,D). case brk of 
     None \<Rightarrow> outer_invar it D \<and> no_acc_over D
   | Some (Vr,Vl) \<Rightarrow> ce_correct Vr Vl"
   
 end
 
 text \<open>Extension of the inner invariant:\<close>
 locale fgl_invar_loc = 
   invar_loc G v0 D0 p D pE 
   + igb_graph G
   for G :: "('Q, 'more) igb_graph_rec_scheme"
   and v0 D0 and brk :: "('Q set \<times> 'Q set) option" and p D pE +
   assumes no_acc: "brk=None \<Longrightarrow> \<not>(\<exists>v pl. pl\<noteq>[] \<and> path lvE v pl v \<and> 
     (\<forall>i<num_acc. \<exists>q\<in>set pl. i\<in>acc q))" \<comment> \<open>No accepting cycle over 
       visited edges\<close>
   assumes acc: "brk=Some (Vr,Vl) \<Longrightarrow> ce_correct Vr Vl"
 begin
   lemma locale_this: "fgl_invar_loc G v0 D0 brk p D pE"
     by unfold_locales
   lemma invar_loc_this: "invar_loc G v0 D0 p D pE" by unfold_locales
   lemma eas_gba_graph_this: "igb_graph G" by unfold_locales
 end
 
 definition (in igb_graph) "fgl_invar v0 D0 \<equiv> 
   \<lambda>(brk, p, D, pE). fgl_invar_loc G v0 D0 brk p D pE"
 
 section \<open>Definition of the Lasso-Finding Algorithm\<close>
 
 context igb_fr_graph
 begin
   definition find_ce :: "('Q set \<times> 'Q set) option nres" where
     "find_ce \<equiv> do {
       let D = {};
       (brk,_)\<leftarrow>FOREACHci fgl_outer_invar V0 
         (\<lambda>(brk,_). brk=None) 
         (\<lambda>v0 (brk,D0). do {
           if v0\<notin>D0 then do {
             let s = (None,initial v0 D0);
 
             (brk,p,D,pE) \<leftarrow> WHILEIT (fgl_invar v0 D0)
               (\<lambda>(brk,p,D,pE). brk=None \<and> p \<noteq> []) (\<lambda>(_,p,D,pE). 
             do {
               \<comment> \<open>Select edge from end of path\<close>
               (vo,(p,D,pE)) \<leftarrow> select_edge (p,D,pE);
 
               ASSERT (p\<noteq>[]);
               case vo of 
                 Some v \<Rightarrow> do {
                   if v \<in> \<Union>(set p) then do {
                     \<comment> \<open>Collapse\<close>
                     let (p,D,pE) = collapse v (p,D,pE);
 
                     ASSERT (p\<noteq>[]);
 
                     if \<forall>i<num_acc. \<exists>q\<in>last p. i\<in>acc q then
                       RETURN (Some (\<Union>(set (butlast p)),last p),p,D,pE)
                     else
                       RETURN (None,p,D,pE)
                   } else if v\<notin>D then do {
                     \<comment> \<open>Edge to new node. Append to path\<close>
                     RETURN (None,push v (p,D,pE))
                   } else RETURN (None,p,D,pE)
                 }
               | None \<Rightarrow> do {
                   \<comment> \<open>No more outgoing edges from current node on path\<close>
                   ASSERT (pE \<inter> last p \<times> UNIV = {});
                   RETURN (None,pop (p,D,pE))
                 }
             }) s;
             ASSERT (brk=None \<longrightarrow> (p=[] \<and> pE={}));
             RETURN (brk,D)
           } else 
             RETURN (brk,D0)
       }) (None,D);
       RETURN brk
     }"
 end
 
 section \<open>Invariant Preservation\<close>
 
 
 context igb_fr_graph
 begin
 
   definition "fgl_invar_part \<equiv> \<lambda>(brk, p, D, pE). 
     fgl_invar_loc_axioms G brk p D pE"
 
   lemma fgl_outer_invarI[intro?]:
     "\<lbrakk>
       brk=None \<Longrightarrow> outer_invar it D; 
       \<lbrakk>brk=None \<Longrightarrow> outer_invar it D\<rbrakk> \<Longrightarrow> fgl_outer_invar_ext it (brk,D)\<rbrakk> 
       \<Longrightarrow> fgl_outer_invar it (brk,D)"
     unfolding outer_invar_def fgl_outer_invar_ext_def fgl_outer_invar_def
     apply (auto split: prod.splits option.splits)
     done
 
   lemma fgl_invarI[intro?]:
     "\<lbrakk> invar v0 D0 PDPE; 
        invar v0 D0 PDPE \<Longrightarrow> fgl_invar_part (B,PDPE)\<rbrakk> 
      \<Longrightarrow> fgl_invar v0 D0 (B,PDPE)"
     unfolding invar_def fgl_invar_part_def fgl_invar_def
     apply (simp split: prod.split_asm)
     apply intro_locales
     apply (simp add: invar_loc_def)
     apply assumption
     done
 
 
   lemma fgl_invar_initial: 
     assumes OINV: "fgl_outer_invar it (None,D0)"
     assumes A: "v0\<in>it" "v0\<notin>D0"
     shows "fgl_invar_part (None, initial v0 D0)"
   proof -
     from OINV interpret outer_invar_loc G it D0 
       by (simp add: fgl_outer_invar_def outer_invar_def)
 
     from OINV have no_acc: "no_acc_over D0"
       by (simp add: fgl_outer_invar_def fgl_outer_invar_ext_def)
 
     {
       fix v pl
 
       assume "pl \<noteq> []" and P: "path (vE [{v0}] D0 (E \<inter> {v0} \<times> UNIV)) v pl v"
       hence 1: "v\<in>D0"
         by (cases pl) (auto simp: path_cons_conv vE_def touched_def)
       have 2: "path E v pl v" using path_mono[OF vE_ss_E P] .
       note 1 2
     } note AUX1=this
 
 
     show ?thesis
       unfolding fgl_invar_part_def
       apply (simp split: prod.splits add: initial_def)
       apply unfold_locales
       using \<open>v0\<notin>D0\<close>
       using AUX1 no_acc unfolding no_acc_over_def apply blast
       by simp
   qed
 
   lemma fgl_invar_pop:
     assumes INV: "fgl_invar v0 D0 (None,p,D,pE)"
     assumes INV': "invar v0 D0 (pop (p,D,pE))"
     assumes NE[simp]: "p\<noteq>[]"
     assumes NO': "pE \<inter> last p \<times> UNIV = {}"
     shows "fgl_invar_part (None, pop (p,D,pE))"
   proof -
     from INV interpret fgl_invar_loc G v0 D0 None p D pE 
       by (simp add: fgl_invar_def)
 
     show ?thesis
       apply (unfold fgl_invar_part_def pop_def)
       apply (simp split: prod.splits)
       apply unfold_locales
       unfolding vE_pop[OF NE]
 
       using no_acc apply auto []
       apply simp
       done
   qed
 
   lemma fgl_invar_collapse_ce_aux:
     assumes INV: "invar v0 D0 (p, D, pE)"
     assumes NE[simp]: "p\<noteq>[]"
     assumes NONTRIV: "vE p D pE \<inter> (last p \<times> last p) \<noteq> {}"
     assumes ACC: "\<forall>i<num_acc. \<exists>q\<in>last p. i\<in>acc q"
     shows "fgl_invar_part (Some (\<Union>(set (butlast p)), last p), p, D, pE)"
   proof -
     from INV interpret invar_loc G v0 D0 p D pE by (simp add: invar_def)
     txt \<open>The last collapsed node on the path contains states from all 
       accepting sets.
       As it is strongly connected and reachable, we get a counter-example. 
       Here, we explicitely construct the lasso.\<close>
 
     let ?Er = "E \<inter> (\<Union>(set (butlast p)) \<times> UNIV)"
 
     txt \<open>We choose a node in the last Cnode, that is reachable only using
       former Cnodes.\<close>
 
     obtain w where "(v0,w)\<in>?Er\<^sup>*" "w\<in>last p"
     proof cases
       assume "length p = 1"
       hence "v0\<in>last p"
         using root_v0 
         by (cases p) auto
       thus thesis by (auto intro: that)
     next
       assume "length p\<noteq>1"
       hence "length p > 1" by (cases p) auto
       hence "Suc (length p - 2) < length p" by auto
       from p_connected'[OF this] obtain u v where
         UIP: "u\<in>p!(length p - 2)" and VIP: "v\<in>p!(length p - 1)" and "(u,v)\<in>lvE"
         using \<open>length p > 1\<close> by auto
       from root_v0 have V0IP: "v0\<in>p!0" by (cases p) auto
       
       from VIP have "v\<in>last p" by (cases p rule: rev_cases) auto
 
       from pathI[OF V0IP UIP] \<open>length p > 1\<close> have 
         "(v0,u)\<in>(lvE \<inter> \<Union>(set (butlast p)) \<times> \<Union>(set (butlast p)))\<^sup>*"
         (is "_ \<in> \<dots>\<^sup>*")  
         by (simp add: path_seg_butlast)
       also have "\<dots> \<subseteq> ?Er" using lvE_ss_E by auto
       finally (rtrancl_mono_mp[rotated]) have "(v0,u)\<in>?Er\<^sup>*" .
       also note \<open>(u,v)\<in>lvE\<close> UIP hence "(u,v)\<in>?Er" using lvE_ss_E \<open>length p > 1\<close> 
         apply (auto simp: Bex_def in_set_conv_nth)
         by (metis One_nat_def Suc_lessE \<open>Suc (length p - 2) < length p\<close> 
           diff_Suc_1 length_butlast nth_butlast)
       finally show ?thesis by (rule that) fact 
     qed
     then obtain "pr" where 
       P_REACH: "path E v0 pr w" and 
       R_SS: "set pr \<subseteq> \<Union>(set (butlast p))"
       apply -
       apply (erule rtrancl_is_path)
       apply (frule path_nodes_edges)
       apply (auto 
         dest!: order_trans[OF _ image_Int_subset] 
         dest: path_mono[of _ E, rotated])
       done
 
     have [simp]: "last p = p!(length p - 1)" by (cases p rule: rev_cases) auto
 
     txt \<open>From that node, we construct a lasso by inductively appending a path
       for each accepting set\<close>
     {
       fix na
       assume na_def: "na = num_acc"
 
       have "\<exists>pl. pl\<noteq>[] 
         \<and> path (lvE \<inter> last p\<times>last p) w pl w 
         \<and> (\<forall>i<num_acc. \<exists>q\<in>set pl. i\<in>acc q)"
         using ACC
         unfolding na_def[symmetric]
       proof (induction na)
         case 0 
 
         from NONTRIV obtain u v 
           where "(u,v)\<in>lvE \<inter> last p \<times> last p" "u\<in>last p" "v\<in>last p"
           by auto
         from cnode_connectedI \<open>w\<in>last p\<close> \<open>u\<in>last p\<close> 
         have "(w,u)\<in>(lvE \<inter> last p \<times> last p)\<^sup>*"
           by auto
         also note \<open>(u,v)\<in>lvE \<inter> last p \<times> last p\<close>
         also (rtrancl_into_trancl1) from cnode_connectedI \<open>v\<in>last p\<close> \<open>w\<in>last p\<close> 
         have "(v,w)\<in>(lvE \<inter> last p \<times> last p)\<^sup>*"
           by auto
         finally obtain pl where "pl\<noteq>[]" "path (lvE \<inter> last p \<times> last p) w pl w"
           by (rule trancl_is_path)
         thus ?case by auto
       next
         case (Suc n)
         from Suc.prems have "\<forall>i<n. \<exists>q\<in>last p. i\<in>acc q" by auto
         with Suc.IH obtain pl where IH: 
           "pl\<noteq>[]" 
           "path (lvE \<inter> last p \<times> last p) w pl w" 
           "\<forall>i<n. \<exists>q\<in>set pl. i\<in>acc q" 
           by blast
   
         from Suc.prems obtain v where "v\<in>last p" and "n\<in>acc v" by auto
         from cnode_connectedI \<open>w\<in>last p\<close> \<open>v\<in>last p\<close> 
         have "(w,v)\<in>(lvE \<inter> last p \<times> last p)\<^sup>*" by auto
         then obtain pl1 where P1: "path (lvE \<inter> last p \<times> last p) w pl1 v" 
           by (rule rtrancl_is_path)
         also from cnode_connectedI \<open>w\<in>last p\<close> \<open>v\<in>last p\<close> 
         have "(v,w)\<in>(lvE \<inter> last p \<times> last p)\<^sup>*" by auto
         then obtain pl2 where P2: "path (lvE \<inter> last p \<times> last p) v pl2 w"
           by (rule rtrancl_is_path)
         also (path_conc) note IH(2)
         finally (path_conc) have 
           P: "path (lvE \<inter> last p \<times> last p) w (pl1@pl2@pl) w"
           by simp
         moreover from IH(1) have "pl1@pl2@pl \<noteq> []" by simp
         moreover have "\<forall>i'<n. \<exists>q\<in>set (pl1@pl2@pl). i'\<in>acc q" using IH(3) by auto
         moreover have "v\<in>set (pl1@pl2@pl)" using P1 P2 P IH(1)
           apply (cases pl2, simp_all add: path_cons_conv path_conc_conv)
           apply (cases pl, simp_all add: path_cons_conv)
           apply (cases pl1, simp_all add: path_cons_conv)
           done
         with \<open>n\<in>acc v\<close> have "\<exists>q\<in>set (pl1@pl2@pl). n\<in>acc q" by auto
         ultimately show ?case
           apply (intro exI conjI)
           apply assumption+
           apply (auto elim: less_SucE)
           done
       qed
     }
     then obtain pl where pl: "pl\<noteq>[]" "path (lvE \<inter> last p\<times>last p) w pl w" 
       "\<forall>i<num_acc. \<exists>q\<in>set pl. i\<in>acc q" by blast
     hence "path E w pl w" and L_SS: "set pl \<subseteq> last p"
       apply -
       apply (frule path_mono[of _ E, rotated])
       using lvE_ss_E
       apply auto [2]
 
       apply (drule path_nodes_edges)
       apply (drule order_trans[OF _ image_Int_subset])
       apply auto []
       done
 
     have LASSO: "is_lasso_prpl (pr,pl)"
       unfolding is_lasso_prpl_def is_lasso_prpl_pre_def
       using \<open>path E w pl w\<close> P_REACH pl by auto
     
     from p_sc have "last p \<times> last p \<subseteq> (lvE \<inter> last p \<times> last p)\<^sup>*" by auto
     with lvE_ss_E have VL_CLOSED: "last p \<times> last p \<subseteq> (E \<inter> last p \<times> last p)\<^sup>*"
       apply (erule_tac order_trans)
       apply (rule rtrancl_mono)
       by blast
 
     have NONTRIV': "last p \<times> last p \<inter> E \<noteq> {}"
       by (metis Int_commute NONTRIV disjoint_mono lvE_ss_E subset_refl)
 
     from order_trans[OF path_touched touched_reachable]
     have LP_REACH: "last p \<subseteq> E\<^sup>*``V0" 
       and BLP_REACH: "\<Union>(set (butlast p)) \<subseteq> E\<^sup>*``V0"
       apply -
       apply (cases p rule: rev_cases)
       apply simp
       apply auto []
 
       apply (cases p rule: rev_cases)
       apply simp
       apply auto []
       done
       
     show ?thesis
       apply (simp add: fgl_invar_part_def)
       apply unfold_locales
       apply simp
 
       using LASSO R_SS L_SS VL_CLOSED NONTRIV' LP_REACH BLP_REACH
       unfolding ce_correct_def 
       apply simp 
       apply blast
       done
 
   qed
 
   lemma fgl_invar_collapse_ce:
     fixes u v
     assumes INV: "fgl_invar v0 D0 (None,p,D,pE)"
     defines "pE' \<equiv> pE - {(u,v)}"
     assumes CFMT: "(p',D',pE'') = collapse v (p,D,pE')"
     assumes INV': "invar v0 D0 (p',D',pE'')"
     assumes NE[simp]: "p\<noteq>[]"
     assumes E: "(u,v)\<in>pE" and "u\<in>last p"
     assumes BACK: "v\<in>\<Union>(set p)"
     assumes ACC: "\<forall>i<num_acc. \<exists>q\<in>last p'. i\<in>acc q"
     defines i_def: "i \<equiv> idx_of p v"
     shows "fgl_invar_part (
       Some (\<Union>(set (butlast p')), last p'), 
       collapse v (p,D,pE'))"
   proof -
 
     from CFMT have p'_def: "p' = collapse_aux p i" and [simp]: "D'=D" "pE''=pE'"
       by (simp_all add: collapse_def i_def)
 
     from INV interpret fgl_invar_loc G v0 D0 None p D pE 
       by (simp add: fgl_invar_def)
 
     from idx_of_props[OF BACK] have "i<length p" and "v\<in>p!i" 
       by (simp_all add: i_def)
 
     have "u\<in>last p'" 
       using \<open>u\<in>last p\<close> \<open>i<length p\<close> 
       unfolding p'_def collapse_aux_def
       apply (simp add: last_drop last_snoc)
       by (metis Misc.last_in_set drop_eq_Nil last_drop not_le)
     moreover have "v\<in>last p'" 
       using \<open>v\<in>p!i\<close> \<open>i<length p\<close> 
       unfolding p'_def collapse_aux_def
       by (metis UnionI append_Nil Cons_nth_drop_Suc in_set_conv_decomp last_snoc)
     ultimately have "vE p' D pE' \<inter> last p' \<times> last p' \<noteq> {}" 
       unfolding p'_def pE'_def by (auto simp: E)
     
     have "p'\<noteq>[]" by (simp add: p'_def collapse_aux_def)
 
     have [simp]: "collapse v (p,D,pE') = (p',D,pE')" 
       unfolding collapse_def p'_def i_def
       by simp
 
     show ?thesis
       apply simp
       apply (rule fgl_invar_collapse_ce_aux) 
       using INV' apply simp
       apply fact+
       done
   qed
 
   lemma fgl_invar_collapse_nce:
     fixes u v
     assumes INV: "fgl_invar v0 D0 (None,p,D,pE)"
     defines "pE' \<equiv> pE - {(u,v)}"
     assumes CFMT: "(p',D',pE'') = collapse v (p,D,pE')"
     assumes INV': "invar v0 D0 (p',D',pE'')"
     assumes NE[simp]: "p\<noteq>[]"
     assumes E: "(u,v)\<in>pE" and "u\<in>last p"
     assumes BACK: "v\<in>\<Union>(set p)"
     assumes NACC: "j<num_acc" "\<forall>q\<in>last p'. j\<notin>acc q"
     defines "i \<equiv> idx_of p v"
     shows "fgl_invar_part (None, collapse v (p,D,pE'))"
   proof -
     from CFMT have p'_def: "p' = collapse_aux p i" and [simp]: "D'=D" "pE''=pE'"
       by (simp_all add: collapse_def i_def)
 
     have [simp]: "collapse v (p,D,pE') = (p',D,pE')" 
       by (simp add: collapse_def p'_def i_def)
 
     from INV interpret fgl_invar_loc G v0 D0 None p D pE 
       by (simp add: fgl_invar_def)
 
     from INV' interpret inv': invar_loc G v0 D0 p' D pE' by (simp add: invar_def)
 
     define vE' where "vE' = vE p' D pE'"
 
     have vE'_alt: "vE' = insert (u,v) lvE"
       by (simp add: vE'_def p'_def pE'_def E)
 
     from idx_of_props[OF BACK] have "i<length p" and "v\<in>p!i" 
       by (simp_all add: i_def)
 
     have "u\<in>last p'" 
       using \<open>u\<in>last p\<close> \<open>i<length p\<close>
       unfolding p'_def collapse_aux_def
       apply (simp add: last_drop last_snoc)
       by (metis Misc.last_in_set drop_eq_Nil last_drop leD)
     moreover have "v\<in>last p'" 
       using \<open>v\<in>p!i\<close> \<open>i<length p\<close> 
       unfolding p'_def collapse_aux_def
       by (metis UnionI append_Nil Cons_nth_drop_Suc in_set_conv_decomp last_snoc)
     ultimately have "vE' \<inter> last p' \<times> last p' \<noteq> {}" 
       unfolding vE'_alt by (auto)
     
     have "p'\<noteq>[]" by (simp add: p'_def collapse_aux_def)
 
     {
       txt \<open>
         We show that no visited strongly connected component contains states
         from all acceptance sets.\<close>
       fix w pl
       txt \<open>For this, we chose a non-trivial loop inside the visited edges\<close>
       assume P: "path vE' w pl w" and NT: "pl\<noteq>[]"
       txt \<open>And show that there is one acceptance set disjoint with the nodes
         of the loop\<close>
       have "\<exists>i<num_acc. \<forall>q\<in>set pl. i\<notin>acc q"
       proof cases
         assume "set pl \<inter> last p' = {}" 
           \<comment> \<open>Case: The loop is outside the last Cnode\<close>
         with path_restrict[OF P] \<open>u\<in>last p'\<close> \<open>v\<in>last p'\<close> have "path lvE w pl w"
           apply -
           apply (drule path_mono[of _ lvE, rotated])
           unfolding vE'_alt
           by auto
         with no_acc NT show ?thesis by auto
       next
         assume "set pl \<inter> last p' \<noteq> {}" 
           \<comment> \<open>Case: The loop touches the last Cnode\<close>
         txt \<open>Then, the loop must be completely inside the last CNode\<close>
         from inv'.loop_in_lastnode[folded vE'_def, OF P \<open>p'\<noteq>[]\<close> this] 
         have "w\<in>last p'" "set pl \<subseteq> last p'" .
         with NACC show ?thesis by blast
       qed
     } note AUX_no_acc = this
 
     show ?thesis
       apply (simp add: fgl_invar_part_def)
       apply unfold_locales
       using AUX_no_acc[unfolded vE'_def] apply auto []
       
       apply simp
       done
   qed
 
   lemma collapse_ne: "([],D',pE') \<noteq> collapse v (p,D,pE)"
     by (simp add: collapse_def collapse_aux_def Let_def)
 
   lemma fgl_invar_push:
     assumes INV: "fgl_invar v0 D0 (None,p,D,pE)"
     assumes BRK[simp]: "brk=None" 
     assumes NE[simp]: "p\<noteq>[]"
     assumes E: "(u,v)\<in>pE" and UIL: "u\<in>last p"
     assumes VNE: "v\<notin>\<Union>(set p)" "v\<notin>D"
     assumes INV': "invar v0 D0 (push v (p,D,pE - {(u,v)}))"
     shows "fgl_invar_part (None, push v (p,D,pE - {(u,v)}))"
   proof -
     from INV interpret fgl_invar_loc G v0 D0 None p D pE 
       by (simp add: fgl_invar_def)
 
     define pE' where "pE' = (pE - {(u,v)} \<union> E\<inter>{v}\<times>UNIV)"
 
     have [simp]: "push v (p,D,pE - {(u,v)}) = (p@[{v}],D,pE')"
       by (simp add: push_def pE'_def)
 
     from INV' interpret inv': invar_loc G v0 D0 "(p@[{v}])" D "pE'"
       by (simp add: invar_def)
 
     note defs_fold = vE_push[OF E UIL VNE, folded pE'_def]
 
     {
       txt \<open>We show that there still is no loop that contains all accepting
         nodes. For this, we choose some loop.\<close>
       fix w pl
       assume P: "path (insert (u,v) lvE) w pl w" and [simp]: "pl\<noteq>[]"
       have "\<exists>i<num_acc. \<forall>q\<in>set pl. i\<notin>acc q" 
       proof cases
         assume "v\<in>set pl" \<comment> \<open>Case: The newly pushed last cnode is on the loop\<close>
         txt \<open>Then the loop is entirely on the last cnode\<close>
         with inv'.loop_in_lastnode[unfolded defs_fold, OF P]
         have [simp]: "w=v" and SPL: "set pl = {v}" by auto
         txt \<open>However, we then either have that the last cnode is contained in
           the last but one cnode, or that there is a visited edge inside the
           last cnode.\<close>
         from P SPL have "u=v \<or> (v,v)\<in>lvE" 
           apply (cases pl) apply (auto simp: path_cons_conv)
           apply (case_tac list)
           apply (auto simp: path_cons_conv)
           done
         txt \<open>Both leads to a contradiction\<close>
         hence False proof
           assume "u=v" \<comment> \<open>This is impossible, as @{text "u"} was on the 
             original path, but @{text "v"} was not\<close>
           with UIL VNE show False by auto
         next
           assume "(v,v)\<in>lvE" \<comment> \<open>This is impossible, as all visited edges are
             from touched nodes, but @{text "v"} was untouched\<close>
           with vE_touched VNE show False unfolding touched_def by auto
         qed
         thus ?thesis ..
       next
         assume A: "v\<notin>set pl" 
           \<comment> \<open>Case: The newly pushed last cnode is not on the loop\<close>
         txt \<open>Then, the path lays inside the old visited edges\<close>
         have "path lvE w pl w" 
         proof -
           have "w\<in>set pl" using P by (cases pl) (auto simp: path_cons_conv)
           with A show ?thesis using path_restrict[OF P]
             apply -
             apply (drule path_mono[of _ lvE, rotated])
             apply (cases pl, auto) []
             
             apply assumption
             done
         qed
         txt \<open>And thus, the proposition follows from the invariant on the old
           state\<close>
         with no_acc show ?thesis 
           apply simp
           using \<open>pl\<noteq>[]\<close> 
           by blast
       qed
     } note AUX_no_acc = this
 
     show ?thesis
       unfolding fgl_invar_part_def
       apply simp
       apply unfold_locales
       unfolding defs_fold
 
       using AUX_no_acc apply auto []
       
       apply simp
       done
   qed
 
 
   lemma fgl_invar_skip:
     assumes INV: "fgl_invar v0 D0 (None,p,D,pE)"
     assumes BRK[simp]: "brk=None" 
     assumes NE[simp]: "p\<noteq>[]"
     assumes E: "(u,v)\<in>pE" and UIL: "u\<in>last p"
     assumes VID: "v\<in>D"
     assumes INV': "invar v0 D0 (p, D, (pE - {(u,v)}))"
     shows "fgl_invar_part (None, p, D, (pE - {(u,v)}))"
   proof -
     from INV interpret fgl_invar_loc G v0 D0 None p D pE 
       by (simp add: fgl_invar_def)
     from INV' interpret inv': invar_loc G v0 D0 p D "(pE - {(u,v)})" 
       by (simp add: invar_def)
 
     {
       txt \<open>We show that there still is no loop that contains all accepting
         nodes. For this, we choose some loop.\<close>
       fix w pl
       assume P: "path (insert (u,v) lvE) w pl w" and [simp]: "pl\<noteq>[]"
       from P have "\<exists>i<num_acc. \<forall>q\<in>set pl. i\<notin>acc q" 
       proof (cases rule: path_edge_rev_cases)
         case no_use \<comment> \<open>Case: The loop does not use the new edge\<close>
         txt \<open>The proposition follows from the invariant for the old state\<close>
         with no_acc show ?thesis 
           apply simp
           using \<open>pl\<noteq>[]\<close> 
           by blast
       next
         case (split p1 p2) \<comment> \<open>Case: The loop uses the new edge\<close>
         txt \<open>As done is closed under transitions, the nodes of the edge have
           already been visited\<close>
         from split(2) D_closed_vE_rtrancl 
         have WID: "w\<in>D" 
           using VID by (auto dest!: path_is_rtrancl)
         from split(1) WID D_closed_vE_rtrancl have "u\<in>D"
           apply (cases rule: path_edge_cases)
           apply (auto dest!: path_is_rtrancl)
           done
         txt \<open>Which is a contradition to the assumptions\<close>
         with UIL p_not_D have False by (cases p rule: rev_cases) auto
         thus ?thesis ..
       qed
     } note AUX_no_acc = this
 
 
     show ?thesis 
       apply (simp add: fgl_invar_part_def)
       apply unfold_locales
       unfolding vE_remove[OF NE E]
 
       using AUX_no_acc apply auto []
 
       apply simp
       done
 
   qed
 
   lemma fgl_outer_invar_initial: 
     "outer_invar V0 {} \<Longrightarrow> fgl_outer_invar_ext V0 (None, {})"
     unfolding fgl_outer_invar_ext_def
     apply (simp add: no_acc_over_def)
     done
 
   lemma fgl_outer_invar_brk:
     assumes INV: "fgl_invar v0 D0 (Some (Vr,Vl),p,D,pE)"
     shows "fgl_outer_invar_ext anyIt (Some (Vr,Vl), anyD)"
   proof -
     from INV interpret fgl_invar_loc G v0 D0 "Some (Vr,Vl)" p D pE
       by (simp add: fgl_invar_def)
 
     from acc show ?thesis by (simp add: fgl_outer_invar_ext_def)
   qed
 
   lemma fgl_outer_invar_newnode_nobrk:
     assumes A: "v0\<notin>D0" "v0\<in>it" 
     assumes OINV: "fgl_outer_invar it (None,D0)"
     assumes INV: "fgl_invar v0 D0 (None,[],D',pE)"
     shows "fgl_outer_invar_ext (it-{v0}) (None,D')"
   proof -
     from OINV interpret outer_invar_loc G it D0 
       unfolding fgl_outer_invar_def outer_invar_def by simp
 
     from INV interpret inv: fgl_invar_loc G v0 D0 None "[]" D' pE 
       unfolding fgl_invar_def by simp
 
     from inv.pE_fin have [simp]: "pE = {}" by simp
 
     { fix v pl
       assume A: "v\<in>D'" "path E v pl v"
       have "path (E \<inter> D' \<times> UNIV) v pl v"
         apply (rule path_mono[OF _ path_restrict_closed[OF inv.D_closed A]])
         by auto
     } note AUX1=this
 
     show ?thesis
       unfolding fgl_outer_invar_ext_def
       apply simp
       using inv.no_acc AUX1 
       apply (auto simp add: vE_def touched_def no_acc_over_def) []
       done
   qed
 
   lemma fgl_outer_invar_newnode:
     assumes A: "v0\<notin>D0" "v0\<in>it" 
     assumes OINV: "fgl_outer_invar it (None,D0)"
     assumes INV: "fgl_invar v0 D0 (brk,p,D',pE)"
     assumes CASES: "(\<exists>Vr Vl. brk = Some (Vr, Vl)) \<or> p = []"
     shows "fgl_outer_invar_ext (it-{v0}) (brk,D')"
     using CASES
     apply (elim disjE1)
     using fgl_outer_invar_brk[of v0 D0 _ _ p D' pE] INV 
     apply - 
     apply (auto, assumption) []
     using fgl_outer_invar_newnode_nobrk[OF A] OINV INV apply auto []
     done
 
   lemma fgl_outer_invar_Dnode:
     assumes "fgl_outer_invar it (None, D)" "v\<in>D"
     shows "fgl_outer_invar_ext (it - {v}) (None, D)"
     using assms
     by (auto simp: fgl_outer_invar_def fgl_outer_invar_ext_def)
 
   
   lemma fgl_fin_no_lasso:
     assumes A: "fgl_outer_invar {} (None, D)"
     assumes B: "is_lasso_prpl prpl"
     shows "False"
   proof -
     obtain "pr" pl where [simp]: "prpl = (pr,pl)" by (cases prpl)
     from A have NA: "no_acc_over D" 
       by (simp add: fgl_outer_invar_def fgl_outer_invar_ext_def)
 
     from A have "outer_invar {} D" by (simp add: fgl_outer_invar_def)
     with fin_outer_D_is_reachable have [simp]: "D=E\<^sup>*``V0" by simp
 
     from NA B show False
       apply (simp add: no_acc_over_def is_lasso_prpl_def is_lasso_prpl_pre_def)
       apply clarsimp
       apply (blast dest: path_is_rtrancl)
       done
   qed
 
   lemma fgl_fin_lasso:
     assumes A: "fgl_outer_invar it (Some (Vr,Vl), D)"
     shows "ce_correct Vr Vl"
     using A by (simp add: fgl_outer_invar_def fgl_outer_invar_ext_def)
 
 
   lemmas fgl_invar_preserve = 
     fgl_invar_initial fgl_invar_push fgl_invar_pop 
     fgl_invar_collapse_ce fgl_invar_collapse_nce fgl_invar_skip
     fgl_outer_invar_newnode fgl_outer_invar_Dnode
     invar_initial outer_invar_initial fgl_invar_initial fgl_outer_invar_initial
     fgl_fin_no_lasso fgl_fin_lasso
 
 end
 
 section \<open>Main Correctness Proof\<close>
 
 context igb_fr_graph
 begin
   lemma outer_invar_from_fgl_invarI: 
     "fgl_outer_invar it (None,D) \<Longrightarrow> outer_invar it D"
     unfolding fgl_outer_invar_def outer_invar_def
     by (simp split: prod.splits)
 
   lemma invar_from_fgl_invarI: "fgl_invar v0 D0 (B,PDPE) \<Longrightarrow> invar v0 D0 PDPE"
     unfolding fgl_invar_def invar_def
     apply (simp split: prod.splits)
     unfolding fgl_invar_loc_def by simp
    
   theorem find_ce_correct: "find_ce \<le> find_ce_spec"
   proof -
     note [simp del] = Union_iff
 
     show ?thesis
       unfolding find_ce_def find_ce_spec_def select_edge_def select_def
       apply (refine_rcg
         WHILEIT_rule[where R="inv_image (abs_wf_rel v0) snd" for v0]
         refine_vcg 
       )
       
       using [[goals_limit = 5]]
 
       apply (vc_solve
         rec: fgl_invarI fgl_outer_invarI
         intro: invar_from_fgl_invarI outer_invar_from_fgl_invarI
         dest!: sym[of "collapse a b" for a b]
         simp: collapse_ne
         simp: pE_fin'[OF invar_from_fgl_invarI] finite_V0
         solve: invar_preserve 
         solve: asm_rl[of "_ \<inter> _ = {}"]
         solve: fgl_invar_preserve)
       done
   qed
 end
 
 section "Emptiness Check"
 text \<open>Using the lasso-finding algorithm, we can define an emptiness check\<close>
 
 context igb_fr_graph
 begin
   definition "abs_is_empty \<equiv> do {
     ce \<leftarrow> find_ce;
     RETURN (ce = None)
     }"
 
   theorem abs_is_empty_correct: 
     "abs_is_empty \<le> SPEC (\<lambda>res. res \<longleftrightarrow> (\<forall>r. \<not>is_acc_run r))"
     unfolding abs_is_empty_def
     apply (refine_rcg refine_vcg 
       order_trans[OF find_ce_correct, unfolded find_ce_spec_def])
     unfolding ce_correct_def
     using lasso_accepted accepted_lasso
     apply (clarsimp split: option.splits)
     apply (metis is_lasso_prpl_of_lasso surj_pair)
     by (metis is_lasso_prpl_conv)
 
   definition "abs_is_empty_ce \<equiv> do {
     ce \<leftarrow> find_ce;
     case ce of
       None \<Rightarrow> RETURN None
     | Some (Vr,Vl) \<Rightarrow> do {
         ASSERT (\<exists>pr pl. set pr \<subseteq> Vr \<and> set pl \<subseteq> Vl \<and> Vl \<times> Vl \<subseteq> (E \<inter> Vl\<times>Vl)\<^sup>* 
           \<and> is_lasso_prpl (pr,pl));
         (pr,pl) \<leftarrow> SPEC (\<lambda>(pr,pl). 
            set pr \<subseteq> Vr 
           \<and> set pl \<subseteq> Vl 
           \<and> Vl \<times> Vl \<subseteq> (E \<inter> Vl\<times>Vl)\<^sup>*
           \<and> is_lasso_prpl (pr,pl));
         RETURN (Some (pr,pl))
       }
     }"
 
   theorem abs_is_empty_ce_correct: "abs_is_empty_ce \<le> SPEC (\<lambda>res. case res of
       None \<Rightarrow> (\<forall>r. \<not>is_acc_run r)
     | Some (pr,pl) \<Rightarrow> is_acc_run (pr\<frown>pl\<^sup>\<omega>)
     )"
     unfolding abs_is_empty_ce_def
     apply (refine_rcg refine_vcg 
       order_trans[OF find_ce_correct, unfolded find_ce_spec_def])
 
     apply (clarsimp_all simp: ce_correct_def)
 
     using accepted_lasso finite_reachableE_V0 apply (metis is_lasso_prpl_of_lasso surj_pair)
     apply blast
     apply (simp add: lasso_prpl_acc_run)
     done
 
 end
 
 section \<open>Refinement\<close>
 text \<open>
   In this section, we refine the lasso finding algorithm to use efficient
   data structures. First, we explicitely keep track of the set of acceptance
   classes for every c-node on the path. Second, we use Gabow's data structure
   to represent the path.
 \<close>
 
 subsection \<open>Addition of Explicit Accepting Sets\<close>
 text \<open>In a first step, we explicitely keep track of the current set of
   acceptance classes for every c-node on the path.\<close>
 
 type_synonym 'a abs_gstate = "nat set list \<times> 'a abs_state"
 type_synonym 'a ce = "('a set \<times> 'a set) option"
 type_synonym 'a abs_gostate = "'a ce \<times> 'a set"
 
 context igb_fr_graph
 begin
 
   definition gstate_invar :: "'Q abs_gstate \<Rightarrow> bool" where 
     "gstate_invar \<equiv> \<lambda>(a,p,D,pE). a = map (\<lambda>V. \<Union>(acc`V)) p"
 
   definition "gstate_rel \<equiv> br snd gstate_invar"
 
   lemma gstate_rel_sv[relator_props,simp,intro!]: "single_valued gstate_rel"
     by (simp add: gstate_rel_def)
 
   definition (in -) gcollapse_aux 
     :: "nat set list \<Rightarrow> 'a set list \<Rightarrow> nat \<Rightarrow> nat set list \<times> 'a set list"
     where "gcollapse_aux a p i \<equiv> 
       (take i a @ [\<Union>(set (drop i a))],take i p @ [\<Union>(set (drop i p))])"
 
   definition (in -) gcollapse :: "'a \<Rightarrow> 'a abs_gstate \<Rightarrow> 'a abs_gstate" 
     where "gcollapse v APDPE \<equiv> 
     let 
       (a,p,D,pE)=APDPE; 
       i=idx_of p v;
       (a,p) = gcollapse_aux a p i
     in (a,p,D,pE)"
 
   definition "gpush v s \<equiv> 
     let
       (a,s) = s
     in
       (a@[acc v],push v s)"
 
   definition "gpop s \<equiv>
     let (a,s) = s in (butlast a,pop s)"
 
   definition ginitial :: "'Q \<Rightarrow> 'Q abs_gostate \<Rightarrow> 'Q abs_gstate" 
     where "ginitial v0 s0 \<equiv> ([acc v0], initial v0 (snd s0))"
 
   definition goinitial :: "'Q abs_gostate" where "goinitial \<equiv> (None,{})"
   definition go_is_no_brk :: "'Q abs_gostate \<Rightarrow> bool" 
     where "go_is_no_brk s \<equiv> fst s = None"
   definition goD :: "'Q abs_gostate \<Rightarrow> 'Q set" where "goD s \<equiv> snd s"
   definition goBrk :: "'Q abs_gostate \<Rightarrow> 'Q ce" where "goBrk s \<equiv> fst s"
   definition gto_outer :: "'Q ce \<Rightarrow> 'Q abs_gstate \<Rightarrow> 'Q abs_gostate" 
     where "gto_outer brk s \<equiv> let (A,p,D,pE)=s in (brk,D)"
 
   definition "gselect_edge s \<equiv> do {
     let (a,s)=s; 
     (r,s)\<leftarrow>select_edge s;
     RETURN (r,a,s) 
   }"
 
   definition gfind_ce :: "('Q set \<times> 'Q set) option nres" where
     "gfind_ce \<equiv> do {
       let os = goinitial;
       os\<leftarrow>FOREACHci fgl_outer_invar V0 (go_is_no_brk) (\<lambda>v0 s0. do {
         if v0\<notin>goD s0 then do {
           let s = (None,ginitial v0 s0);
 
           (brk,a,p,D,pE) \<leftarrow> WHILEIT (\<lambda>(brk,a,s). fgl_invar v0 (goD s0) (brk,s))
             (\<lambda>(brk,a,p,D,pE). brk=None \<and> p \<noteq> []) (\<lambda>(_,a,p,D,pE). 
           do {
             \<comment> \<open>Select edge from end of path\<close>
             (vo,(a,p,D,pE)) \<leftarrow> gselect_edge (a,p,D,pE);
 
             ASSERT (p\<noteq>[]);
             case vo of 
               Some v \<Rightarrow> do {
                 if v \<in> \<Union>(set p) then do {
                   \<comment> \<open>Collapse\<close>
                   let (a,p,D,pE) = gcollapse v (a,p,D,pE);
 
                   ASSERT (p\<noteq>[]);
                   ASSERT (a\<noteq>[]);
 
                   if last a = {0..<num_acc} then
                     RETURN (Some (\<Union>(set (butlast p)),last p),a,p,D,pE)
                   else
                     RETURN (None,a,p,D,pE)
                 } else if v\<notin>D then do {
                   \<comment> \<open>Edge to new node. Append to path\<close>
                   RETURN (None,gpush v (a,p,D,pE))
                 } else RETURN (None,a,p,D,pE)
               }
             | None \<Rightarrow> do {
                 \<comment> \<open>No more outgoing edges from current node on path\<close>
                 ASSERT (pE \<inter> last p \<times> UNIV = {});
                 RETURN (None,gpop (a,p,D,pE))
               }
           }) s;
           ASSERT (brk=None \<longrightarrow> (p=[] \<and> pE={}));
           RETURN (gto_outer brk (a,p,D,pE))
         } else RETURN s0
     }) os;
     RETURN (goBrk os)
   }"
 
   lemma gcollapse_refine:
     "\<lbrakk>(v',v)\<in>Id; (s',s)\<in>gstate_rel\<rbrakk> 
       \<Longrightarrow> (gcollapse v' s',collapse v s)\<in>gstate_rel"
     unfolding gcollapse_def collapse_def collapse_aux_def gcollapse_aux_def 
     apply (simp add: gstate_rel_def br_def Let_def)
     unfolding gstate_invar_def[abs_def]
     apply (auto split: prod.splits simp: take_map drop_map)
     done
 
   lemma gpush_refine:
     "\<lbrakk>(v',v)\<in>Id; (s',s)\<in>gstate_rel\<rbrakk> \<Longrightarrow> (gpush v' s',push v s)\<in>gstate_rel"
     unfolding gpush_def push_def 
     apply (simp add: gstate_rel_def br_def)
     unfolding gstate_invar_def[abs_def]
     apply (auto split: prod.splits)
     done
 
   lemma gpop_refine:
     "\<lbrakk>(s',s)\<in>gstate_rel\<rbrakk> \<Longrightarrow> (gpop s',pop s)\<in>gstate_rel"
     unfolding gpop_def pop_def 
     apply (simp add: gstate_rel_def br_def)
     unfolding gstate_invar_def[abs_def]
     apply (auto split: prod.splits simp: map_butlast)
     done
 
   lemma ginitial_refine:
     "(ginitial x (None, b), initial x b) \<in> gstate_rel"
     unfolding ginitial_def gstate_rel_def br_def gstate_invar_def initial_def
     by auto
 
   lemma oinitial_b_refine: "((None,{}),(None,{}))\<in>Id\<times>\<^sub>rId" by simp
 
   lemma gselect_edge_refine: "\<lbrakk>(s',s)\<in>gstate_rel\<rbrakk> \<Longrightarrow> gselect_edge s' 
     \<le>\<Down>(\<langle>Id\<rangle>option_rel \<times>\<^sub>r gstate_rel) (select_edge s)"
     unfolding gselect_edge_def select_edge_def
     apply (simp add: pw_le_iff refine_pw_simps prod_rel_sv
       split: prod.splits option.splits)
 
     apply (auto simp: gstate_rel_def br_def gstate_invar_def)
     done
 
   lemma last_acc_impl:
     assumes "p\<noteq>[]"
     assumes "((a',p',D',pE'),(p,D,pE))\<in>gstate_rel"
     shows "(last a' = {0..<num_acc}) = (\<forall>i<num_acc. \<exists>q\<in>last p. i\<in>acc q)"
     using assms acc_bound unfolding gstate_rel_def br_def gstate_invar_def
     by (auto simp: last_map)
 
   lemma fglr_aux1:
     assumes V: "(v',v)\<in>Id" and S: "(s',s)\<in>gstate_rel" 
       and P: "\<And>a' p' D' pE' p D pE. ((a',p',D',pE'),(p,D,pE))\<in>gstate_rel 
       \<Longrightarrow> f' a' p' D' pE' \<le>\<Down>R (f p D pE)"
     shows "(let (a',p',D',pE') = gcollapse v' s' in f' a' p' D' pE') 
       \<le> \<Down>R (let (p,D,pE) = collapse v s in f p D pE)"
     apply (auto split: prod.splits)
     apply (rule P)
     using gcollapse_refine[OF V S]
     apply simp
     done
 
   lemma gstate_invar_empty: 
     "gstate_invar (a,[],D,pE) \<Longrightarrow> a=[]"
     "gstate_invar ([],p,D,pE) \<Longrightarrow> p=[]"
     by (auto simp add: gstate_invar_def)
 
   lemma find_ce_refine: "gfind_ce \<le>\<Down>Id find_ce"
     unfolding gfind_ce_def find_ce_def
     unfolding goinitial_def go_is_no_brk_def[abs_def] goD_def goBrk_def 
       gto_outer_def
     using [[goals_limit = 1]]
     apply (refine_rcg 
       gselect_edge_refine prod_relI[OF IdI gpop_refine]
       prod_relI[OF IdI gpush_refine]
       fglr_aux1 last_acc_impl oinitial_b_refine
       inj_on_id
     )
     apply refine_dref_type
     apply (simp_all add: ginitial_refine)
     apply (vc_solve (nopre) 
       solve: asm_rl 
       simp: gstate_rel_def br_def gstate_invar_empty)
     done
 end
 
 subsection \<open>Refinement to Gabow's Data Structure\<close>
 
 subsubsection \<open>Preliminaries\<close>
 definition Un_set_drop_impl :: "nat \<Rightarrow> 'a set list \<Rightarrow> 'a set nres"
   \<comment> \<open>Executable version of @{text "\<Union>set (drop i A)"}, using indexing to
   access @{text "A"}\<close>
   where "Un_set_drop_impl i A \<equiv> 
   do {
     (_,res) \<leftarrow> WHILET (\<lambda>(i,res). i < length A) (\<lambda>(i,res). do {
       ASSERT (i<length A);
       let res = A!i \<union> res;
       let i = i + 1;
       RETURN (i,res)
     }) (i,{});
     RETURN res
   }"
 
 lemma Un_set_drop_impl_correct: 
   "Un_set_drop_impl i A \<le> SPEC (\<lambda>r. r=\<Union>(set (drop i A)))"
   unfolding Un_set_drop_impl_def
   apply (refine_rcg 
     WHILET_rule[where I="\<lambda>(i',res). res=\<Union>(set ((drop i (take i' A)))) \<and> i\<le>i'" 
     and R="measure (\<lambda>(i',_). length A - i')"] 
     refine_vcg)
   apply (auto simp: take_Suc_conv_app_nth)
   done
 
 schematic_goal Un_set_drop_code_aux: 
   assumes [autoref_rules]: "(es_impl,{})\<in>\<langle>R\<rangle>Rs"
   assumes [autoref_rules]: "(un_impl,(\<union>))\<in>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs"
   shows "(?c,Un_set_drop_impl)\<in>nat_rel \<rightarrow> \<langle>\<langle>R\<rangle>Rs\<rangle>as_rel \<rightarrow> \<langle>\<langle>R\<rangle>Rs\<rangle>nres_rel"
   unfolding Un_set_drop_impl_def[abs_def]
   apply (autoref (trace, keep_goal))
   done
 concrete_definition Un_set_drop_code uses Un_set_drop_code_aux
 
 schematic_goal Un_set_drop_tr_aux: 
   "RETURN ?c \<le> Un_set_drop_code es_impl un_impl i A"
   unfolding Un_set_drop_code_def
   by refine_transfer
 concrete_definition Un_set_drop_tr for es_impl un_impl i A 
   uses Un_set_drop_tr_aux 
 
 lemma Un_set_drop_autoref[autoref_rules]: 
   assumes "GEN_OP es_impl {} (\<langle>R\<rangle>Rs)"
   assumes "GEN_OP un_impl (\<union>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
   shows "(\<lambda>i A. RETURN (Un_set_drop_tr es_impl un_impl i A),Un_set_drop_impl)
     \<in>nat_rel \<rightarrow> \<langle>\<langle>R\<rangle>Rs\<rangle>as_rel \<rightarrow> \<langle>\<langle>R\<rangle>Rs\<rangle>nres_rel"
   apply (intro fun_relI nres_relI)
   apply (rule order_trans[OF Un_set_drop_tr.refine])
   using Un_set_drop_code.refine[of es_impl Rs R un_impl, 
     param_fo, THEN nres_relD]
   using assms
   by simp
 
 
 subsubsection \<open>Actual Refinement\<close>
 
 type_synonym 'Q gGS = "nat set list \<times> 'Q GS"
 
 type_synonym 'Q goGS = "'Q ce \<times> 'Q oGS"
 
 context igb_graph
 begin
 
 definition gGS_invar :: "'Q gGS \<Rightarrow> bool"
   where "gGS_invar s \<equiv> 
   let (a,S,B,I,P) = s in 
     GS_invar (S,B,I,P)
     \<and> length a = length B
     \<and> \<Union>(set a) \<subseteq> {0..<num_acc}
   "
 
 definition gGS_\<alpha> :: "'Q gGS \<Rightarrow> 'Q abs_gstate"
   where "gGS_\<alpha> s \<equiv> let (a,s)=s in (a,GS.\<alpha> s)"
 
 definition "gGS_rel \<equiv> br gGS_\<alpha> gGS_invar"
 
 lemma gGS_rel_sv[relator_props,intro!,simp]: "single_valued gGS_rel"
   unfolding gGS_rel_def by auto
 
 
 definition goGS_invar :: "'Q goGS \<Rightarrow> bool" where
   "goGS_invar s \<equiv> let (brk,ogs)=s in brk=None \<longrightarrow> oGS_invar ogs"
 
 definition "goGS_\<alpha> s \<equiv> let (brk,ogs)=s in (brk,oGS_\<alpha> ogs)"
 
 definition "goGS_rel \<equiv> br goGS_\<alpha> goGS_invar"
 
 lemma goGS_rel_sv[relator_props,intro!,simp]: "single_valued goGS_rel"
   unfolding goGS_rel_def by auto
 
 end
 
 
 context igb_fr_graph
 begin
   lemma gGS_relE:
     assumes "(s',(a,p,D,pE))\<in>gGS_rel"
     obtains S' B' I' P' where "s'=(a,S',B',I',P')" 
       and "((S',B',I',P'),(p,D,pE))\<in>GS_rel" 
       and "length a = length B'"
       and "\<Union>(set a) \<subseteq> {0..<num_acc}"
     using assms
     apply (cases s')
     apply (simp add: gGS_rel_def br_def gGS_\<alpha>_def GS.\<alpha>_def)
     apply (rule that)
     apply (simp only:)
     apply (auto simp: GS_rel_def br_def gGS_invar_def GS.\<alpha>_def)
     done
 
 
   definition goinitial_impl :: "'Q goGS" 
     where "goinitial_impl \<equiv> (None,Map.empty)"
   lemma goinitial_impl_refine: "(goinitial_impl,goinitial)\<in>goGS_rel"
     by (auto 
       simp: goinitial_impl_def goinitial_def goGS_rel_def br_def 
       simp: goGS_\<alpha>_def goGS_invar_def oGS_\<alpha>_def oGS_invar_def)
 
   definition gto_outer_impl :: "'Q ce \<Rightarrow> 'Q gGS \<Rightarrow> 'Q goGS"
     where "gto_outer_impl brk s \<equiv> let (A,S,B,I,P)=s in (brk,I)"
 
   lemma gto_outer_refine:
     assumes A: "brk = None \<longrightarrow> (p=[] \<and> pE={})"
     assumes B: "(s, (A,p, D, pE)) \<in> gGS_rel"
     assumes C: "(brk',brk)\<in>Id"
     shows "(gto_outer_impl brk' s,gto_outer brk (A,p,D,pE))\<in>goGS_rel"
   proof (cases s)
     fix A S B I P
     assume [simp]: "s=(A,S,B,I,P)"
     show ?thesis
       using C
       apply (cases brk)
       using assms I_to_outer[of S B I P D]
       apply (auto 
         simp: goGS_rel_def br_def goGS_\<alpha>_def gto_outer_def 
               gto_outer_impl_def goGS_invar_def 
         simp: gGS_rel_def oGS_rel_def GS_rel_def gGS_\<alpha>_def gGS_invar_def 
               GS.\<alpha>_def) []
 
       using B apply (auto 
         simp: gto_outer_def gto_outer_impl_def
         simp: br_def goGS_rel_def goGS_invar_def goGS_\<alpha>_def oGS_\<alpha>_def
         simp: gGS_rel_def gGS_\<alpha>_def GS.\<alpha>_def GS.D_\<alpha>_def
       )
 
       done
   qed
 
   definition "gpush_impl v s \<equiv> let (a,s)=s in (a@[acc v], push_impl v s)"
 
 
   lemma gpush_impl_refine:
     assumes B: "(s',(a,p,D,pE))\<in>gGS_rel"
     assumes A: "(v',v)\<in>Id" 
     assumes PRE: "v' \<notin> \<Union>(set p)" "v' \<notin> D"
     shows "(gpush_impl v' s', gpush v (a,p,D,pE))\<in>gGS_rel"
   proof -
     from B obtain S' B' I' P' where [simp]: "s'=(a,S',B',I',P')" 
       and OSR: "((S',B',I',P'),(p,D,pE))\<in>GS_rel" and L: "length a = length B'" 
       and R: "\<Union>(set a) \<subseteq> {0..<num_acc}"
       by (rule gGS_relE)
     {
       fix S B I P S' B' I' P'
       assume "push_impl v (S, B, I, P) = (S', B', I', P')"
       hence "length B' = Suc (length B)" 
         by (auto simp add: push_impl_def GS.push_impl_def Let_def)  
     } note AUX1=this
 
     from push_refine[OF OSR A PRE] A L acc_bound R show ?thesis
       unfolding gpush_impl_def gpush_def
         gGS_rel_def gGS_invar_def gGS_\<alpha>_def GS_rel_def br_def
       apply (auto dest: AUX1)
       done
   qed
   
   definition gpop_impl :: "'Q gGS \<Rightarrow> 'Q gGS nres" 
     where "gpop_impl s \<equiv> do {
     let (a,s)=s;
     s\<leftarrow>pop_impl s;
     ASSERT (a\<noteq>[]);
     let a = butlast a;
     RETURN (a,s)
   }"
 
   lemma gpop_impl_refine:
     assumes A: "(s',(a,p,D,pE))\<in>gGS_rel"
     assumes PRE: "p \<noteq> []" "pE \<inter> last p \<times> UNIV = {}"
     shows "gpop_impl s' \<le> \<Down>gGS_rel (RETURN (gpop (a,p,D,pE)))"
   proof -
     from A obtain S' B' I' P' where [simp]: "s'=(a,S',B',I',P')" 
       and OSR: "((S',B',I',P'),(p,D,pE))\<in>GS_rel" and L: "length a = length B'"
       and R: "\<Union>(set a) \<subseteq> {0..<num_acc}"
       by (rule gGS_relE)
 
     from PRE OSR have [simp]: "a\<noteq>[]" using L
       by (auto simp add: GS_rel_def br_def GS.\<alpha>_def GS.p_\<alpha>_def)
 
     {
       fix S B I P S' B' I' P'
       assume "nofail (pop_impl ((S, B, I, P)::'a GS))"
         "inres (pop_impl ((S, B, I, P)::'a GS)) (S', B', I', P')"
       hence "length B' = length B - Suc 0"
         apply (simp add: pop_impl_def GS.pop_impl_def Let_def
           refine_pw_simps)
         apply auto
         done
     } note AUX1=this
 
     from A L show ?thesis
       unfolding gpop_impl_def gpop_def gGS_rel_def gGS_\<alpha>_def br_def
       apply (simp add: Let_def)
       using pop_refine[OF OSR PRE]
       apply (simp add: pw_le_iff refine_pw_simps split: prod.splits)
       unfolding gGS_rel_def gGS_invar_def gGS_\<alpha>_def GS_rel_def GS.\<alpha>_def br_def
       apply (auto dest!: AUX1 in_set_butlastD iff: Sup_le_iff)
       done
   qed
   
   definition gselect_edge_impl :: "'Q gGS \<Rightarrow> ('Q option \<times> 'Q gGS) nres" 
     where "gselect_edge_impl s \<equiv> 
     do { 
       let (a,s)=s; 
       (vo,s)\<leftarrow>select_edge_impl s; 
       RETURN (vo,a,s)
     }"
 
   thm select_edge_refine
   lemma gselect_edge_impl_refine:
     assumes A: "(s', a, p, D, pE) \<in> gGS_rel" 
     assumes PRE: "p \<noteq> []"
     shows "gselect_edge_impl s' \<le> \<Down>(Id \<times>\<^sub>r gGS_rel) (gselect_edge (a, p, D, pE))"
   proof -
     from A obtain S' B' I' P' where [simp]: "s'=(a,S',B',I',P')" 
       and OSR: "((S',B',I',P'),(p,D,pE))\<in>GS_rel" and L: "length a = length B'"
       and R: "\<Union>(set a) \<subseteq> {0..<num_acc}"
       by (rule gGS_relE)
 
     {
       fix S B I P S' B' I' P' vo
       assume "nofail (select_edge_impl ((S, B, I, P)::'a GS))"
         "inres (select_edge_impl ((S, B, I, P)::'a GS)) (vo, (S', B', I', P'))"
       hence "length B' = length B"
         apply (simp add: select_edge_impl_def GS.sel_rem_last_def refine_pw_simps
           split: if_split_asm prod.splits)
         apply auto
         done
     } note AUX1=this
 
     show ?thesis
       using select_edge_refine[OF OSR PRE]
       unfolding gselect_edge_impl_def gselect_edge_def
       apply (simp add: refine_pw_simps pw_le_iff prod_rel_sv)
 
       unfolding gGS_rel_def br_def gGS_\<alpha>_def gGS_invar_def GS_rel_def GS.\<alpha>_def
       apply (simp split: prod.splits)
       apply clarsimp
       using R
       apply (auto simp: L dest: AUX1)
       done
   qed
 
 
   term GS.idx_of_impl
 
   thm GS_invar.idx_of_correct
 
 
   definition gcollapse_impl_aux :: "'Q \<Rightarrow> 'Q gGS \<Rightarrow> 'Q gGS nres" where 
     "gcollapse_impl_aux v s \<equiv> 
     do { 
       let (A,s)=s;
       \<^cancel>\<open>ASSERT (v\<in>\<Union>set (GS.p_\<alpha> s));\<close>
       i \<leftarrow> GS.idx_of_impl s v;
       s \<leftarrow> collapse_impl v s;
       ASSERT (i < length A);
       us \<leftarrow> Un_set_drop_impl i A;
       let A = take i A @ [us];
       RETURN (A,s)
     }"
 
   term collapse
   lemma gcollapse_alt:
     "gcollapse v APDPE = ( 
       let 
         (a,p,D,pE)=APDPE; 
         i=idx_of p v;
         s=collapse v (p,D,pE);
         us=\<Union>(set (drop i a));
         a = take i a @ [us]
       in (a,s))"
     unfolding gcollapse_def gcollapse_aux_def collapse_def collapse_aux_def
     by auto
 
   thm collapse_refine
   lemma gcollapse_impl_aux_refine:
     assumes A: "(s', a, p, D, pE) \<in> gGS_rel" 
     assumes B: "(v',v)\<in>Id"
     assumes PRE: "v\<in>\<Union>(set p)"
     shows "gcollapse_impl_aux v' s' 
       \<le> \<Down> gGS_rel (RETURN (gcollapse v (a, p, D, pE)))"
   proof -
     note [simp] = Let_def
 
     from A obtain S' B' I' P' where [simp]: "s'=(a,S',B',I',P')" 
       and OSR: "((S',B',I',P'),(p,D,pE))\<in>GS_rel" and L: "length a = length B'"
       and R: "\<Union>(set a) \<subseteq> {0..<num_acc}"
       by (rule gGS_relE)
 
     from B have [simp]: "v'=v" by simp
 
     from OSR have [simp]: "GS.p_\<alpha> (S',B',I',P') = p"
       by (simp add: GS_rel_def br_def GS.\<alpha>_def)
 
     from OSR PRE have PRE': "v \<in> \<Union>(set (GS.p_\<alpha> (S',B',I',P')))"
       by (simp add: GS_rel_def br_def GS.\<alpha>_def)
 
     from OSR have GS_invar: "GS_invar (S',B',I',P')" 
       by (simp add: GS_rel_def br_def)
 
     term GS.B
     {
       fix s
       assume "collapse v (p, D, pE) = (GS.p_\<alpha> s, GS.D_\<alpha> s, GS.pE_\<alpha> s)"
       hence "length (GS.B s) = Suc (idx_of p v)"
         unfolding collapse_def collapse_aux_def Let_def
         apply (cases s)
         apply (auto simp: GS.p_\<alpha>_def)
         apply (drule arg_cong[where f=length])
         using GS_invar.p_\<alpha>_disjoint_sym[OF GS_invar]
           and PRE \<open>GS.p_\<alpha> (S', B', I', P') = p\<close> idx_of_props(1)[of p v]
         by simp
     } note AUX1 = this
 
     show ?thesis
       unfolding gcollapse_alt gcollapse_impl_aux_def
       apply simp
       apply (rule RETURN_as_SPEC_refine)
       apply (refine_rcg
         order_trans[OF GS_invar.idx_of_correct[OF GS_invar PRE']] 
         order_trans[OF collapse_refine[OF OSR B PRE, simplified]]
         refine_vcg
       )
       using PRE' apply simp
       
       apply (simp add: L)
 
       using Un_set_drop_impl_correct acc_bound R
       apply (simp add: refine_pw_simps pw_le_iff)
       unfolding gGS_rel_def GS_rel_def GS.\<alpha>_def br_def gGS_\<alpha>_def gGS_invar_def
       apply (clarsimp simp: L dest!: AUX1)
       apply (auto dest!: AUX1 simp: L)
       apply (force dest!: in_set_dropD) []
       apply (force dest!: in_set_takeD) []
       done
   qed
 
   definition gcollapse_impl :: "'Q \<Rightarrow> 'Q gGS \<Rightarrow> 'Q gGS nres" 
     where "gcollapse_impl v s \<equiv>     
     do { 
       let (A,S,B,I,P)=s;
       i \<leftarrow> GS.idx_of_impl (S,B,I,P) v;
       ASSERT (i+1 \<le> length B);
       let B = take (i+1) B;
       ASSERT (i < length A);
       us\<leftarrow>Un_set_drop_impl i A;
       let A = take i A @ [us];
       RETURN (A,S,B,I,P)
     }"
 
   lemma gcollapse_impl_aux_opt_refine: 
     "gcollapse_impl v s \<le> gcollapse_impl_aux v s"
     unfolding gcollapse_impl_def gcollapse_impl_aux_def collapse_impl_def 
       GS.collapse_impl_def
     apply (simp add: refine_pw_simps pw_le_iff split: prod.splits) 
     apply blast
     done
   
   lemma gcollapse_impl_refine:
     assumes A: "(s', a, p, D, pE) \<in> gGS_rel" 
     assumes B: "(v',v)\<in>Id"
     assumes PRE: "v\<in>\<Union>(set p)"
     shows "gcollapse_impl v' s' 
     \<le> \<Down> gGS_rel (RETURN (gcollapse v (a, p, D, pE)))"
     using order_trans[OF 
       gcollapse_impl_aux_opt_refine 
       gcollapse_impl_aux_refine[OF assms]]
     .
 
   definition ginitial_impl :: "'Q \<Rightarrow> 'Q goGS \<Rightarrow> 'Q gGS" 
     where "ginitial_impl v0 s0 \<equiv> ([acc v0],initial_impl v0 (snd s0))"
   lemma ginitial_impl_refine: 
     assumes A: "v0\<notin>goD s0" "go_is_no_brk s0"
     assumes REL: "(s0i,s0)\<in>goGS_rel" "(v0i,v0)\<in>Id" 
     shows "(ginitial_impl v0i s0i,ginitial v0 s0)\<in>gGS_rel"
     unfolding ginitial_impl_def ginitial_def 
     using REL initial_refine[OF A(1) _ REL(2), of "snd s0i"] A(2)
     apply (auto 
       simp: gGS_rel_def br_def gGS_\<alpha>_def gGS_invar_def goGS_rel_def goGS_\<alpha>_def
       simp: go_is_no_brk_def goD_def oGS_rel_def GS_rel_def goGS_invar_def
       split: prod.splits
 
     )
     using acc_bound
     apply (fastforce simp: initial_impl_def GS_initial_impl_def)+
     done
 
   definition gpath_is_empty_impl :: "'Q gGS \<Rightarrow> bool"
     where "gpath_is_empty_impl s = path_is_empty_impl (snd s)"
 
   lemma gpath_is_empty_refine: 
     "(s,(a,p,D,pE))\<in>gGS_rel \<Longrightarrow> gpath_is_empty_impl s \<longleftrightarrow> p=[]"
     unfolding gpath_is_empty_impl_def 
     using path_is_empty_refine
     by (fastforce simp: gGS_rel_def br_def gGS_invar_def gGS_\<alpha>_def GS.\<alpha>_def)
 
   definition gis_on_stack_impl :: "'Q \<Rightarrow> 'Q gGS \<Rightarrow> bool" 
     where "gis_on_stack_impl v s = is_on_stack_impl v (snd s)"
 
   lemma gis_on_stack_refine: 
     "\<lbrakk>(s,(a,p,D,pE))\<in>gGS_rel\<rbrakk> \<Longrightarrow> gis_on_stack_impl v s \<longleftrightarrow> v\<in>\<Union>(set p)"
     unfolding gis_on_stack_impl_def 
     using is_on_stack_refine
     by (fastforce simp: gGS_rel_def br_def gGS_invar_def gGS_\<alpha>_def GS.\<alpha>_def)
 
   definition gis_done_impl :: "'Q \<Rightarrow> 'Q gGS \<Rightarrow> bool"
     where "gis_done_impl v s \<equiv> is_done_impl v (snd s)"
   thm is_done_refine
   lemma gis_done_refine: "(s,(a,p,D,pE))\<in>gGS_rel 
     \<Longrightarrow> gis_done_impl v s \<longleftrightarrow> (v \<in> D)"
     using is_done_refine[of "(snd s)" v]
     by (auto 
       simp: gGS_rel_def br_def gGS_\<alpha>_def gGS_invar_def GS.\<alpha>_def 
             gis_done_impl_def)
 
 
   definition (in -) "on_stack_less I u v \<equiv> 
     case I v of 
       Some (STACK j) \<Rightarrow> j<u
     | _ \<Rightarrow> False"
 
   definition (in -) "on_stack_ge I l v \<equiv> 
     case I v of 
       Some (STACK j) \<Rightarrow> l\<le>j
     | _ \<Rightarrow> False"
 
 
   lemma (in GS_invar) set_butlast_p_refine:
     assumes PRE: "p_\<alpha>\<noteq>[]"
     shows "Collect (on_stack_less I (last B)) = \<Union>(set (butlast p_\<alpha>))" (is "?L=?R")
   proof (intro equalityI subsetI)
     from PRE have [simp]: "B\<noteq>[]" by (auto simp: p_\<alpha>_def)
 
     have [simp]: "S\<noteq>[]"
       by (simp add: empty_eq)
 
     {
       fix v
       assume "v\<in>?L"
       then obtain j where [simp]: "I v = Some (STACK j)" and "j<last B"
         by (auto simp: on_stack_less_def split: option.splits node_state.splits)
 
       from I_consistent[of v j] have [simp]: "j<length S" "v=S!j" by auto
       
       from B0 have "B!0=0" by simp
       from \<open>j<last B\<close> have "j<B!(length B - 1)" by (simp add: last_conv_nth)
       from find_seg_bounds[OF \<open>j<length S\<close>] find_seg_correct[OF \<open>j<length S\<close>]
       have "v\<in>seg (find_seg j)" "find_seg j < length B" by auto
       moreover with \<open>j<B!(length B - 1)\<close> have "find_seg j < length B - 1"
         (* What follows is an unreadable, auto-generated structured proof
           that replaces the following smt-call:
         by (smt GS.seg_start_def `seg_start (find_seg j) \<le> j`)*)
       proof -
         have f1: "\<And>x\<^sub>1 x. \<not> (x\<^sub>1::nat) < x\<^sub>1 - x"
           using less_imp_diff_less by blast
         have "j \<le> last B"
           by (metis \<open>j < last B\<close> less_le)
         hence f2: "\<And>x\<^sub>1. \<not> last B < x\<^sub>1 \<or> \<not> x\<^sub>1 \<le> j"
           using f1 by (metis diff_diff_cancel le_trans)
         have "\<And>x\<^sub>1. seg_end x\<^sub>1 \<le> j \<or> \<not> x\<^sub>1 < find_seg j"
           by (metis \<open>seg_start (find_seg j) \<le> j\<close> calculation(2) 
             le_trans seg_end_less_start)
         thus "find_seg j < length B - 1"
           using f1 f2 
           by (metis GS.seg_start_def \<open>B \<noteq> []\<close> \<open>j < B ! (length B - 1)\<close>
             \<open>seg_start (find_seg j) \<le> j\<close> calculation(2) diff_diff_cancel 
             last_conv_nth nat_neq_iff seg_start_less_end)
       qed
       ultimately show "v\<in>?R" 
         by (auto simp: p_\<alpha>_def map_butlast[symmetric] butlast_upt)
     }
 
     {
       fix v
       assume "v\<in>?R"
       then obtain i where "i<length B - 1" and "v\<in>seg i"
         by (auto simp: p_\<alpha>_def map_butlast[symmetric] butlast_upt)
       then obtain j where "j < seg_end i" and "v=S!j"
         by (auto simp: seg_def)
       hence "j<B!(i+1)" and "i+1 \<le> length B - 1" using \<open>i<length B - 1\<close>
         by (auto simp: seg_end_def last_conv_nth split: if_split_asm)
       with sorted_nth_mono[OF B_sorted \<open>i+1 \<le> length B - 1\<close>] have "j<last B"
         by (auto simp: last_conv_nth)
       moreover from \<open>j < seg_end i\<close> have "j<length S"
         by (metis GS.seg_end_def add_diff_inverse_nat \<open>i + 1 \<le> length B - 1\<close>
           add_lessD1 less_imp_diff_less less_le_not_le nat_neq_iff 
           seg_end_bound)
         (*by (smt `i < length B - 1` seg_end_bound)*)
       with I_consistent \<open>v=S!j\<close> have "I v = Some (STACK j)" by auto
       ultimately show "v\<in>?L"
         by (auto simp: on_stack_less_def)
     }
   qed
 
   lemma (in GS_invar) set_last_p_refine:
     assumes PRE: "p_\<alpha>\<noteq>[]"
     shows "Collect (on_stack_ge I (last B)) = last p_\<alpha>" (is "?L=?R")
   proof (intro equalityI subsetI)
     from PRE have [simp]: "B\<noteq>[]" by (auto simp: p_\<alpha>_def)
 
     have [simp]: "S\<noteq>[]" by (simp add: empty_eq)
 
     {
       fix v
       assume "v\<in>?L"
       then obtain j where [simp]: "I v = Some (STACK j)" and "j\<ge>last B"
         by (auto simp: on_stack_ge_def split: option.splits node_state.splits)
 
       from I_consistent[of v j] have [simp]: "j<length S" "v=S!j" by auto
       hence "v\<in>seg (length B - 1)" using \<open>j\<ge>last B\<close>
         by (auto simp: seg_def last_conv_nth seg_start_def seg_end_def)
       thus "v\<in>last p_\<alpha>" by (auto simp: p_\<alpha>_def last_map)
     }
 
     {
       fix v
       assume "v\<in>?R"
       hence "v\<in>seg (length B - 1)"
         by (auto simp: p_\<alpha>_def last_map)
       then obtain j where "v=S!j" "j\<ge>last B" "j<length S"
         by (auto simp: seg_def last_conv_nth seg_start_def seg_end_def)
       with I_consistent have "I v = Some (STACK j)" by simp
       with \<open>j\<ge>last B\<close> show "v\<in>?L" by (auto simp: on_stack_ge_def)
     }
   qed
 
   definition ce_impl :: "'Q gGS \<Rightarrow> (('Q set \<times> 'Q set) option \<times> 'Q gGS) nres"
     where "ce_impl s \<equiv> 
     do {
       let (a,S,B,I,P) = s;
       ASSERT (B\<noteq>[]);
       let bls = Collect (on_stack_less I (last B));
       let ls = Collect (on_stack_ge I (last B));
       RETURN (Some (bls, ls),a,S,B,I,P)
     }"
 
   lemma ce_impl_refine:
     assumes A: "(s,(a,p,D,pE))\<in>gGS_rel"
     assumes PRE: "p\<noteq>[]"
     shows "ce_impl s \<le> \<Down>(Id\<times>\<^sub>rgGS_rel) 
       (RETURN (Some (\<Union>(set (butlast p)),last p),a,p,D,pE))"
   proof -
     from A obtain S' B' I' P' where [simp]: "s=(a,S',B',I',P')" 
       and OSR: "((S',B',I',P'),(p,D,pE))\<in>GS_rel" and L: "length a = length B'"
       by (rule gGS_relE)
 
     from OSR have [simp]: "GS.p_\<alpha> (S',B',I',P') = p"
       by (simp add: GS_rel_def br_def GS.\<alpha>_def)
 
     from PRE have NE': "GS.p_\<alpha> (S', B', I', P') \<noteq> []" by simp
     hence BNE[simp]: "B'\<noteq>[]" by (simp add: GS.p_\<alpha>_def)
 
     from OSR have GS_invar: "GS_invar (S',B',I',P')" 
       by (simp add: GS_rel_def br_def)
 
     show ?thesis
       using GS_invar.set_butlast_p_refine[OF GS_invar NE']
       using GS_invar.set_last_p_refine[OF GS_invar NE']
       unfolding ce_impl_def
       using A
       by auto
   qed
 
   definition "last_is_acc_impl s \<equiv> 
     do {
       let (a,_)=s;
       ASSERT (a\<noteq>[]);
       RETURN (\<forall>i<num_acc. i\<in>last a)
     }"
 
   lemma last_is_acc_impl_refine:
     assumes A: "(s,(a,p,D,pE))\<in>gGS_rel"
     assumes PRE: "a\<noteq>[]"
     shows "last_is_acc_impl s \<le> RETURN (last a = {0..<num_acc})"
   proof -
     from A PRE have "last a \<subseteq> {0..<num_acc}"
       unfolding gGS_rel_def gGS_invar_def br_def gGS_\<alpha>_def by auto
     hence C: "(\<forall>i<num_acc. i\<in>last a) \<longleftrightarrow> (last a = {0..<num_acc})"
       by auto
 
     from A obtain gs where [simp]: "s=(a,gs)"
       by (auto simp: gGS_rel_def gGS_\<alpha>_def br_def split: prod.splits)
 
     show ?thesis
       unfolding last_is_acc_impl_def 
       by (auto simp: gGS_rel_def br_def gGS_\<alpha>_def C PRE split: prod.splits)
   qed
 
   definition go_is_no_brk_impl :: "'Q goGS \<Rightarrow> bool" 
     where "go_is_no_brk_impl s \<equiv> fst s = None"
   lemma go_is_no_brk_refine: 
     "(s,s')\<in>goGS_rel \<Longrightarrow> go_is_no_brk_impl s \<longleftrightarrow> go_is_no_brk s'"
     unfolding go_is_no_brk_def go_is_no_brk_impl_def
     by (auto simp: goGS_rel_def br_def goGS_\<alpha>_def split: prod.splits)
 
   definition goD_impl :: "'Q goGS \<Rightarrow> 'Q oGS" where "goD_impl s \<equiv> snd s"
   lemma goD_refine: 
     "go_is_no_brk s' \<Longrightarrow> (s,s')\<in>goGS_rel \<Longrightarrow> (goD_impl s, goD s')\<in>oGS_rel"
     unfolding goD_impl_def goD_def
     by (auto 
       simp: goGS_rel_def br_def goGS_\<alpha>_def goGS_invar_def oGS_rel_def 
             go_is_no_brk_def) 
 
   definition go_is_done_impl :: "'Q \<Rightarrow> 'Q goGS \<Rightarrow> bool" 
     where "go_is_done_impl v s \<equiv> is_done_oimpl v (snd s)"
   thm is_done_orefine
   lemma go_is_done_impl_refine: "\<lbrakk>go_is_no_brk s'; (s,s')\<in>goGS_rel; (v,v')\<in>Id\<rbrakk> 
     \<Longrightarrow> go_is_done_impl v s \<longleftrightarrow> (v'\<in>goD s')"
     using is_done_orefine
     unfolding go_is_done_impl_def goD_def go_is_no_brk_def
     apply (fastforce simp: goGS_rel_def br_def goGS_invar_def goGS_\<alpha>_def)
     done
 
 
   definition goBrk_impl :: "'Q goGS \<Rightarrow> 'Q ce" where "goBrk_impl \<equiv> fst"
 
   lemma goBrk_refine: "(s,s')\<in>goGS_rel \<Longrightarrow> (goBrk_impl s, goBrk s')\<in>Id"
     unfolding goBrk_impl_def goBrk_def
     by (auto simp: goGS_rel_def br_def goGS_\<alpha>_def split: prod.splits)
 
   definition find_ce_impl :: "('Q set \<times> 'Q set) option nres" where
     "find_ce_impl \<equiv> do {
       stat_start_nres;
       let os=goinitial_impl;
       os\<leftarrow>FOREACHci (\<lambda>it os. fgl_outer_invar it (goGS_\<alpha> os)) V0 
         (go_is_no_brk_impl) (\<lambda>v0 s0. 
       do {
         if \<not>go_is_done_impl v0 s0 then do {
 
           let s = (None,ginitial_impl v0 s0);
 
           (brk,s)\<leftarrow>WHILEIT 
             (\<lambda>(brk,s). fgl_invar v0 (oGS_\<alpha> (goD_impl s0)) (brk,snd (gGS_\<alpha> s)))
             (\<lambda>(brk,s). brk=None \<and> \<not>gpath_is_empty_impl s) (\<lambda>(l,s).
           do {
             \<comment> \<open>Select edge from end of path\<close>
             (vo,s) \<leftarrow> gselect_edge_impl s;
 
             case vo of 
               Some v \<Rightarrow> do {
                 if gis_on_stack_impl v s then do {
                   s\<leftarrow>gcollapse_impl v s;
                   b\<leftarrow>last_is_acc_impl s;
                   if b then
                     ce_impl s
                   else 
                     RETURN (None,s)
                 } else if \<not>gis_done_impl v s then do {
                   \<comment> \<open>Edge to new node. Append to path\<close>
                   RETURN (None,gpush_impl v s)
                 } else do {
                   \<comment> \<open>Edge to done node. Skip\<close>
                   RETURN (None,s)
                 }
               }
             | None \<Rightarrow> do {
                 \<comment> \<open>No more outgoing edges from current node on path\<close>
                 s\<leftarrow>gpop_impl s;
                 RETURN (None,s)
               }
           }) (s);
           RETURN (gto_outer_impl brk s)
         } else RETURN s0
       }) os;
       stat_stop_nres;
       RETURN (goBrk_impl os)
     }"
 
   lemma find_ce_impl_refine: "find_ce_impl \<le> \<Down>Id gfind_ce"
   proof -
     note [refine2] = prod_relI[OF IdI[of None] ginitial_impl_refine]
 
     have [refine]: "\<And>s a p D pE. \<lbrakk>
       (s,(a,p,D,pE))\<in>gGS_rel;
       p \<noteq> []; pE \<inter> last p \<times> UNIV = {}
       \<rbrakk> \<Longrightarrow>
       gpop_impl s \<bind> (\<lambda>s. RETURN (None, s))
         \<le> SPEC (\<lambda>c. (c, None, gpop (a,p,D,pE)) \<in> Id \<times>\<^sub>r gGS_rel)"
       apply (drule (2) gpop_impl_refine)
       apply (fastforce simp add: pw_le_iff refine_pw_simps)
       done
 
     note [[goals_limit = 1]]
 
     note FOREACHci_refine_rcg'[refine del]
 
     show ?thesis
       unfolding find_ce_impl_def gfind_ce_def
       apply (refine_rcg
         bind_refine'
         prod_relI IdI
         inj_on_id
 
         gselect_edge_impl_refine gpush_impl_refine 
         oinitial_refine ginitial_impl_refine 
         bind_Let_refine2[OF gcollapse_impl_refine]
         if_bind_cond_refine[OF last_is_acc_impl_refine]
         ce_impl_refine
         goinitial_impl_refine
         gto_outer_refine
         goBrk_refine
         FOREACHci_refine_rcg'[where R=goGS_rel, OF inj_on_id]
       )
 
       apply refine_dref_type
     
       apply (simp_all add: go_is_no_brk_refine go_is_done_impl_refine)
       apply (auto simp: goGS_rel_def br_def) []
       apply (auto simp: goGS_rel_def br_def goGS_\<alpha>_def gGS_\<alpha>_def gGS_rel_def 
                         goD_def goD_impl_def) []
 
       apply (auto dest: gpath_is_empty_refine ) []
       apply (auto dest: gis_on_stack_refine) []
       apply (auto dest: gis_done_refine) []
       done
   qed
 
 end
 
 section \<open>Constructing a Lasso from Counterexample\<close>
 
 subsection \<open>Lassos in GBAs\<close>
 
 context igb_fr_graph begin
 
   definition reconstruct_reach :: "'Q set \<Rightarrow> 'Q set \<Rightarrow> ('Q list \<times> 'Q) nres"
     \<comment> \<open>Reconstruct the reaching path of a lasso\<close>
     where "reconstruct_reach Vr Vl \<equiv> do {
       res \<leftarrow> find_path (E\<inter>Vr\<times>UNIV) V0 (\<lambda>v. v\<in>Vl);
       ASSERT (res \<noteq> None);
       RETURN (the res)
     }"
 
   lemma reconstruct_reach_correct:
     assumes CEC: "ce_correct Vr Vl"
     shows "reconstruct_reach Vr Vl 
       \<le> SPEC (\<lambda>(pr,va). \<exists>v0\<in>V0. path E v0 pr va \<and> va\<in>Vl)"
   proof -
     have FIN_aux: "finite ((E \<inter> Vr \<times> UNIV)\<^sup>* `` V0)"
       by (metis finite_reachableE_V0 finite_subset inf_sup_ord(1) inf_sup_ord(2)
         inf_top.left_neutral reachable_mono)
     
     {
       fix u p v
       assume P: "path E u p v" and SS: "set p \<subseteq> Vr"
       have "path (E \<inter> Vr\<times>UNIV) u p v"
         apply (rule path_mono[OF _ path_restrict[OF P]])
         using SS by auto
     } note P_CONV=this
 
     from CEC obtain v0 "pr" va where "v0\<in>V0" "set pr \<subseteq> Vr" "va\<in>Vl" 
       "path (E \<inter> Vr\<times>UNIV) v0 pr va"
       unfolding ce_correct_def is_lasso_prpl_def is_lasso_prpl_pre_def
       by (force simp: neq_Nil_conv path_simps dest: P_CONV)
     hence 1: "va \<in> (E \<inter> Vr \<times> UNIV)\<^sup>* `` V0" 
       by (auto dest: path_is_rtrancl)
       
     show ?thesis
       using assms unfolding reconstruct_reach_def
       apply (refine_rcg refine_vcg order_trans[OF find_path_ex_rule])
       apply (clarsimp_all simp: FIN_aux finite_V0)
 
       using \<open>va\<in>Vl\<close> 1 apply auto []
 
       apply (auto dest: path_mono[of "E \<inter> Vr \<times> UNIV" E, simplified]) []
       done
   qed
 
   definition "rec_loop_invar Vl va s \<equiv> let (v,p,cS) = s in 
     va \<in> E\<^sup>*``V0 \<and>
     path E va p v \<and>
     cS = acc v \<union> (\<Union>(acc`set p)) \<and>
     va \<in> Vl \<and> v \<in> Vl \<and> set p \<subseteq> Vl"
 
   definition reconstruct_lasso :: "'Q set \<Rightarrow> 'Q set \<Rightarrow> ('Q list \<times> 'Q list) nres"
     \<comment> \<open>Reconstruct lasso\<close>
     where "reconstruct_lasso Vr Vl \<equiv> do {
     (pr,va) \<leftarrow> reconstruct_reach Vr Vl;
     
     let cS_full = {0..<num_acc};
     let E = E \<inter> UNIV\<times>Vl;
     
     (vd,p,_) \<leftarrow> WHILEIT (rec_loop_invar Vl va) 
       (\<lambda>(_,_,cS). cS \<noteq> cS_full) 
       (\<lambda>(v,p,cS). do {
         ASSERT (\<exists>v'. (v,v')\<in>E\<^sup>* \<and> \<not> (acc v' \<subseteq> cS));
         sr \<leftarrow> find_path E {v} (\<lambda>v. \<not> (acc v \<subseteq> cS));
         ASSERT (sr \<noteq> None);
         let (p_seg,v) = the sr;
         RETURN (v,p@p_seg,cS \<union> acc v)
       }) (va,[],acc va);
 
     p_close_r \<leftarrow> (if p=[] then 
         find_path1 E vd ((=) va)
       else
         find_path E {vd} ((=) va));
 
     ASSERT (p_close_r \<noteq> None);
     let (p_close,_) = the p_close_r;
 
     RETURN (pr, p@p_close)
   }"
 
 
 lemma (in igb_fr_graph) reconstruct_lasso_correct:
   assumes CEC: "ce_correct Vr Vl"
   shows "reconstruct_lasso Vr Vl \<le> SPEC (is_lasso_prpl)"
 proof -
 
   let ?E = "E \<inter> UNIV \<times> Vl"
 
   have E_SS: "E \<inter> Vl \<times> Vl \<subseteq> ?E" by auto
 
   from CEC have
     REACH: "Vl \<subseteq> E\<^sup>*``V0"
     and CONN: "Vl\<times>Vl \<subseteq> (E \<inter> Vl\<times>Vl)\<^sup>*"
     and NONTRIV: "Vl\<times>Vl \<inter> E \<noteq> {}"
     and NES[simp]: "Vl\<noteq>{}"
     and ALL: "\<Union>(acc`Vl) = {0..<num_acc}"
     unfolding ce_correct_def is_lasso_prpl_def
     apply clarsimp_all
     apply auto []
     apply force
     done
 
   define term_rel
     where "term_rel = (inv_image (finite_psupset {0..<num_acc}) (\<lambda>(_::'Q,_::'Q list,cS). cS))"
   hence WF: "wf term_rel" by simp
 
   { fix va
     assume "va \<in> Vl"
     hence "rec_loop_invar Vl va (va, [], acc va)"
       unfolding rec_loop_invar_def using REACH by auto
   } note INVAR_INITIAL = this
 
   {
     fix v p cS va
     assume "rec_loop_invar Vl va (v, p, cS)"
     hence "finite ((?E)\<^sup>* `` {v})"
       apply -
       apply (rule finite_subset[where B="E\<^sup>*``V0"])
       unfolding rec_loop_invar_def
       using REACH
       apply (clarsimp_all dest!: path_is_rtrancl)
       apply (drule rtrancl_mono_mp[where U="?E" and V=E, rotated], (auto) [])
       by (metis rev_ImageI rtrancl_trans)
   } note FIN1 = this
 
   {
     fix va v :: 'Q and p cS
     assume INV: "rec_loop_invar Vl va (v,p,cS)"
       and NC: "cS \<noteq> {0..<num_acc}"
 
     from NC INV obtain i where "i<num_acc" "i\<notin>cS" 
       unfolding rec_loop_invar_def by auto blast
 
     with ALL obtain v' where "v'\<in>Vl" "\<not> acc v' \<subseteq> cS"
       by simp (smt UN_iff atLeastLessThan_iff le0 subsetCE)
      
     moreover with CONN INV have "(v,v')\<in>(E \<inter> Vl \<times> Vl)\<^sup>*"
       unfolding rec_loop_invar_def by auto
     hence "(v,v')\<in>?E\<^sup>*" using rtrancl_mono_mp[OF E_SS] by blast
     ultimately have "\<exists>v'. (v,v')\<in>(?E)\<^sup>* \<and> \<not> acc v' \<subseteq> cS" by auto
   } note ASSERT1 = this
 
   {
     fix va v p cS v' p'
     assume "rec_loop_invar Vl va (v, p, cS)"
     and "path (?E) v p' v'"
     and "\<not> (acc v' \<subseteq> cS)"
     and "\<forall>v\<in>set p'. acc v \<subseteq> cS"
     hence "rec_loop_invar Vl va (v', p@p', cS \<union> acc v')"
       unfolding rec_loop_invar_def
       apply simp
       apply (intro conjI)
       apply (auto simp: path_simps dest: path_mono[of "?E" E, simplified]) []
 
       apply (cases p')
       apply (auto simp: path_simps) [2]
 
       apply (cases p' rule: rev_cases)
       apply (auto simp: path_simps) [2]
 
       apply (erule path_set_induct)
       apply auto [2]
       done
   } note INV_PRES = this
 
   {
     fix va v p cS v' p'
     assume "rec_loop_invar Vl va (v, p, cS)"
       and "path ?E v p' v'"
       and "\<not> (acc v' \<subseteq> cS)"
       and "\<forall>v\<in>set p'. acc v \<subseteq> cS"
     hence "((v', p@p', cS \<union> acc v'), (v,p,cS)) \<in> term_rel"
       unfolding term_rel_def rec_loop_invar_def
       by (auto simp: finite_psupset_def)
   } note VAR = this
 
   have CONN1: "Vl \<times> Vl \<subseteq> (?E)\<^sup>+"
   proof clarify
     fix a b
     assume "a\<in>Vl" "b\<in>Vl"
     from NONTRIV obtain u v where E: "(u,v)\<in>(E \<inter> Vl\<times>Vl)" by auto
     from CONN \<open>a\<in>Vl\<close> E have "(a,u)\<in>(E\<inter>Vl\<times>Vl)\<^sup>*" by auto
     also note E
     also (rtrancl_into_trancl1) from CONN \<open>b\<in>Vl\<close> E have "(v,b)\<in>(E\<inter>Vl\<times>Vl)\<^sup>*"
       by auto
     finally show "(a,b)\<in>(?E)\<^sup>+" using trancl_mono[OF _ E_SS] by auto
   qed
     
   {
     fix va v p cS
     assume "rec_loop_invar Vl va (v, p, cS)"
     hence "(v,va) \<in> (?E)\<^sup>+"
       unfolding rec_loop_invar_def
       using CONN1
       by auto
   } note CLOSE1 = this
 
   {
     fix va v p cS
     assume "rec_loop_invar Vl va (v, p, cS)"
     hence "(v,va) \<in> (?E)\<^sup>*"
       unfolding rec_loop_invar_def
       using CONN rtrancl_mono[OF E_SS]
       by auto
   } note CLOSE2 = this
 
   {
     fix "pr" vd pl va v0
     assume "rec_loop_invar Vl va (vd, [], {0..<num_acc})" "va \<in> Vl" "v0 \<in> V0"
       "path E v0 pr va" "pl \<noteq> []" "path ?E vd pl va"
     hence "is_lasso_prpl (pr, pl)"
       unfolding is_lasso_prpl_def is_lasso_prpl_pre_def rec_loop_invar_def
       by (auto simp: neq_Nil_conv path_simps
         dest!: path_mono[of "?E" E, simplified]) []
   } note INV_POST1 = this
 
   {
     fix va v p p' "pr" v0
     assume INV: "rec_loop_invar Vl va (v,p,{0..<num_acc})" 
       and 1: "p\<noteq>[]" "path ?E v p' va"
       and PR: "v0\<in>V0" "path E v0 pr va"
 
     from INV have "\<forall>i<num_acc. \<exists>q\<in>insert v (set p). i \<in> acc q"
       unfolding rec_loop_invar_def
       by auto
     moreover from INV 1 have "insert v (set p) \<subseteq> set p \<union> set p'"
       unfolding rec_loop_invar_def
-      apply (cases p, simp)
+      apply (cases p)
+      apply blast
       apply (cases p')
       apply (auto simp: path_simps)
       done
     ultimately have ACC: "\<forall>i<num_acc. \<exists>q\<in>set p \<union> set p'. i \<in> acc q" by blast
     
     from INV 1 have PL: "path E va (p @ p') va"
       by (auto simp: rec_loop_invar_def path_simps 
         dest!: path_mono[of "?E" E, simplified]) []
 
     have "is_lasso_prpl (pr,p@p')"
       unfolding is_lasso_prpl_def is_lasso_prpl_pre_def
       apply (clarsimp simp: ACC)
       using PR PL \<open>p\<noteq>[]\<close> by auto
   } note INV_POST2 = this
 
   show ?thesis
     unfolding reconstruct_lasso_def
     apply (refine_rcg 
       WF
       order_trans[OF reconstruct_reach_correct]
       order_trans[OF find_path_ex_rule]
       order_trans[OF find_path1_ex_rule]
       refine_vcg 
     )
 
     apply (vc_solve 
       del: subsetI
       solve: ASSERT1 INV_PRES asm_rl VAR CLOSE1 CLOSE2 INV_POST1 INV_POST2
       simp: INVAR_INITIAL FIN1 CEC)
     done
 qed
 
 definition find_lasso where "find_lasso \<equiv> do {
   ce \<leftarrow> find_ce_spec;
   case ce of 
     None \<Rightarrow> RETURN None
   | Some (Vr,Vl) \<Rightarrow> do {
       l \<leftarrow> reconstruct_lasso Vr Vl;
       RETURN (Some l)
     }
 }"
 
 lemma (in igb_fr_graph) find_lasso_correct: "find_lasso \<le> find_lasso_spec"
   unfolding find_lasso_spec_def find_lasso_def find_ce_spec_def
   apply (refine_rcg refine_vcg order_trans[OF reconstruct_lasso_correct])
   apply auto
   done
 
 end
 
 end
diff --git a/thys/JinjaThreads/BV/BVSpecTypeSafe.thy b/thys/JinjaThreads/BV/BVSpecTypeSafe.thy
--- a/thys/JinjaThreads/BV/BVSpecTypeSafe.thy
+++ b/thys/JinjaThreads/BV/BVSpecTypeSafe.thy
@@ -1,1841 +1,1844 @@
 (*  Title:      JinjaThreads/BV/BVSpecTypeSafe.thy
     Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler
 *)
 
 section \<open>BV Type Safety Proof \label{sec:BVSpecTypeSafe}\<close>
 
 theory BVSpecTypeSafe
 imports
   BVConform
   "../Common/ExternalCallWF"
 begin
 
 declare listE_length [simp del]
 
 text \<open>
   This theory contains proof that the specification of the bytecode
   verifier only admits type safe programs.  
 \<close>
 
 subsection \<open>Preliminaries\<close>
 
 text \<open>
   Simp and intro setup for the type safety proof:
 \<close>
 context JVM_heap_conf_base begin
 
 lemmas widen_rules [intro] = conf_widen confT_widen confs_widens confTs_widen
 
 end
   
 subsection \<open>Exception Handling\<close>
 
 
 text \<open>
   For the \<open>Invoke\<close> instruction the BV has checked all handlers
   that guard the current \<open>pc\<close>.
 \<close>
 lemma Invoke_handlers:
   "match_ex_table P C pc xt = Some (pc',d') \<Longrightarrow> 
   \<exists>(f,t,D,h,d) \<in> set (relevant_entries P (Invoke n M) pc xt). 
    (case D of None \<Rightarrow> True | Some D' \<Rightarrow> P \<turnstile> C \<preceq>\<^sup>* D') \<and> pc \<in> {f..<t} \<and> pc' = h \<and> d' = d"
   by (induct xt) (auto simp add: relevant_entries_def matches_ex_entry_def 
                                  is_relevant_entry_def split: if_split_asm)
 
 lemma match_is_relevant:
   assumes rv: "\<And>D'. P \<turnstile> D \<preceq>\<^sup>* D' \<Longrightarrow> is_relevant_class (ins ! i) P D'"
   assumes match: "match_ex_table P D pc xt = Some (pc',d')"
   shows "\<exists>(f,t,D',h,d) \<in> set (relevant_entries P (ins ! i) pc xt). (case D' of None \<Rightarrow> True | Some D'' \<Rightarrow> P \<turnstile> D \<preceq>\<^sup>* D'') \<and> pc \<in> {f..<t} \<and> pc' = h \<and> d' = d"
 using rv match
 by(fastforce simp add: relevant_entries_def is_relevant_entry_def matches_ex_entry_def dest: match_ex_table_SomeD)
 
 
 context JVM_heap_conf_base begin
 
 lemma exception_step_conform:
   fixes \<sigma>' :: "('addr, 'heap) jvm_state"
   assumes wtp: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   assumes correct: "\<Phi> \<turnstile> t:(\<lfloor>xcp\<rfloor>, h, fr # frs) \<surd>"
   shows "\<Phi> \<turnstile> t:exception_step P xcp h fr frs \<surd>"
 proof -
   obtain stk loc C M pc where fr: "fr = (stk, loc, C, M, pc)" by(cases fr)
   from correct obtain Ts T mxs mxl\<^sub>0 ins xt 
     where meth: "P \<turnstile> C sees M:Ts \<rightarrow> T = \<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
     by (simp add: correct_state_def fr) blast
 
   from correct meth fr obtain D 
     where hxcp: "typeof_addr h xcp = \<lfloor>Class_type D\<rfloor>" and DsubThrowable: "P \<turnstile> D \<preceq>\<^sup>* Throwable"
     and rv: "\<And>D'. P \<turnstile> D \<preceq>\<^sup>* D' \<Longrightarrow> is_relevant_class (instrs_of P C M ! pc) P D'"
     by(fastforce simp add: correct_state_def dest: sees_method_fun)
   
   from meth have [simp]: "ex_table_of P C M = xt" by simp
 
   from correct have tconf: "P,h \<turnstile> t \<surd>t" by(simp add: correct_state_def)
 
   show ?thesis
   proof(cases "match_ex_table P D pc xt")
     case None
     with correct fr meth hxcp show ?thesis
       by(fastforce simp add: correct_state_def cname_of_def split: list.split)
   next
     case (Some pc_d)
     then obtain pc' d' where pcd: "pc_d = (pc', d')"
       and match: "match_ex_table P D pc xt = Some (pc',d')" by (cases pc_d) auto
     from match_is_relevant[OF rv match] meth obtain f t D'
       where rv: "(f, t, D', pc', d') \<in> set (relevant_entries P (ins ! pc) pc xt)"
       and DsubD': "(case D' of None \<Rightarrow> True | Some D'' \<Rightarrow> P \<turnstile> D \<preceq>\<^sup>* D'')" and pc: "pc \<in> {f..<t}" by(auto)
 
     from correct meth obtain ST LT
       where h_ok:  "hconf h"
       and \<Phi>_pc: "\<Phi> C M ! pc = Some (ST, LT)"
       and frame:  "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)"
       and frames: "conf_fs P h \<Phi> M (size Ts) T frs"
       and preh: "preallocated h"
       unfolding correct_state_def fr by(auto dest: sees_method_fun)
 
     from frame obtain stk: "P,h \<turnstile> stk [:\<le>] ST"
       and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and pc:  "pc < size ins" 
       by (unfold conf_f_def) auto
     
     from stk have [simp]: "size stk = size ST" ..
 
     from wtp meth correct fr have wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
       by (auto simp add: correct_state_def conf_f_def
                    dest: sees_method_fun
                    elim!: wt_jvm_prog_impl_wt_instr)
 
     from wt \<Phi>_pc have
       eff: "\<forall>(pc', s')\<in>set (xcpt_eff (ins!pc) P pc (ST,LT) xt).
              pc' < size ins \<and> P \<turnstile> s' \<le>' \<Phi> C M!pc'"
       by (auto simp add: defs1)
 
     let ?stk' = "Addr xcp # drop (length stk - d') stk"
     let ?f = "(?stk', loc, C, M, pc')"
 
     have conf: "P,h \<turnstile> Addr xcp :\<le> Class (case D' of None \<Rightarrow> Throwable | Some D'' \<Rightarrow> D'')"
       using DsubD' hxcp DsubThrowable by(auto simp add: conf_def)
 
     obtain ST' LT' where
       \<Phi>_pc': "\<Phi> C M ! pc' = Some (ST', LT')" and
       pc':   "pc' < size ins" and
       less:  "P \<turnstile> (Class D # drop (size ST - d') ST, LT) \<le>\<^sub>i (ST', LT')"
     proof(cases D')
       case Some
       thus ?thesis using eff rv DsubD' conf that
         by(fastforce simp add: xcpt_eff_def sup_state_opt_any_Some intro: widen_trans[OF widen_subcls])
     next
       case None
       with that eff rv conf DsubThrowable show ?thesis
         by(fastforce simp add: xcpt_eff_def sup_state_opt_any_Some intro: widen_trans[OF widen_subcls])
     qed
 
     with conf loc stk hxcp have "conf_f P h (ST',LT') ins ?f" 
       by (auto simp add: defs1 conf_def intro: list_all2_dropI)
 
     with meth h_ok frames \<Phi>_pc' fr match hxcp tconf preh
     show ?thesis unfolding correct_state_def
       by(fastforce dest: sees_method_fun simp add: cname_of_def)
   qed
 qed
 
 end
 
 subsection \<open>Single Instructions\<close>
 
 text \<open>
   In this subsection we prove for each single (welltyped) instruction
   that the state after execution of the instruction still conforms.
   Since we have already handled raised exceptions above, we can now assume that
   no exception has been raised in this step.
 \<close>
 
 context JVM_conf_read begin
 
 declare defs1 [simp]
 
 lemma Invoke_correct: 
   fixes \<sigma>' :: "('addr, 'heap) jvm_state"
   assumes wtprog: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   assumes meth_C: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:    "ins ! pc = Invoke M' n"
   assumes wti:    "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes approx: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes exec: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t:\<sigma> \<surd>"
 proof -
   note split_paired_Ex [simp del]
   
   from wtprog obtain wfmb where wfprog: "wf_prog wfmb P" 
     by (simp add: wf_jvm_prog_phi_def)
       
   from ins meth_C approx obtain ST LT where
     heap_ok: "hconf h" and
     tconf:   "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (fastforce dest: sees_method_fun)
 
   from ins wti \<Phi>_pc
   have n: "n < size ST" by simp
   
   show ?thesis
   proof(cases "stk!n = Null")
     case True
     with ins heap_ok \<Phi>_pc frame frames exec meth_C tconf preh show ?thesis
       by(fastforce elim: wf_preallocatedE[OF wfprog, where C=NullPointer])
   next
     case False
     note Null = this
     have NT: "ST!n \<noteq> NT"
     proof
       assume "ST!n = NT"
       moreover from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
       with n have "P,h \<turnstile> stk!n :\<le> ST!n" by (simp add: list_all2_conv_all_nth)
       ultimately have "stk!n = Null" by simp
       with Null show False by contradiction
     qed
 
     from frame obtain 
       stk: "P,h \<turnstile> stk [:\<le>] ST" and
       loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" by simp
 
     from NT ins wti \<Phi>_pc have pc': "pc+1 < size ins" by simp
 
     from NT ins wti \<Phi>_pc obtain ST' LT'
       where pc': "pc+1 < size ins"
       and \<Phi>': "\<Phi> C M ! (pc+1) = Some (ST', LT')"
       and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'"
       by(auto simp add: neq_Nil_conv sup_state_opt_any_Some split: if_split_asm)
     with NT ins wti \<Phi>_pc obtain D D' TTs TT m
       where D: "class_type_of' (ST!n) = \<lfloor>D\<rfloor>"
       and m_D: "P \<turnstile> D sees M': TTs\<rightarrow>TT = m in D'"
       and Ts:  "P \<turnstile> rev (take n ST) [\<le>] TTs"
       and ST': "P \<turnstile> (TT # drop (n+1) ST) [\<le>] ST'" 
       by(auto)
 
     from n stk D have "P,h \<turnstile> stk!n :\<le> ST ! n"
       by (auto simp add: list_all2_conv_all_nth)
       
     from \<open>P,h \<turnstile> stk!n :\<le> ST ! n\<close> Null D
     obtain U a where
       Addr:   "stk!n = Addr a" and
       obj:    "typeof_addr h a = Some U" and
       UsubSTn: "P \<turnstile> ty_of_htype U \<le> ST ! n"
       by(cases "stk ! n")(auto simp add: conf_def widen_Class)
 
     from D UsubSTn obtain C' where
       C': "class_type_of' (ty_of_htype U) = \<lfloor>C'\<rfloor>" and C'subD: "P \<turnstile> C' \<preceq>\<^sup>* D"
       by(rule widen_is_class_type_of) simp
 
     with wfprog m_D
     obtain Ts' T' D'' meth' where
       m_C': "P \<turnstile> C' sees M': Ts'\<rightarrow>T' = meth' in D''" and
       T':   "P \<turnstile> T' \<le> TT" and
       Ts':  "P \<turnstile> TTs [\<le>] Ts'" 
       by (auto dest: sees_method_mono)
 
     from Ts n have [simp]: "size TTs = n" 
       by (auto dest: list_all2_lengthD simp: min_def)
     with Ts' have [simp]: "size Ts' = n" 
       by (auto dest: list_all2_lengthD)
 
     from m_C' wfprog
     obtain mD'': "P \<turnstile> D'' sees M':Ts'\<rightarrow>T'=meth' in D''"
       by (fast dest: sees_method_idemp)
 
     { fix mxs' mxl' ins' xt'
       assume [simp]: "meth' = \<lfloor>(mxs', mxl', ins', xt')\<rfloor>"
       let ?loc' = "Addr a # rev (take n stk) @ replicate mxl' undefined_value"
       let ?f' = "([], ?loc', D'', M', 0)"
       let ?f  = "(stk, loc, C, M, pc)"
       
       from Addr obj m_C' ins meth_C exec C' False
       have s': "\<sigma> = (None, h, ?f' # ?f # frs)" by(auto split: if_split_asm)
       
       moreover 
       from wtprog mD''
       obtain start: "wt_start P D'' Ts' mxl' (\<Phi> D'' M')" and ins': "ins' \<noteq> []"
         by (auto dest: wt_jvm_prog_impl_wt_start)
       then obtain LT\<^sub>0 where LT\<^sub>0: "\<Phi> D'' M' ! 0 = Some ([], LT\<^sub>0)"
         by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
       moreover
       have "conf_f P h ([], LT\<^sub>0) ins' ?f'"
       proof -
         let ?LT = "OK (Class D'') # (map OK Ts') @ (replicate mxl' Err)"
         
         from stk have "P,h \<turnstile> take n stk [:\<le>] take n ST" ..
         hence "P,h \<turnstile> rev (take n stk) [:\<le>] rev (take n ST)" by simp
         also note Ts also note Ts' finally
         have "P,h \<turnstile> rev (take n stk) [:\<le>\<^sub>\<top>] map OK Ts'" by simp 
         also
         have "P,h \<turnstile> replicate mxl' undefined_value [:\<le>\<^sub>\<top>] replicate mxl' Err" by simp
         also from m_C' have "P \<turnstile> C' \<preceq>\<^sup>* D''" by (rule sees_method_decl_above)
         from obj heap_ok have "is_htype P U" by (rule typeof_addr_is_type)
         with C' have "P \<turnstile> ty_of_htype U \<le> Class C'" 
           by(cases U)(simp_all add: widen_array_object)
         with \<open>P \<turnstile> C' \<preceq>\<^sup>* D''\<close> obj C' have "P,h \<turnstile> Addr a :\<le> Class D''"
           by (auto simp add: conf_def intro: widen_trans)
         ultimately
         have "P,h \<turnstile> ?loc' [:\<le>\<^sub>\<top>] ?LT" by simp
         also from start LT\<^sub>0 have "P \<turnstile> \<dots> [\<le>\<^sub>\<top>] LT\<^sub>0" by (simp add: wt_start_def)
         finally have "P,h \<turnstile> ?loc' [:\<le>\<^sub>\<top>] LT\<^sub>0" .
         thus ?thesis using ins' by simp
       qed
       ultimately have ?thesis using s' \<Phi>_pc approx meth_C m_D T' ins D tconf C' mD''
         by (fastforce dest: sees_method_fun [of _ C]) }
     moreover
     { assume [simp]: "meth' = Native"
       with wfprog m_C' have "D''\<bullet>M'(Ts') :: T'" by(simp add: sees_wf_native)
       with C' m_C' have nec: "is_native P U M'" by(auto intro: is_native.intros)
 
       from ins n Addr obj exec m_C' C'
       obtain va h' tas' where va: "(tas', va, h') \<in> red_external_aggr P t a M' (rev (take n stk)) h"
         and \<sigma>: "\<sigma> = extRet2JVM n h' stk loc C M pc frs va" by(auto)
       from va nec obj have hext: "h \<unlhd> h'" by(auto intro: red_external_aggr_hext)
       with frames have frames': "conf_fs P h' \<Phi> M (length Ts) T frs" by(rule conf_fs_hext)
       from preh hext have preh': "preallocated h'" by(rule preallocated_hext)      
       from va nec obj tconf have tconf': "P,h' \<turnstile> t \<surd>t"
         by(auto dest: red_external_aggr_preserves_tconf)
       from hext obj have obj': "typeof_addr h' a = \<lfloor>U\<rfloor>" by(rule typeof_addr_hext_mono)
 
       from stk have "P,h \<turnstile> take n stk [:\<le>] take n ST" by(rule list_all2_takeI)
       then obtain Us where "map typeof\<^bsub>h\<^esub> (take n stk) = map Some Us" "P \<turnstile> Us [\<le>] take n ST"
         by(auto simp add: confs_conv_map)
       hence Us: "map typeof\<^bsub>h\<^esub> (rev (take n stk)) = map Some (rev Us)" "P \<turnstile> rev Us [\<le>] rev (take n ST)"
         by- (simp only: rev_map[symmetric], simp)
       from \<open>P \<turnstile> rev Us [\<le>] rev (take n ST)\<close> Ts Ts'
       have "P \<turnstile> rev Us [\<le>] Ts'" by(blast intro: widens_trans)
       with obj \<open>map typeof\<^bsub>h\<^esub> (rev (take n stk)) = map Some (rev Us)\<close> C' m_C' 
       have wtext': "P,h \<turnstile> a\<bullet>M'(rev (take n stk)) : T'" by(simp add: external_WT'.intros)
       from va have va': "P,t \<turnstile> \<langle>a\<bullet>M'(rev (take n stk)),h\<rangle> -tas'\<rightarrow>ext \<langle>va,h'\<rangle>"
         by(unfold WT_red_external_list_conv[OF wfprog wtext' tconf])
       with heap_ok wtext' tconf wfprog have heap_ok': "hconf h'" by(auto dest: external_call_hconf)
 
       have ?thesis
       proof(cases va)
         case (RetExc a')
         from frame hext have "conf_f P h' (ST, LT) ins (stk, loc, C, M, pc)" by(rule conf_f_hext)
         with \<sigma> tconf' heap_ok' meth_C \<Phi>_pc frames' RetExc red_external_conf_extRet[OF wfprog va' wtext' heap_ok preh tconf] ins preh'
         show ?thesis by(fastforce simp add: conf_def widen_Class)
       next
         case RetStaySame
         from frame hext have "conf_f P h' (ST, LT) ins (stk, loc, C, M, pc)" by(rule conf_f_hext)
         with \<sigma> heap_ok' meth_C \<Phi>_pc RetStaySame frames' tconf' preh' show ?thesis by fastforce
       next
         case (RetVal v)
         with \<sigma> have \<sigma>: "\<sigma> = (None, h', (v # drop (n+1) stk, loc, C, M, pc+1) # frs)" by simp
         from heap_ok wtext' va' RetVal preh tconf have "P,h' \<turnstile> v :\<le> T'"
           by(auto dest: red_external_conf_extRet[OF wfprog])
         from stk have "P,h \<turnstile> drop (n + 1) stk [:\<le>] drop (n+1) ST" by(rule list_all2_dropI)
         hence "P,h' \<turnstile> drop (n + 1) stk [:\<le>] drop (n+1) ST" using hext by(rule confs_hext)
         with \<open>P,h' \<turnstile> v :\<le> T'\<close> have "P,h' \<turnstile> v # drop (n + 1) stk [:\<le>] T' # drop (n+1) ST"
           by(auto simp add: conf_def intro: widen_trans)
         also
         with NT ins wti \<Phi>_pc \<Phi>' nec False D m_D T'
         have "P \<turnstile> (T' # drop (n + 1) ST) [\<le>] ST'"
           by(auto dest: sees_method_fun intro: widen_trans)
         also from loc hext have "P,h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT" by(rule confTs_hext)
         hence "P,h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" using LT' by(rule confTs_widen)
         ultimately show ?thesis using \<open>hconf h'\<close> \<sigma> meth_C \<Phi>' pc' frames' tconf' preh' by fastforce
       qed }
     ultimately show ?thesis by(cases meth') auto
   qed
 qed
 
 declare list_all2_Cons2 [iff]
 
 lemma Return_correct:
   assumes wt_prog: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins: "ins ! pc = Return"
   assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes correct: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes s': "(tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs)"
   shows "\<Phi> \<turnstile> t:\<sigma>'\<surd>"
 proof -
   from wt_prog 
   obtain wfmb where wf: "wf_prog wfmb P" by (simp add: wf_jvm_prog_phi_def)
 
   from meth ins s' correct
   have "frs = [] \<Longrightarrow> ?thesis" by (simp add: correct_state_def)
   moreover
   { fix f frs' assume frs': "frs = f#frs'"
     moreover obtain stk' loc' C' M' pc' where 
       f: "f = (stk',loc',C',M',pc')" by (cases f)
     moreover note meth ins s'
     ultimately
     have \<sigma>':
       "\<sigma>' = (None,h,(hd stk#(drop (1+size Ts) stk'),loc',C',M',pc'+1)#frs')"
       (is "\<sigma>' = (None,h,?f'#frs')")
       by simp
     
     from correct meth
     obtain ST LT where
       h_ok:   "hconf h" and
       tconf: "P,h \<turnstile> t \<surd>t" and
       \<Phi>_pc: "\<Phi> C M ! pc = Some (ST, LT)" and
       frame:  "conf_f P h (ST, LT) ins (stk,loc,C,M,pc)" and
       frames: "conf_fs P h \<Phi> M (size Ts) T frs" and
       preh: "preallocated h"
       by (auto dest: sees_method_fun)
 
     from \<Phi>_pc ins wt
     obtain U ST\<^sub>0 where "ST = U # ST\<^sub>0" "P \<turnstile> U \<le> T"
       by (simp add: wt_instr_def app_def) blast    
     with wf frame 
     have hd_stk: "P,h \<turnstile> hd stk :\<le> T" by (auto simp add: conf_f_def)
 
     from f frs' frames
     obtain ST' LT' Ts'' T'' mxs' mxl\<^sub>0' ins' xt' Ts' T' where
       \<Phi>': "\<Phi> C' M' ! pc' = Some (ST', LT')" and
       meth_C':  "P \<turnstile> C' sees M':Ts''\<rightarrow>T''=\<lfloor>(mxs',mxl\<^sub>0',ins',xt')\<rfloor> in C'" and
       ins': "ins' ! pc' = Invoke M (size Ts)" and
       D: "\<exists>D m D'. class_type_of' (ST' ! (size Ts)) = Some D \<and> P \<turnstile> D sees M: Ts'\<rightarrow>T' = m in D'" and
       T': "P \<turnstile> T \<le> T'" and
       frame':   "conf_f P h (ST',LT') ins' f" and
       conf_fs:  "conf_fs P h \<Phi> M' (size Ts'') T'' frs'"
       by clarsimp blast
 
     from f frame' obtain
       stk': "P,h \<turnstile> stk' [:\<le>] ST'" and
       loc': "P,h \<turnstile> loc' [:\<le>\<^sub>\<top>] LT'" and
       pc':  "pc' < size ins'"
       by (simp add: conf_f_def)
     
     from wt_prog meth_C' pc'  
     have wti: "P,T'',mxs',size ins',xt' \<turnstile> ins'!pc',pc' :: \<Phi> C' M'"
       by (rule wt_jvm_prog_impl_wt_instr)
 
     obtain aTs ST'' LT'' where
       \<Phi>_suc:   "\<Phi> C' M' ! Suc pc' = Some (ST'', LT'')" and
       less:    "P \<turnstile> (T' # drop (size Ts+1) ST', LT') \<le>\<^sub>i (ST'', LT'')" and
       suc_pc': "Suc pc' < size ins'"
       using ins' \<Phi>' D T' wti
       by(fastforce simp add: sup_state_opt_any_Some split: if_split_asm)
 
     from hd_stk T' have hd_stk': "P,h \<turnstile> hd stk :\<le> T'"  ..
         
     have frame'':
       "conf_f P h (ST'',LT'') ins' ?f'" 
     proof -
       from stk'
       have "P,h \<turnstile> drop (1+size Ts) stk' [:\<le>] drop (1+size Ts) ST'" ..
       moreover
       with hd_stk' less
       have "P,h \<turnstile> hd stk # drop (1+size Ts) stk' [:\<le>] ST''" by auto
       moreover
       from wf loc' less have "P,h \<turnstile> loc' [:\<le>\<^sub>\<top>] LT''" by auto
       moreover note suc_pc' 
       ultimately show ?thesis by (simp add: conf_f_def)
     qed
 
     with \<sigma>' frs' f meth h_ok hd_stk \<Phi>_suc frames meth_C' \<Phi>'  tconf preh
     have ?thesis by (fastforce dest: sees_method_fun [of _ C'])
   }
   ultimately
   show ?thesis by (cases frs) blast+
 qed
 
 declare sup_state_opt_any_Some [iff]
 declare not_Err_eq [iff] 
 
 lemma Load_correct:
 "\<lbrakk> wf_prog wt P;
     P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
     ins!pc = Load idx; 
     P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
     \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd> ;
     (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>' \<surd>"
   by (fastforce dest: sees_method_fun [of _ C] elim!: confTs_confT_sup)
 
 declare [[simproc del: list_to_set_comprehension]]
 
 lemma Store_correct:
 "\<lbrakk> wf_prog wt P;
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C;
   ins!pc = Store idx;
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
   apply clarsimp 
   apply (drule (1) sees_method_fun)
   apply clarsimp
   apply (blast intro!: list_all2_update_cong)
   done
 
 lemma Push_correct:
 "\<lbrakk> wf_prog wt P;
     P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
     ins!pc = Push v;
     P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
     \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>; 
     (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>" 
   apply clarsimp 
   apply (drule (1) sees_method_fun)
   apply clarsimp
   apply (blast dest: typeof_lit_conf)
   done
 
 declare [[simproc add: list_to_set_comprehension]]
 
 lemma Checkcast_correct:
 "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
     P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
     ins!pc = Checkcast D; 
     P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
     \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
     (tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs \<rbrakk> 
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma> \<surd>"
 using wf_preallocatedD[of "\<lambda>P C (M, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt). wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M)" P h ClassCast]
 apply (clarsimp simp add: wf_jvm_prog_phi_def split: if_split_asm)
  apply(drule (1) sees_method_fun)
  apply(fastforce simp add: conf_def intro: widen_trans)
 apply (drule (1) sees_method_fun)
 apply(fastforce simp add: conf_def intro: widen_trans)
 done
 
 lemma Instanceof_correct:
 "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
     P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
     ins!pc = Instanceof Ty; 
     P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
     \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
     (tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs \<rbrakk> 
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma> \<surd>"
   apply (clarsimp simp add: wf_jvm_prog_phi_def split: if_split_asm)
   apply (drule (1) sees_method_fun)
   apply fastforce
   done
 
 declare split_paired_All [simp del]
 
 end
 
 lemma widens_Cons [iff]:
   "P \<turnstile> (T # Ts) [\<le>] Us = (\<exists>z zs. Us = z # zs \<and> P \<turnstile> T \<le> z \<and> P \<turnstile> Ts [\<le>] zs)"
 by(rule list_all2_Cons1)
 
 context heap_conf_base begin
 
 
 end
 
 context JVM_conf_read begin
 
 lemma Getfield_correct:
   assumes wf: "wf_prog wt P"
   assumes mC: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes i:  "ins!pc = Getfield F D"
   assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes cf: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes xc: "(tas, \<sigma>') \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
 
   shows "\<Phi> \<turnstile> t:\<sigma>'\<surd>"
 proof -
   from mC cf obtain ST LT where    
     "h\<surd>": "hconf h" and
     tconf: "P,h \<turnstile> t \<surd>t" and
     \<Phi>: "\<Phi> C M ! pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     fs: "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh: "preallocated h"
     by (fastforce dest: sees_method_fun)
        
   from i \<Phi> wt obtain oT ST'' vT ST' LT' vT' fm where 
     oT: "P \<turnstile> oT \<le> Class D" and
     ST: "ST = oT # ST''" and
     F:  "P \<turnstile> D sees F:vT (fm) in D" and
     pc': "pc+1 < size ins"  and
     \<Phi>': "\<Phi> C M ! (pc+1) = Some (vT'#ST', LT')" and
     ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and  
     vT': "P \<turnstile> vT \<le> vT'"
     by fastforce                       
 
   from stk ST obtain ref stk' where 
     stk': "stk = ref#stk'" and
     ref:  "P,h \<turnstile> ref :\<le> oT" and
     ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
     by auto
 
   show ?thesis
   proof(cases "ref = Null")
     case True
     with tconf "h\<surd>" i xc stk' mC fs \<Phi> ST'' ref ST loc pc' 
       wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     from ref oT have "P,h \<turnstile> ref :\<le> Class D" ..
     with False obtain a U' D' where a: "ref = Addr a"
       and h: "typeof_addr h a = Some U'"
       and U': "D' = class_type_of U'" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
       by (blast dest: non_npD2)
 
     { fix v
       assume read: "heap_read h a (CField D F) v"
       from D' F have has_field: "P \<turnstile> D' has F:vT (fm) in D"
         by (blast intro: has_field_mono has_visible_field)
       with h have "P,h \<turnstile> a@CField D F : vT" unfolding U' .. 
       with read have v: "P,h \<turnstile> v :\<le> vT" using "h\<surd>"
         by(rule heap_read_conf)
       
       from ST'' ST' have "P,h \<turnstile> stk' [:\<le>] ST'" ..
       moreover
       from v vT' have "P,h \<turnstile> v :\<le> vT'" by blast
       moreover
       from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
       moreover
       note "h\<surd>" mC \<Phi>' pc' v fs tconf preh
       ultimately have "\<Phi> \<turnstile> t:(None, h, (v#stk',loc,C,M,pc+1)#frs) \<surd>" by fastforce }
     with a h i mC stk' xc
     show ?thesis by auto
   qed
 qed
 
 lemma Putfield_correct:
   assumes wf: "wf_prog wt P"
   assumes mC: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes i:  "ins!pc = Putfield F D"
   assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes cf: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes xc: "(tas, \<sigma>') \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t:\<sigma>' \<surd>"
 proof -
   from mC cf obtain ST LT where    
     "h\<surd>": "hconf h" and    
     tconf: "P,h \<turnstile> t \<surd>t" and
     \<Phi>: "\<Phi> C M ! pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     fs: "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh: "preallocated h"
     by (fastforce dest: sees_method_fun)
   
   from i \<Phi> wt obtain vT vT' oT ST'' ST' LT' fm where 
     ST: "ST = vT # oT # ST''" and
     field: "P \<turnstile> D sees F:vT' (fm) in D" and
     oT: "P \<turnstile> oT \<le> Class D" and vT: "P \<turnstile> vT \<le> vT'" and
     pc': "pc+1 < size ins" and 
     \<Phi>': "\<Phi> C M!(pc+1) = Some (ST',LT')" and
     ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'"
     by clarsimp
 
   from stk ST obtain v ref stk' where 
     stk': "stk = v#ref#stk'" and
     v:    "P,h \<turnstile> v :\<le> vT" and 
     ref:  "P,h \<turnstile> ref :\<le> oT" and
     ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
     by auto
 
   show ?thesis
   proof(cases "ref = Null")
     case True
     with tconf "h\<surd>" i xc stk' mC fs \<Phi> ST'' ref ST loc pc' v
       wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     from ref oT have "P,h \<turnstile> ref :\<le> Class D" ..
     with False obtain a U' D' where 
       a: "ref = Addr a" and h: "typeof_addr h a = Some U'"
       and U': "D' = class_type_of U'" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
       by (blast dest: non_npD2)
     
     from v vT have vT': "P,h \<turnstile> v :\<le> vT'" ..
     
     from field D' have has_field: "P \<turnstile> D' has F:vT' (fm) in D"
       by (blast intro: has_field_mono has_visible_field)
     with h have al: "P,h \<turnstile> a@CField D F : vT'" unfolding U' ..
     let ?f' = "(stk',loc,C,M,pc+1)"
 
     { fix h'
       assume "write": "heap_write h a (CField D F) v h'"
       hence hext: "h \<unlhd> h'" by(rule hext_heap_write)
       with preh have "preallocated h'" by(rule preallocated_hext)
       moreover
       from "write" "h\<surd>" al vT' have "hconf h'" by(rule hconf_heap_write_mono)
       moreover
       from ST'' ST' have "P,h \<turnstile> stk' [:\<le>] ST'" ..
       from this hext have "P,h' \<turnstile> stk' [:\<le>] ST'" by (rule confs_hext)
       moreover
       from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
       from this hext have "P,h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" by (rule confTs_hext)
       moreover
       from fs hext
       have "conf_fs P h' \<Phi> M (size Ts) T frs" by (rule conf_fs_hext)
       moreover
       note mC \<Phi>' pc' 
       moreover
       from tconf hext have "P,h' \<turnstile> t \<surd>t" by(rule tconf_hext_mono)
       ultimately have "\<Phi> \<turnstile> t:(None, h', ?f'#frs) \<surd>" by fastforce }
     with a h i mC stk' xc show ?thesis by(auto simp del: correct_state_def)
   qed
 qed
 
 lemma CAS_correct:
   assumes wf: "wf_prog wt P"
   assumes mC: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes i:  "ins!pc = CAS F D"
   assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes cf: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes xc: "(tas, \<sigma>') \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t:\<sigma>' \<surd>"
 proof -
   from mC cf obtain ST LT where    
     "h\<surd>": "hconf h" and    
     tconf: "P,h \<turnstile> t \<surd>t" and
     \<Phi>: "\<Phi> C M ! pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     fs: "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh: "preallocated h"
     by (fastforce dest: sees_method_fun)
   
   from i \<Phi> wt obtain T1 T2 T3 T' ST'' ST' LT' fm where 
     ST: "ST = T3 # T2 # T1 # ST''" and
     field: "P \<turnstile> D sees F:T' (fm) in D" and
     oT: "P \<turnstile> T1 \<le> Class D" and T2: "P \<turnstile> T2 \<le> T'" and T3: "P \<turnstile> T3 \<le> T'" and
     pc': "pc+1 < size ins" and 
     \<Phi>': "\<Phi> C M!(pc+1) = Some (Boolean # ST',LT')" and
     ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'"
     by clarsimp
 
   from stk ST obtain v'' v' v stk' where 
     stk': "stk = v''#v'#v#stk'" and
     v:    "P,h \<turnstile> v :\<le> T1" and 
     v':  "P,h \<turnstile> v' :\<le> T2" and
     v'': "P,h \<turnstile> v'' :\<le> T3" and
     ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
     by auto
 
   show ?thesis
   proof(cases "v = Null")
     case True
     with tconf "h\<surd>" i xc stk' mC fs \<Phi> ST'' v ST loc pc' v' v''
       wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     from v oT have "P,h \<turnstile> v :\<le> Class D" ..
     with False obtain a U' D' where 
       a: "v = Addr a" and h: "typeof_addr h a = Some U'"
       and U': "D' = class_type_of U'" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
       by (blast dest: non_npD2)
     
     from v' T2 have vT': "P,h \<turnstile> v' :\<le> T'" ..
     from v'' T3 have vT'': "P,h \<turnstile> v'' :\<le> T'" ..
     
     from field D' have has_field: "P \<turnstile> D' has F:T' (fm) in D"
       by (blast intro: has_field_mono has_visible_field)
     with h have al: "P,h \<turnstile> a@CField D F : T'" unfolding U' ..
 
     from ST'' ST' have stk'': "P,h \<turnstile> stk' [:\<le>] ST'" ..
     from loc LT' have loc': "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
     { fix h'
       assume "write": "heap_write h a (CField D F) v'' h'"
       hence hext: "h \<unlhd> h'" by(rule hext_heap_write)
       with preh have "preallocated h'" by(rule preallocated_hext)
       moreover
       from "write" "h\<surd>" al vT'' have "hconf h'" by(rule hconf_heap_write_mono)
       moreover
       from stk'' hext have "P,h' \<turnstile> stk' [:\<le>] ST'" by (rule confs_hext)
       moreover
       from loc' hext have "P,h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" by (rule confTs_hext)
       moreover
       from fs hext
       have "conf_fs P h' \<Phi> M (size Ts) T frs" by (rule conf_fs_hext)
       moreover
       note mC \<Phi>' pc' 
       moreover
       let ?f' = "(Bool True # stk',loc,C,M,pc+1)"
       from tconf hext have "P,h' \<turnstile> t \<surd>t" by(rule tconf_hext_mono)
       ultimately have "\<Phi> \<turnstile> t:(None, h', ?f'#frs) \<surd>" by fastforce 
     } moreover {
       let ?f' = "(Bool False # stk',loc,C,M,pc+1)"
       have "\<Phi> \<turnstile> t:(None, h, ?f'#frs) \<surd>" using tconf "h\<surd>" preh mC \<Phi>' stk'' loc' pc' fs
         by fastforce
     } ultimately show ?thesis using a h i mC stk' xc by(auto simp del: correct_state_def)
   qed
 qed
 
 lemma New_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = New X"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t:\<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf:   "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from \<Phi>_pc ins wt
   obtain ST' LT' where
     is_class_X: "is_class P X" and
     mxs:       "size ST < mxs" and
     suc_pc:     "pc+1 < size ins" and
     \<Phi>_suc:      "\<Phi> C M!(pc+1) = Some (ST', LT')" and
     less:       "P \<turnstile> (Class X # ST, LT) \<le>\<^sub>i (ST', LT')"
     by auto
   show ?thesis
   proof(cases "allocate h (Class_type X) = {}")
     case True
     with frame frames tconf suc_pc no_x ins meth \<Phi>_pc
       wf_preallocatedD[OF wf, of h OutOfMemory] preh is_class_X heap_ok
     show ?thesis
       by(fastforce intro: tconf_hext_mono confs_hext confTs_hext conf_fs_hext)
   next
     case False
     with ins meth no_x obtain h' oref 
       where new: "(h', oref) \<in> allocate h (Class_type X)"
       and \<sigma>': "\<sigma> = (None, h', (Addr oref#stk,loc,C,M,pc+1)#frs)" (is "\<sigma> = (None, h', ?f # frs)")
       by auto
 
     from new have hext: "h \<unlhd> h'" by(rule hext_allocate)
     with preh have preh': "preallocated h'" by(rule preallocated_hext)
     from new heap_ok is_class_X have heap_ok': "hconf h'"
       by(auto intro: hconf_allocate_mono)
 
     with new is_class_X have h': "typeof_addr h' oref = \<lfloor>Class_type X\<rfloor>" by(auto dest: allocate_SomeD)
   
     note heap_ok' \<sigma>'
     moreover
     from frame less suc_pc wf h' hext
     have "conf_f P h' (ST', LT') ins ?f"
       apply (clarsimp simp add: fun_upd_apply conf_def split_beta)
       apply (auto intro: confs_hext confTs_hext)
       done
     moreover
     from frames hext have "conf_fs P h' \<Phi> M (size Ts) T frs" by (rule conf_fs_hext)
     moreover from tconf hext have "P,h' \<turnstile> t \<surd>t" by(rule tconf_hext_mono)
     ultimately
     show ?thesis using meth \<Phi>_suc preh' by fastforce
   qed
 qed
 
 lemma Goto_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = Goto branch; 
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>; 
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>' \<surd>"
 apply clarsimp 
 apply (drule (1) sees_method_fun)
 apply fastforce
 done
 
 declare [[simproc del: list_to_set_comprehension]]
 
 lemma IfFalse_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = IfFalse branch; 
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply fastforce
 done
 
 declare [[simproc add: list_to_set_comprehension]]
 
 lemma BinOp_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = BinOpInstr bop;
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply(clarsimp simp add: conf_def)
 apply(drule (2) WTrt_binop_widen_mono)
 apply clarsimp
 apply(frule (2) binop_progress)
 apply(clarsimp split: sum.split_asm)
  apply(frule (5) binop_type)
  apply(fastforce intro: widen_trans simp add: conf_def)
 apply(frule (5) binop_type)
 apply(clarsimp simp add: conf_def)
 apply(clarsimp simp add: widen_Class)
 apply(fastforce intro: widen_trans dest: binop_relevant_class simp add: cname_of_def conf_def)
 done
 
 lemma Pop_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = Pop;
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply fastforce
 done
 
 lemma Dup_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = Dup;
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply fastforce
 done
 
 lemma Swap_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = Swap;
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs) \<rbrakk>
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply fastforce
 done
 
 declare [[simproc del: list_to_set_comprehension]]
 
 lemma Throw_correct:
 "\<lbrakk> wf_prog wt P; 
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C; 
   ins ! pc = ThrowExc; 
   P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M; 
   \<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>;
   (tas, \<sigma>') \<in> exec_instr (ins!pc) P t h stk loc C M pc frs \<rbrakk> 
 \<Longrightarrow> \<Phi> \<turnstile> t:\<sigma>'\<surd>"
 using wf_preallocatedD[of wt P h NullPointer]
 apply(clarsimp)
 apply(drule (1) sees_method_fun)
 apply(auto)
   apply fastforce
  apply fastforce
 apply(drule (1) non_npD)
 apply fastforce+
 done
 
 declare [[simproc add: list_to_set_comprehension]]
 
 lemma NewArray_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = NewArray X"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t:(None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t:\<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf: "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from ins \<Phi>_pc wt obtain ST'' X' ST' LT' where 
     ST: "ST = Integer # ST''" and
     pc': "pc+1 < size ins"  and
     \<Phi>': "\<Phi> C M ! (pc+1) = Some (X'#ST', LT')" and
     ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
     XX': "P \<turnstile> X\<lfloor>\<rceil> \<le> X'" and
     suc_pc:     "pc+1 < size ins" and
     is_type_X: "is_type P (X\<lfloor>\<rceil>)"
     by(fastforce dest: Array_widen)
 
   from stk ST obtain si stk' where si: "stk = Intg si # stk'"
     by(auto simp add: conf_def)
 
   show ?thesis
   proof(cases "si <s 0 \<or> allocate h (Array_type X (nat (sint si))) = {}")
     case True
     with frame frames tconf heap_ok suc_pc no_x ins meth \<Phi>_pc si preh
       wf_preallocatedD[OF wf, of h OutOfMemory] wf_preallocatedD[OF wf, of h NegativeArraySize]
     show ?thesis
       by(fastforce intro: tconf_hext_mono confs_hext confTs_hext conf_fs_hext split: if_split_asm)+
   next
     case False
     with ins meth si no_x obtain h' oref 
       where new: "(h', oref) \<in> allocate h (Array_type X (nat (sint si)))"
       and \<sigma>': "\<sigma> = (None, h', (Addr oref#tl stk,loc,C,M,pc+1)#frs)" (is "\<sigma> = (None, h', ?f # frs)")
       by(auto split: if_split_asm)
     from new have hext: "h \<unlhd> h'" by(rule hext_allocate)
     with preh have preh': "preallocated h'" by(rule preallocated_hext)
     from new heap_ok is_type_X have heap_ok': "hconf h'" by(auto intro: hconf_allocate_mono)
     from False have si': "0 <=s si" by auto
     with new is_type_X have h': "typeof_addr h' oref = \<lfloor>Array_type X (nat (sint si))\<rfloor>" 
       by(auto dest: allocate_SomeD)
 
     note \<sigma>' heap_ok'
     moreover
     from frame ST' ST LT' suc_pc wf XX' h' hext
     have "conf_f P h' (X' # ST', LT') ins ?f"
       by(clarsimp simp add: fun_upd_apply conf_def split_beta)(auto intro: confs_hext confTs_hext)
     moreover
     from frames hext have "conf_fs P h' \<Phi> M (size Ts) T frs" by (rule conf_fs_hext)
     moreover from tconf hext have "P,h' \<turnstile> t \<surd>t" by(rule tconf_hext_mono)
     ultimately
     show ?thesis using meth \<Phi>' preh' by fastforce
   qed 
 qed
 
 lemma ALoad_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = ALoad"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t:\<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf:   "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from ins wt \<Phi>_pc have lST: "length ST > 1" by(auto)
 
   show ?thesis
   proof(cases "hd (tl stk) = Null")
     case True
     with ins no_x heap_ok tconf \<Phi>_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     note stkNN = this
     have STNN: "hd (tl ST) \<noteq> NT"
     proof
       assume "hd (tl ST) = NT"
       moreover 
       from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
       with lST have "P,h \<turnstile> hd (tl stk) :\<le> hd (tl ST)"
         by (cases ST, auto, case_tac list, auto)
       ultimately 
       have "hd (tl stk) = Null" by simp
       with stkNN show False by contradiction
     qed
 
     with stkNN ins \<Phi>_pc wt obtain ST'' X X' ST' LT' where 
       ST: "ST = Integer # X\<lfloor>\<rceil> # ST''" and
       pc': "pc+1 < size ins"  and
       \<Phi>': "\<Phi> C M ! (pc+1) = Some (X'#ST', LT')" and
       ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
       XX': "P \<turnstile> X \<le> X'" and
       suc_pc:     "pc+1 < size ins"
       by(fastforce)
 
     from stk ST obtain ref idx stk' where 
       stk': "stk = idx#ref#stk'" and
       idx: "P,h \<turnstile> idx :\<le> Integer" and
       ref:  "P,h \<turnstile> ref :\<le> X\<lfloor>\<rceil>" and
       ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
       by auto
 
     from stkNN stk' have "ref \<noteq> Null" by(simp)
     with ref obtain a Xel n
       where a: "ref = Addr a"
       and ha: "typeof_addr h a = \<lfloor>Array_type Xel n\<rfloor>"
       and Xel: "P \<turnstile> Xel \<le> X"
       by(cases ref)(fastforce simp add: conf_def widen_Array)+
 
     from idx obtain idxI where idxI: "idx = Intg idxI"
       by(auto simp add: conf_def)
     show ?thesis
     proof(cases "0 <=s idxI \<and> sint idxI < int n")
       case True
       hence si': "0 <=s idxI" "sint idxI < int n" by auto
       hence "nat (sint idxI) < n"
         by (simp add: word_sle_eq nat_less_iff)
       with ha have al: "P,h \<turnstile> a@ACell (nat (sint idxI)) : Xel" ..
 
       { fix v
         assume read: "heap_read h a (ACell (nat (sint idxI))) v"
         hence v: "P,h \<turnstile> v :\<le> Xel" using al heap_ok by(rule heap_read_conf)
 
         let ?f = "(v # stk', loc, C, M, pc + 1)"
         
         from frame ST' ST LT' suc_pc wf XX' Xel idxI si' v ST''
         have "conf_f P h (X' # ST', LT') ins ?f"
           by(auto intro: widen_trans simp add: conf_def)
         hence "\<Phi> \<turnstile> t:(None, h, ?f # frs) \<surd>"
           using meth \<Phi>' heap_ok \<Phi>_pc frames tconf preh by fastforce }
       with ins meth si' stk' a ha no_x idxI idx 
       show ?thesis by(auto simp del: correct_state_def split: if_split_asm)
     next
       case False
       with stk' idxI ins no_x heap_ok tconf meth a ha Xel \<Phi>_pc frame frames
-        wf_preallocatedD[OF wf, of h ArrayIndexOutOfBounds] preh
-      show ?thesis by(fastforce split: if_split_asm)
+        wf_preallocatedD[OF wf, of h ArrayIndexOutOfBounds]
+      show ?thesis 
+        by (fastforce simp: preh split: if_split_asm simp del: Listn.lesub_list_impl_same_size)
     qed
   qed
 qed
 
 
 lemma AStore_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = AStore"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t: \<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf: "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from ins wt \<Phi>_pc have lST: "length ST > 2" by(auto)
   
   show ?thesis
   proof(cases "hd (tl (tl stk)) = Null")
     case True
     with ins no_x heap_ok tconf \<Phi>_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     note stkNN = this
     have STNN: "hd (tl (tl ST)) \<noteq> NT"       
     proof
       assume "hd (tl (tl ST)) = NT"
       moreover 
       from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
       with lST have "P,h \<turnstile> hd (tl (tl stk)) :\<le> hd (tl (tl ST))"
         by (cases ST, auto, case_tac list, auto, case_tac lista, auto)
       ultimately 
       have "hd (tl (tl stk)) = Null" by simp
       with stkNN show False by contradiction
     qed
 
     with ins stkNN \<Phi>_pc wt obtain ST'' Y X ST' LT' where 
       ST: "ST = Y # Integer # X\<lfloor>\<rceil> # ST''" and
       pc': "pc+1 < size ins"  and
       \<Phi>': "\<Phi> C M ! (pc+1) = Some (ST', LT')" and
       ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
       suc_pc:     "pc+1 < size ins"
       by(fastforce)
 
     from stk ST obtain ref e idx stk' where 
       stk': "stk = e#idx#ref#stk'" and
       idx: "P,h \<turnstile> idx :\<le> Integer" and
       ref:  "P,h \<turnstile> ref :\<le> X\<lfloor>\<rceil>" and
       e: "P,h \<turnstile> e :\<le> Y" and
       ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
       by auto
 
     from stkNN stk' have "ref \<noteq> Null" by(simp)
     with ref obtain a Xel n
       where a: "ref = Addr a"
       and ha: "typeof_addr h a = \<lfloor>Array_type Xel n\<rfloor>"
       and Xel: "P \<turnstile> Xel \<le> X"
       by(cases ref)(fastforce simp add: conf_def widen_Array)+
 
     from idx obtain idxI where idxI: "idx = Intg idxI"
       by(auto simp add: conf_def)
     
     show ?thesis
     proof(cases "0 <=s idxI \<and> sint idxI < int n")
       case True
       hence si': "0 <=s idxI" "sint idxI < int n" by simp_all
 
       from e obtain Te where Te: "typeof\<^bsub>h\<^esub> e = \<lfloor>Te\<rfloor>" "P \<turnstile> Te \<le> Y"
         by(auto simp add: conf_def)
 
       show ?thesis
       proof(cases "P \<turnstile> Te \<le> Xel")
         case True
         with Te have eXel: "P,h \<turnstile> e :\<le> Xel"
           by(auto simp add: conf_def intro: widen_trans)
 
         { fix h'
           assume "write": "heap_write h a (ACell (nat (sint idxI))) e h'"
           hence hext: "h \<unlhd> h'" by(rule hext_heap_write)
           with preh have preh': "preallocated h'" by(rule preallocated_hext)
 
           let ?f = "(stk', loc, C, M, pc + 1)"
 
           from si' have "nat (sint idxI) < n"
             by (simp add: word_sle_eq nat_less_iff)
           with ha have "P,h \<turnstile> a@ACell (nat (sint idxI)) : Xel" ..
           with "write" heap_ok have heap_ok': "hconf h'" using eXel
             by(rule hconf_heap_write_mono)
           moreover
           from ST stk stk' ST' have "P,h \<turnstile> stk' [:\<le>] ST'" by auto
           with hext have stk'': "P,h' \<turnstile> stk' [:\<le>] ST'"
             by- (rule confs_hext)
           moreover
           from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
           with hext have "P,h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" by - (rule confTs_hext)
           moreover
           with frame ST' ST LT' suc_pc wf Xel idxI si' stk''
           have "conf_f P h' (ST', LT') ins ?f"
             by(clarsimp)
           with frames hext have "conf_fs P h' \<Phi> M (size Ts) T frs" by- (rule conf_fs_hext)
           moreover from tconf hext have "P,h' \<turnstile> t \<surd>t" by(rule tconf_hext_mono)
           ultimately have "\<Phi> \<turnstile> t:(None, h', ?f # frs) \<surd>" using meth \<Phi>' \<Phi>_pc suc_pc preh'
             by(fastforce) }
         with True si' ins meth stk' a ha no_x idxI idx Te
         show ?thesis
           by(auto split: if_split_asm simp del: correct_state_def intro: widen_trans)
       next
         case False
-        with stk' idxI ins no_x heap_ok tconf meth a ha Xel Te \<Phi>_pc frame frames si' preh
+        with stk' idxI ins no_x heap_ok tconf meth a ha Xel Te \<Phi>_pc frame frames si'
           wf_preallocatedD[OF wf, of h ArrayStore]
-        show ?thesis by(fastforce split: if_split_asm)
+        show ?thesis
+          by (fastforce split: if_splits list.splits simp: preh
+              simp del: Listn.lesub_list_impl_same_size)
       qed
     next
       case False
       with stk' idxI ins no_x heap_ok tconf meth a ha Xel \<Phi>_pc frame frames preh
         wf_preallocatedD[OF wf, of h ArrayIndexOutOfBounds]
       show ?thesis by(fastforce split: if_split_asm)
     qed
   qed
 qed
 
 lemma ALength_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = ALength"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t: \<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf:   "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from ins wt \<Phi>_pc have lST: "length ST > 0" by(auto)
   
   show ?thesis
   proof(cases "hd stk = Null")
     case True
     with ins no_x heap_ok tconf \<Phi>_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     note stkNN = this
     have STNN: "hd ST \<noteq> NT"
     proof
       assume "hd ST = NT"
       moreover 
       from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
       with lST have "P,h \<turnstile> hd stk :\<le> hd ST"
         by (cases ST, auto)
       ultimately 
       have "hd stk = Null" by simp
       with stkNN show False by contradiction
     qed
 
     with stkNN ins \<Phi>_pc wt obtain ST'' X ST' LT' where 
       ST: "ST = (X\<lfloor>\<rceil>) # ST''" and
       pc': "pc+1 < size ins"  and
       \<Phi>': "\<Phi> C M ! (pc+1) = Some (ST', LT')" and
       ST': "P \<turnstile> (Integer # ST'') [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
       suc_pc:     "pc+1 < size ins"
       by(fastforce)
 
     from stk ST obtain ref stk' where 
       stk': "stk = ref#stk'" and
       ref:  "P,h \<turnstile> ref :\<le> X\<lfloor>\<rceil>" and
       ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
       by auto
 
     from stkNN stk' have "ref \<noteq> Null" by(simp)
     with ref obtain a Xel n
       where a: "ref = Addr a"
       and ha: "typeof_addr h a = \<lfloor>Array_type Xel n\<rfloor>"
       and Xel: "P \<turnstile> Xel \<le> X"
       by(cases ref)(fastforce simp add: conf_def widen_Array)+
 
     from ins meth stk' a ha no_x have \<sigma>':
       "\<sigma> = (None, h, (Intg (word_of_int (int n)) # stk', loc, C, M, pc + 1) # frs)"
       (is "\<sigma> = (None, h, ?f # frs)")
       by(auto)
     moreover
     from ST stk stk' ST' have "P,h \<turnstile> Intg si # stk' [:\<le>] ST'" by(auto)
     with frame ST' ST LT' suc_pc wf
     have "conf_f P h (ST', LT') ins ?f"
       by(fastforce intro: widen_trans)
     ultimately show ?thesis using meth \<Phi>' heap_ok \<Phi>_pc frames tconf preh by fastforce
   qed
 qed
 
 
 lemma MEnter_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = MEnter"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t: \<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf:   "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from ins wt \<Phi>_pc have lST: "length ST > 0" by(auto)
 
   show ?thesis
   proof(cases "hd stk = Null")
     case True
     with ins no_x heap_ok tconf \<Phi>_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     note stkNN = this
     have STNN: "hd ST \<noteq> NT"
     proof
       assume "hd ST = NT"
       moreover 
       from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
       with lST have "P,h \<turnstile> hd stk :\<le> hd ST"
         by (cases ST, auto)
       ultimately 
       have "hd stk = Null" by simp
       with stkNN show False by contradiction
     qed
 
     with stkNN ins \<Phi>_pc wt obtain ST'' X ST' LT' where 
       ST: "ST = X # ST''" and
       refT: "is_refT X" and
       pc': "pc+1 < size ins"  and
       \<Phi>': "\<Phi> C M ! (pc+1) = Some (ST', LT')" and
       ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
       suc_pc:     "pc+1 < size ins"
       by(fastforce)
 
     from stk ST obtain ref stk' where 
       stk': "stk = ref#stk'" and
       ref:  "P,h \<turnstile> ref :\<le> X"
       by auto
 
     from stkNN stk' have "ref \<noteq> Null" by(simp)
     moreover
     from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
     moreover
     from ST stk stk' ST'
     have "P,h \<turnstile> stk' [:\<le>] ST'" by(auto)
     ultimately show ?thesis using meth \<Phi>' heap_ok \<Phi>_pc suc_pc frames loc LT' no_x ins stk' ST' tconf preh
       by(fastforce)
   qed
 qed
 
 lemma MExit_correct:
   assumes wf:   "wf_prog wt P"
   assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C"
   assumes ins:  "ins!pc = MExit"
   assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
   assumes conf: "\<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
   assumes no_x: "(tas, \<sigma>) \<in> exec_instr (ins!pc) P t h stk loc C M pc frs"
   shows "\<Phi> \<turnstile> t: \<sigma> \<surd>"
 proof - 
   from ins conf meth
   obtain ST LT where
     heap_ok: "hconf h" and
     tconf:   "P,h \<turnstile> t \<surd>t" and
     \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
     stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
     pc: "pc < size ins" and 
     frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
     frames:  "conf_fs P h \<Phi> M (size Ts) T frs" and
     preh:    "preallocated h"
     by (auto dest: sees_method_fun)
 
   from ins wt \<Phi>_pc have lST: "length ST > 0" by(auto)
 
   show ?thesis
   proof(cases "hd stk = Null")
     case True
     with ins no_x heap_ok tconf \<Phi>_pc stk loc frame frames meth wf_preallocatedD[OF wf, of h NullPointer] preh
     show ?thesis by(fastforce)
   next
     case False
     note stkNN = this
     have STNN: "hd ST \<noteq> NT"
     proof
       assume "hd ST = NT"
       moreover 
       from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
       with lST have "P,h \<turnstile> hd stk :\<le> hd ST"
         by (cases ST, auto)
       ultimately 
       have "hd stk = Null" by simp
       with stkNN show False by contradiction
     qed
 
     with stkNN ins \<Phi>_pc wt obtain ST'' X ST' LT' where 
       ST: "ST = X # ST''" and
       refT: "is_refT X" and
       pc': "pc+1 < size ins"  and
       \<Phi>': "\<Phi> C M ! (pc+1) = Some (ST', LT')" and
       ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
       suc_pc:     "pc+1 < size ins"
       by(fastforce)
 
     from stk ST obtain ref stk' where 
       stk': "stk = ref#stk'" and
       ref:  "P,h \<turnstile> ref :\<le> X"
       by auto
 
     from stkNN stk' have "ref \<noteq> Null" by(simp)
     moreover
     from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
     moreover
     from ST stk stk' ST'
     have "P,h \<turnstile> stk' [:\<le>] ST'" by(auto)
     ultimately 
     show ?thesis using meth \<Phi>' heap_ok \<Phi>_pc suc_pc frames loc LT' no_x ins stk' ST' tconf frame preh
       wf_preallocatedD[OF wf, of h IllegalMonitorState]
       by(fastforce)
   qed
 qed
 
 text \<open>
   The next theorem collects the results of the sections above,
   i.e.~exception handling and the execution step for each 
   instruction. It states type safety for single step execution:
   in welltyped programs, a conforming state is transformed
   into another conforming state when one instruction is executed.
 \<close>
 theorem instr_correct:
 "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
   P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> in C;
   (tas, \<sigma>') \<in> exec P t (None, h, (stk,loc,C,M,pc)#frs); 
   \<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk> 
 \<Longrightarrow> \<Phi> \<turnstile> t: \<sigma>'\<surd>"
 apply (subgoal_tac "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M")
  prefer 2
  apply (erule wt_jvm_prog_impl_wt_instr, assumption)
  apply clarsimp
  apply (drule (1) sees_method_fun)
  apply simp
 apply(unfold exec.simps Let_def set_map)
 apply (frule wt_jvm_progD, erule exE)
 apply (cases "ins ! pc")
 apply (rule Load_correct, assumption+, fastforce)
 apply (rule Store_correct, assumption+, fastforce)
 apply (rule Push_correct, assumption+, fastforce)
 apply (rule New_correct, assumption+, fastforce)
 apply (rule NewArray_correct, assumption+, fastforce)
 apply (rule ALoad_correct, assumption+, fastforce)
 apply (rule AStore_correct, assumption+, fastforce)
 apply (rule ALength_correct, assumption+, fastforce)
 apply (rule Getfield_correct, assumption+, fastforce)
 apply (rule Putfield_correct, assumption+, fastforce)
 apply (rule CAS_correct, assumption+, fastforce)
 apply (rule Checkcast_correct, assumption+, fastforce)
 apply (rule Instanceof_correct, assumption+, fastforce)
 apply (rule Invoke_correct, assumption+, fastforce)
 apply (rule Return_correct, assumption+, fastforce simp add: split_beta)
 apply (rule Pop_correct, assumption+, fastforce)
 apply (rule Dup_correct, assumption+, fastforce)
 apply (rule Swap_correct, assumption+, fastforce)
 apply (rule BinOp_correct, assumption+, fastforce)
 apply (rule Goto_correct, assumption+, fastforce)
 apply (rule IfFalse_correct, assumption+, fastforce)
 apply (rule Throw_correct, assumption+, fastforce)
 apply (rule MEnter_correct, assumption+, fastforce)
 apply (rule MExit_correct, assumption+, fastforce)
 done
 
 declare defs1 [simp del]
 
 end
 
 subsection \<open>Main\<close>
 
 lemma (in JVM_conf_read) BV_correct_1 [rule_format]:
 "\<And>\<sigma>. \<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P; \<Phi> \<turnstile> t: \<sigma>\<surd>\<rbrakk> \<Longrightarrow> P,t \<turnstile> \<sigma> -tas-jvm\<rightarrow> \<sigma>' \<longrightarrow> \<Phi> \<turnstile> t: \<sigma>'\<surd>"
 apply (simp only: split_tupled_all exec_1_iff)
 apply (rename_tac xp h frs)
 apply (case_tac xp)
  apply (case_tac frs)
   apply simp
  apply (simp only: split_tupled_all)
  apply hypsubst
  apply (frule correct_state_impl_Some_method)
  apply clarify
  apply (rule instr_correct)
  apply assumption+
 apply clarify
 apply(case_tac frs)
  apply simp
 apply(clarsimp simp only: exec.simps set_simps)
 apply(erule (1) exception_step_conform)
 done
 
 theorem (in JVM_progress) progress:
   assumes wt: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and cs: "\<Phi> \<turnstile> t: (xcp, h, f # frs)\<surd>"
   shows "\<exists>ta \<sigma>'. P,t \<turnstile> (xcp, h, f # frs) -ta-jvm\<rightarrow> \<sigma>'"
 proof -
   obtain stk loc C M pc where f: "f = (stk, loc, C, M, pc)" by(cases f)
   with cs obtain Ts T mxs mxl\<^sub>0 "is" xt ST LT
     where hconf: "hconf h"
     and sees: "P \<turnstile> C sees M: Ts\<rightarrow>T = \<lfloor>(mxs, mxl\<^sub>0, is, xt)\<rfloor> in C"
     and \<Phi>_pc: "\<Phi> C M ! pc = \<lfloor>(ST, LT)\<rfloor>"
     and ST: "P,h \<turnstile> stk [:\<le>] ST"
     and LT: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT"
     and pc: "pc < length is"
     by(auto simp add: defs1)
   show ?thesis
   proof(cases xcp)
     case Some thus ?thesis
       unfolding f exec_1_iff by auto
   next
     case [simp]: None
     note [simp del] = split_paired_Ex
     note [simp] = defs1 list_all2_Cons2
 
 
     from wt obtain wf_md where wf: "wf_prog wf_md P" by(auto dest: wt_jvm_progD)
     from wt sees pc have wt: "P,T,mxs,size is,xt \<turnstile> is!pc,pc :: \<Phi> C M"
       by(rule wt_jvm_prog_impl_wt_instr)
 
 
     have "\<exists>ta \<sigma>'. (ta, \<sigma>') \<in> exec_instr (is ! pc) P t h stk loc C M pc frs"
     proof(cases "is ! pc")
       case [simp]: ALoad
       with wt \<Phi>_pc have lST: "length ST > 1" by(auto)
       show ?thesis
       proof(cases "hd (tl stk) = Null")
         case True thus ?thesis by simp
       next
         case False
         have STNN: "hd (tl ST) \<noteq> NT"
         proof
           assume "hd (tl ST) = NT"
           moreover 
           from ST lST have "P,h \<turnstile> hd (tl stk) :\<le> hd (tl ST)"
             by (cases ST)(auto, case_tac list, auto)
           ultimately have "hd (tl stk) = Null" by simp
           with False show False by contradiction
         qed
         
         with False \<Phi>_pc wt obtain ST'' X where "ST = Integer # X\<lfloor>\<rceil> # ST''" by auto
         with ST obtain ref idx stk' where stk': "stk = idx#ref#stk'" and idx: "P,h \<turnstile> idx :\<le> Integer" 
           and ref:  "P,h \<turnstile> ref :\<le> X\<lfloor>\<rceil>" by(auto)
 
         from False stk' have "ref \<noteq> Null" by(simp)
         with ref obtain a Xel n where a: "ref = Addr a"
           and ha: "typeof_addr h a = \<lfloor>Array_type Xel n\<rfloor>"
           and Xel: "P \<turnstile> Xel \<le> X"
           by(cases ref)(fastforce simp add: conf_def widen_Array)+
         
         from idx obtain idxI where idxI: "idx = Intg idxI"
           by(auto simp add: conf_def)
         show ?thesis
         proof(cases "0 <=s idxI \<and> sint idxI < int n")
           case True
           hence si': "0 <=s idxI" "sint idxI < int n" by auto
           hence "nat (sint idxI) < n"
             by (simp add: word_sle_eq nat_less_iff)
           with ha have al: "P,h \<turnstile> a@ACell (nat (sint idxI)) : Xel" ..
           from heap_read_total[OF hconf this] True False ha stk' idxI a
           show ?thesis by auto
         next
           case False with ha stk' idxI a show ?thesis by auto
         qed
       qed
     next
       case [simp]: AStore
       from wt \<Phi>_pc have lST: "length ST > 2" by(auto)
       
       show ?thesis
       proof(cases "hd (tl (tl stk)) = Null")
         case True thus ?thesis by(fastforce)
       next
         case False
         note stkNN = this
         have STNN: "hd (tl (tl ST)) \<noteq> NT"       
         proof
           assume "hd (tl (tl ST)) = NT"
           moreover 
           from ST lST have "P,h \<turnstile> hd (tl (tl stk)) :\<le> hd (tl (tl ST))"
             by (cases ST, auto, case_tac list, auto, case_tac lista, auto)
           ultimately have "hd (tl (tl stk)) = Null" by simp
           with stkNN show False by contradiction
         qed
 
         with stkNN \<Phi>_pc wt obtain ST'' Y X
           where "ST = Y # Integer # X\<lfloor>\<rceil> # ST''" by(fastforce)
 
         with ST obtain ref e idx stk' where stk': "stk = e#idx#ref#stk'" 
           and idx: "P,h \<turnstile> idx :\<le> Integer" and ref:  "P,h \<turnstile> ref :\<le> X\<lfloor>\<rceil>" 
           and e: "P,h \<turnstile> e :\<le> Y" by auto
 
         from stkNN stk' have "ref \<noteq> Null" by(simp)
         with ref obtain a Xel n where a: "ref = Addr a"
           and ha: "typeof_addr h a = \<lfloor>Array_type Xel n\<rfloor>"
           and Xel: "P \<turnstile> Xel \<le> X"
           by(cases ref)(fastforce simp add: conf_def widen_Array)+
 
         from idx obtain idxI where idxI: "idx = Intg idxI"
           by(auto simp add: conf_def)
         
         show ?thesis
         proof(cases "0 <=s idxI \<and> sint idxI < int n")
           case True
           hence si': "0 <=s idxI" "sint idxI < int n" by simp_all
           hence "nat (sint idxI) < n"
             by (simp add: word_sle_eq nat_less_iff)
           with ha have adal: "P,h \<turnstile> a@ACell (nat (sint idxI)) : Xel" ..
           
           show ?thesis
           proof(cases "P \<turnstile> the (typeof\<^bsub>h\<^esub> e) \<le> Xel")
             case False
             with ha stk' idxI a show ?thesis by auto
           next
             case True
             hence "P,h \<turnstile> e :\<le> Xel" using e by(auto simp add: conf_def)
             from heap_write_total[OF hconf adal this] ha stk' idxI a show ?thesis by auto
           qed
         next
           case False with ha stk' idxI a show ?thesis by auto
         qed
       qed
     next
       case [simp]: (Getfield F D)
 
       from \<Phi>_pc wt obtain oT ST'' vT fm where oT: "P \<turnstile> oT \<le> Class D" 
         and "ST = oT # ST''" and F: "P \<turnstile> D sees F:vT (fm) in D" 
         by fastforce
 
       with ST obtain ref stk' where stk': "stk = ref#stk'" 
         and ref:  "P,h \<turnstile> ref :\<le> oT" by auto
 
       show ?thesis
       proof(cases "ref = Null")
         case True thus ?thesis using stk' by auto
       next
         case False
         from ref oT have "P,h \<turnstile> ref :\<le> Class D" ..
         with False obtain a U' D' where 
           a: "ref = Addr a" and h: "typeof_addr h a = Some U'"
           and U': "D' = class_type_of U'" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
           by (blast dest: non_npD2)
     
         from D' F have has_field: "P \<turnstile> D' has F:vT (fm) in D"
           by (blast intro: has_field_mono has_visible_field)
         with h have "P,h \<turnstile> a@CField D F : vT" unfolding U' ..
         from heap_read_total[OF hconf this]
         show ?thesis using stk' a by auto
       qed
     next
       case [simp]: (Putfield F D)
 
       from \<Phi>_pc wt obtain vT vT' oT ST'' fm where "ST = vT # oT # ST''" 
         and field: "P \<turnstile> D sees F:vT' (fm) in D"
         and oT: "P \<turnstile> oT \<le> Class D"
         and vT': "P \<turnstile> vT \<le> vT'" by fastforce
       with ST obtain v ref stk' where stk': "stk = v#ref#stk'" 
         and ref:  "P,h \<turnstile> ref :\<le> oT" 
         and v: "P,h \<turnstile> v :\<le> vT" by auto
 
       show ?thesis
       proof(cases "ref = Null")
         case True with stk' show ?thesis by auto
       next
         case False
         from ref oT have "P,h \<turnstile> ref :\<le> Class D" ..
         with False obtain a U' D' where 
           a: "ref = Addr a" and h: "typeof_addr h a = Some U'" and
           U': "D' = class_type_of U'" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
           by (blast dest: non_npD2)
 
         from field D' have has_field: "P \<turnstile> D' has F:vT' (fm) in D"
           by (blast intro: has_field_mono has_visible_field)
         with h have al: "P,h \<turnstile> a@CField D F : vT'" unfolding U' ..
         from v vT' have "P,h \<turnstile> v :\<le> vT'" by auto
         from heap_write_total[OF hconf al this] v a stk' h show ?thesis by auto
       qed
     next
       case [simp]: (CAS F D)
       from \<Phi>_pc wt obtain T' T1 T2 T3 ST'' fm where "ST = T3 # T2 # T1 # ST''" 
         and field: "P \<turnstile> D sees F:T' (fm) in D"
         and oT: "P \<turnstile> T1 \<le> Class D"
         and vT': "P \<turnstile> T2 \<le> T'" "P \<turnstile> T3 \<le> T'" by fastforce
       with ST obtain v v' v'' stk' where stk': "stk = v''#v'#v#stk'" 
         and v:  "P,h \<turnstile> v :\<le> T1" 
         and v': "P,h \<turnstile> v' :\<le> T2"
         and v'': "P,h \<turnstile> v'' :\<le> T3" by auto
       show ?thesis
       proof(cases "v= Null")
         case True with stk' show ?thesis by auto
       next
         case False
         from v oT have "P,h \<turnstile> v :\<le> Class D" ..
         with False obtain a U' D' where 
           a: "v = Addr a" and h: "typeof_addr h a = Some U'" and
           U': "D' = class_type_of U'" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
           by (blast dest: non_npD2)
 
         from field D' have has_field: "P \<turnstile> D' has F:T' (fm) in D"
           by (blast intro: has_field_mono has_visible_field)
         with h have al: "P,h \<turnstile> a@CField D F : T'" unfolding U' ..
         from v' vT' have "P,h \<turnstile> v' :\<le> T'" by auto
         from heap_read_total[OF hconf al] obtain v''' where v''': "heap_read h a (CField D F) v'''" by blast
         show ?thesis
         proof(cases "v''' = v'")
           case True
           from v'' vT' have "P,h \<turnstile> v'' :\<le> T'" by auto
           from heap_write_total[OF hconf al this] v a stk' h v''' True show ?thesis by auto
         next
           case False
           from v''' v a stk' h False show ?thesis by auto
         qed
       qed
     next
       case [simp]: (Invoke M' n)
 
       from wt \<Phi>_pc have n: "n < size ST" by simp
   
       show ?thesis
       proof(cases "stk!n = Null")
         case True thus ?thesis by simp
       next
         case False
         note Null = this
         have NT: "ST!n \<noteq> NT"
         proof
           assume "ST!n = NT"
           moreover from ST n have "P,h \<turnstile> stk!n :\<le> ST!n" by (simp add: list_all2_conv_all_nth)
           ultimately have "stk!n = Null" by simp
           with Null show False by contradiction
         qed
 
         from NT wt \<Phi>_pc obtain D D' Ts T m
           where D: "class_type_of' (ST!n) = Some D"
           and m_D: "P \<turnstile> D sees M': Ts\<rightarrow>T = m in D'"
           and Ts:  "P \<turnstile> rev (take n ST) [\<le>] Ts"
           by auto
 
         from n ST D have "P,h \<turnstile> stk!n :\<le> ST!n"
           by (auto simp add: list_all2_conv_all_nth)
 
         from \<open>P,h \<turnstile> stk!n :\<le> ST!n\<close> Null D
         obtain a T' where
           Addr:   "stk!n = Addr a" and
           obj:    "typeof_addr h a = Some T'" and
           T'subSTn: "P \<turnstile> ty_of_htype T' \<le> ST ! n"
           by(cases "stk ! n")(auto simp add: conf_def widen_Class)
 
         from D T'subSTn obtain C' where
           C': "class_type_of' (ty_of_htype T') = \<lfloor>C'\<rfloor>" and C'subD: "P \<turnstile> C' \<preceq>\<^sup>* D"
           by(rule widen_is_class_type_of) simp
 
         from Call_lemma[OF m_D C'subD wf]
         obtain D' Ts' T' m' 
           where Call': "P \<turnstile> C' sees M': Ts'\<rightarrow>T' = m' in D'" "P \<turnstile> Ts [\<le>] Ts'"
             "P \<turnstile> T' \<le> T" "P \<turnstile> C' \<preceq>\<^sup>* D'" "is_type P T'" "\<forall>T\<in>set Ts'. is_type P T"
           by blast
         
         show ?thesis
         proof(cases m')
           case Some with Call' C' obj Addr C' C'subD show ?thesis by(auto)
         next
           case [simp]: None
           from ST have "P,h \<turnstile> take n stk [:\<le>] take n ST" by(rule list_all2_takeI)
           then obtain Us where "map typeof\<^bsub>h\<^esub> (take n stk) = map Some Us" "P \<turnstile> Us [\<le>] take n ST"
             by(auto simp add: confs_conv_map)
           hence Us: "map typeof\<^bsub>h\<^esub> (rev (take n stk)) = map Some (rev Us)" "P \<turnstile> rev Us [\<le>] rev (take n ST)"
             by- (simp only: rev_map[symmetric], simp)
           with Ts \<open>P \<turnstile> Ts [\<le>] Ts'\<close> have "P \<turnstile> rev Us [\<le>] Ts'" by(blast intro: widens_trans)
           with obj Us Call' C' have "P,h \<turnstile> a\<bullet>M'(rev (take n stk)) : T'"
             by(auto intro!: external_WT'.intros)
           from external_call_progress[OF wf this hconf, of t] obj Addr Call' C'
           show ?thesis by(auto dest!: red_external_imp_red_external_aggr)
         qed
       qed
     qed(auto 4 4 simp add: split_beta split: if_split_asm)
     thus ?thesis using sees None
       unfolding f exec_1_iff by(simp del: split_paired_Ex)
   qed
 qed
 
 lemma (in JVM_heap_conf) BV_correct_initial:
   shows "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P; start_heap_ok; P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>m\<rfloor> in D; P,start_heap \<turnstile> vs [:\<le>] Ts \<rbrakk>
   \<Longrightarrow> \<Phi> \<turnstile> start_tid:JVM_start_state' P C M vs \<surd>"
   apply (cases m)
   apply (unfold JVM_start_state'_def)
   apply (unfold correct_state_def)
   apply (clarsimp)
   apply (frule wt_jvm_progD)
   apply (erule exE)
   apply (frule wf_prog_wf_syscls)
   apply (rule conjI)
    apply(erule (1) tconf_start_heap_start_tid)
   apply(rule conjI)
    apply (simp add: wf_jvm_prog_phi_def hconf_start_heap) 
   apply(frule sees_method_idemp)
   apply (frule wt_jvm_prog_impl_wt_start, assumption+)
   apply (unfold conf_f_def wt_start_def)
   apply(auto simp add: sup_state_opt_any_Some)
    apply(erule preallocated_start_heap)
   apply(rule exI conjI|assumption)+
   apply(auto simp add: list_all2_append1)
   apply(auto dest: list_all2_lengthD intro!: exI)
   done
 
 end
diff --git a/thys/JinjaThreads/MM/DRF_JVM.thy b/thys/JinjaThreads/MM/DRF_JVM.thy
--- a/thys/JinjaThreads/MM/DRF_JVM.thy
+++ b/thys/JinjaThreads/MM/DRF_JVM.thy
@@ -1,1167 +1,1167 @@
 (*  Title:      JinjaThreads/MM/DRF_JVM.thy
     Author:     Andreas Lochbihler
 *)
 
 section \<open>JMM Instantiation for bytecode\<close>
 
 theory DRF_JVM
 imports
   JMM_Common
   JMM_JVM
   "../BV/BVProgressThreaded"
   SC_Legal
 begin
 
 subsection \<open>DRF guarantee for the JVM\<close>
 
 abbreviation (input) ka_xcp :: "'addr option \<Rightarrow> 'addr set"
 where "ka_xcp \<equiv> set_option"
 
 primrec jvm_ka :: "'addr jvm_thread_state \<Rightarrow> 'addr set"
 where
   "jvm_ka (xcp, frs) = 
    ka_xcp xcp \<union> (\<Union>(stk, loc, C, M, pc) \<in> set frs. (\<Union>v \<in> set stk. ka_Val v) \<union> (\<Union>v \<in> set loc. ka_Val v))"
 
 context heap begin
 
 lemma red_external_aggr_read_mem_typeable:
   "\<lbrakk> (ta, va, h') \<in> red_external_aggr P t a M vs h; ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> \<exists>T'. P,h \<turnstile> ad@al : T'"
 by(auto simp add: red_external_aggr_def split_beta split: if_split_asm dest: heap_clone_read_typeable)
 
 end
 
 context JVM_heap_base begin
 
 definition jvm_known_addrs :: "'thread_id \<Rightarrow> 'addr jvm_thread_state \<Rightarrow> 'addr set"
 where "jvm_known_addrs t xcpfrs = {thread_id2addr t} \<union> jvm_ka xcpfrs \<union> set start_addrs"
 
 end
 
 context JVM_heap begin
 
 lemma exec_instr_known_addrs:
   assumes ok: "start_heap_ok"
   and exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   shows "jvm_known_addrs t (xcp', frs') \<subseteq> jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs) \<union> new_obs_addrs \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
 proof -
   
   note [simp] = jvm_known_addrs_def new_obs_addrs_def addr_of_sys_xcpt_start_addr[OF ok] subset_Un1 subset_Un2 subset_insert ka_Val_subset_new_obs_Addr_ReadMem SUP_subset_mono split_beta neq_Nil_conv tl_conv_drop set_drop_subset is_Ref_def
 
   from exec check show ?thesis
   proof(cases "i")
     case Load with exec check show ?thesis by auto
   next
     case (Store V) with exec check show ?thesis
       using set_update_subset_insert[of loc V]
       by(clarsimp simp del: set_update_subsetI) blast
   next
     case (Push v)
     with check have "ka_Val v = {}" by(cases v) simp_all
     with Push exec check show ?thesis by(simp)
   next
     case (CAS F D)
     then show ?thesis using exec check 
       by(clarsimp split: if_split_asm)(fastforce dest!: in_set_dropD)+
   next
     case (Invoke M' n)
     show ?thesis
     proof(cases "stk ! n = Null")
       case True with exec check Invoke show ?thesis by(simp)
     next
       case [simp]: False
       with check Invoke obtain a where stkn: "stk ! n = Addr a" "n < length stk" by auto
       hence a: "a \<in> (\<Union>v \<in> set stk. ka_Val v)" by(fastforce dest: nth_mem)
       show ?thesis
       proof(cases "snd (snd (snd (method P (class_type_of (the (typeof_addr h (the_Addr (stk ! n))))) M'))) = Native")
         case True
         with exec check Invoke a stkn show ?thesis
           apply clarsimp
           apply(drule red_external_aggr_known_addrs_mono[OF ok], simp)
           apply(auto dest!: in_set_takeD dest: bspec subsetD split: extCallRet.split_asm simp add: has_method_def is_native.simps)
           done
       next
         case False
         with exec check Invoke a stkn show ?thesis
           by(auto simp add: set_replicate_conv_if dest!: in_set_takeD)
       qed
     qed
   next
     case Swap with exec check show ?thesis
       by(cases stk)(simp, case_tac list, auto)
   next
     case (BinOpInstr bop) with exec check show ?thesis
       using binop_known_addrs[OF ok, of bop "hd (drop (Suc 0) stk)" "hd stk"]
       apply(cases stk)
       apply(simp, case_tac list, simp)
       apply clarsimp
       apply(drule (2) binop_progress)
       apply(auto 6 2 split: sum.split_asm)
       done
   next
     case MExit with exec check show ?thesis by(auto split: if_split_asm)
   qed(clarsimp split: if_split_asm)+
 qed
 
 lemma exec_d_known_addrs_mono:
   assumes ok: "start_heap_ok"
   and exec: "mexecd P t (xcpfrs, h) ta (xcpfrs', h')"
   shows "jvm_known_addrs t xcpfrs' \<subseteq> jvm_known_addrs t xcpfrs \<union> new_obs_addrs \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
 using exec
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply(simp add: split_beta)
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
  apply(fastforce simp add: check_def split_beta del: subsetI dest!: exec_instr_known_addrs[OF ok])
 apply(fastforce simp add: jvm_known_addrs_def split_beta dest!: in_set_dropD)
 done
 
 lemma exec_instr_known_addrs_ReadMem:
   assumes exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   and read: "ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   shows "ad \<in> jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs)"
 using assms
 proof(cases i)
   case ALoad thus ?thesis using assms
     by(cases stk)(case_tac [2] list, auto simp add: split_beta is_Ref_def jvm_known_addrs_def split: if_split_asm)
 next
   case (Invoke M n)
   with check have "stk ! n \<noteq> Null \<longrightarrow> the_Addr (stk ! n) \<in> ka_Val (stk ! n)" "stk ! n \<in> set stk"
     by(auto simp add: is_Ref_def)
   with assms Invoke show ?thesis
     by(auto simp add: split_beta is_Ref_def simp del: ka_Val.simps nth_mem split: if_split_asm dest!: red_external_aggr_known_addrs_ReadMem in_set_takeD del: is_AddrE)(auto simp add: jvm_known_addrs_def simp del: ka_Val.simps nth_mem del: is_AddrE)
 next
   case Getfield thus ?thesis using assms
     by(auto simp add: jvm_known_addrs_def neq_Nil_conv is_Ref_def split: if_split_asm)
 next
   case CAS thus ?thesis using assms
     apply(cases stk; simp)
     subgoal for v stk
       apply(cases stk; simp)
       subgoal for v stk
         by(cases stk)(auto split: if_split_asm simp add: jvm_known_addrs_def is_Ref_def)
       done
     done
 qed(auto simp add: split_beta is_Ref_def neq_Nil_conv split: if_split_asm)
 
 lemma mexecd_known_addrs_ReadMem:
   "\<lbrakk> mexecd P t (xcpfrs, h) ta (xcpfrs', h'); ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> ad \<in> jvm_known_addrs t xcpfrs"
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply simp
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
 apply(auto simp add: check_def dest: exec_instr_known_addrs_ReadMem)
 done
 
 lemma exec_instr_known_addrs_WriteMem:
   assumes exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   and "write": "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! n = WriteMem ad al (Addr a)" "n < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   shows "a \<in> jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs) \<or> a \<in> new_obs_addrs (take n \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
 using assms
 proof(cases i)
   case (Invoke M n)
   with check have "stk ! n \<noteq> Null \<longrightarrow> the_Addr (stk ! n) \<in> ka_Val (stk ! n)" "stk ! n \<in> set stk"
     by(auto simp add: is_Ref_def)
   thus ?thesis using assms Invoke
     by(auto simp add: is_Ref_def split_beta split: if_split_asm simp del: ka_Val.simps nth_mem dest!: red_external_aggr_known_addrs_WriteMem in_set_takeD del: is_AddrE)(auto simp add: jvm_known_addrs_def del: is_AddrE)
 next
   case AStore with assms show ?thesis
     by(cases stk)(auto simp add: jvm_known_addrs_def split: if_split_asm)
 next
   case Putfield with assms show ?thesis
     by(cases stk)(auto simp add: jvm_known_addrs_def split: if_split_asm)
 next
   case CAS with assms show ?thesis
     apply(cases stk; simp)
     subgoal for v stk
       apply(cases stk; simp)
       subgoal for v stk
         by(cases stk)(auto split: if_split_asm simp add: take_Cons' jvm_known_addrs_def)
       done
     done
 qed(auto simp add: split_beta split: if_split_asm)
 
 lemma mexecd_known_addrs_WriteMem:
   "\<lbrakk> mexecd P t (xcpfrs, h) ta (xcpfrs', h'); \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! n = WriteMem ad al (Addr a); n < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> a \<in> jvm_known_addrs t xcpfrs \<or> a \<in> new_obs_addrs (take n \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply simp
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
 apply(auto simp add: check_def dest: exec_instr_known_addrs_WriteMem)
 done
 
 lemma exec_instr_known_addrs_new_thread:
   assumes exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   and new: "NewThread t' x' h'' \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>"
   shows "jvm_known_addrs t' x' \<subseteq> jvm_known_addrs t (None, (stk, loc, C, M, pc) # frs)"
 using assms
 proof(cases i)
   case (Invoke M n)
   with assms have "stk ! n \<noteq> Null \<longrightarrow> the_Addr (stk ! n) \<in> ka_Val (stk ! n) \<and> thread_id2addr (addr2thread_id (the_Addr (stk ! n))) = the_Addr (stk ! n)" "stk ! n \<in> set stk"
     apply(auto simp add: is_Ref_def split: if_split_asm)
     apply(frule red_external_aggr_NewThread_idD, simp, simp)
     apply(drule red_external_aggr_new_thread_sub_thread)
     apply(auto intro: addr2thread_id_inverse)
     done
   with assms Invoke show ?thesis
     apply(auto simp add: is_Ref_def split_beta split: if_split_asm simp del: nth_mem del: is_AddrE)
     apply(drule red_external_aggr_NewThread_idD)
     apply(auto simp add: extNTA2JVM_def jvm_known_addrs_def split_beta simp del: nth_mem del: is_AddrE)
     done
 qed(auto simp add: split_beta split: if_split_asm)
 
 lemma mexecd_known_addrs_new_thread:
   "\<lbrakk> mexecd P t (xcpfrs, h) ta (xcpfrs', h'); NewThread t' x' h'' \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub> \<rbrakk>
   \<Longrightarrow> jvm_known_addrs t' x' \<subseteq> jvm_known_addrs t xcpfrs"
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply simp
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
 apply(auto 4 3 simp add: check_def dest: exec_instr_known_addrs_new_thread)
 done
 
 lemma exec_instr_New_same_addr_same:
   "\<lbrakk> (ta, xcp', h', frs') \<in> exec_instr ins P t h stk loc C M pc frs;
      \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NewHeapElem a x; i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>;
      \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! j = NewHeapElem a x'; j < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> i = j"
 apply(cases ins)
 apply(auto simp add: nth_Cons' split: prod.split_asm if_split_asm)
 apply(auto split: extCallRet.split_asm dest: red_external_aggr_New_same_addr_same)
 done
 
 lemma exec_New_same_addr_same:
   "\<lbrakk> (ta, xcp', h', frs') \<in> exec P t (xcp, h, frs); 
      \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NewHeapElem a x; i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>;
      \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! j = NewHeapElem a x'; j < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> i = j"
 apply(cases "(P, t, xcp, h, frs)" rule: exec.cases)
 apply(auto dest: exec_instr_New_same_addr_same)
 done
 
 lemma exec_1_d_New_same_addr_same:
   "\<lbrakk> P,t \<turnstile> Normal (xcp, h, frs) -ta-jvmd\<rightarrow> Normal (xcp', h', frs'); 
      \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NewHeapElem a x; i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>;
      \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! j = NewHeapElem a x'; j < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> i = j"
 by(erule jvmd_NormalE)(rule exec_New_same_addr_same)
 
 end
 
 
 
 locale JVM_allocated_heap = allocated_heap +
   constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
   and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
   and spurious_wakeups :: bool
   and empty_heap :: "'heap"
   and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
   and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
   and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
   and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
   and allocated :: "'heap \<Rightarrow> 'addr set"
   and P :: "'addr jvm_prog"
 
 sublocale JVM_allocated_heap < JVM_heap
 by(unfold_locales)
 
 context JVM_allocated_heap begin
 
 lemma exec_instr_allocated_mono:
   "\<lbrakk> (ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs; check_instr i P h stk loc C M pc frs \<rbrakk>
   \<Longrightarrow> allocated h \<subseteq> allocated h'"
 apply(cases i)
 apply(auto 4 4 simp add: split_beta has_method_def is_native.simps split: if_split_asm sum.split_asm intro: allocate_allocated_mono dest: heap_write_allocated_same dest!: red_external_aggr_allocated_mono del: subsetI)
 done
 
 lemma mexecd_allocated_mono:
   "mexecd P t (xcpfrs, h) ta (xcpfrs', h') \<Longrightarrow> allocated h \<subseteq> allocated h'"
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply(simp)
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
 apply(auto del: subsetI simp add: check_def dest: exec_instr_allocated_mono)
 done
 
 lemma exec_instr_allocatedD:
   "\<lbrakk> (ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs; 
      check_instr i P h stk loc C M pc frs; NewHeapElem ad CTn \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> ad \<in> allocated h' \<and> ad \<notin> allocated h"
 apply(cases i)
 apply(auto 4 4 split: if_split_asm prod.split_asm dest: allocate_allocatedD dest!: red_external_aggr_allocatedD simp add: has_method_def is_native.simps)
 done
 
 lemma mexecd_allocatedD:
   "\<lbrakk> mexecd P t (xcpfrs, h) ta (xcpfrs', h'); NewHeapElem ad CTn \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk> 
   \<Longrightarrow> ad \<in> allocated h' \<and> ad \<notin> allocated h"
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply(simp)
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
 apply(auto del: subsetI dest: exec_instr_allocatedD simp add: check_def)
 done
 
 lemma exec_instr_NewHeapElemD:
   "\<lbrakk> (ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs; check_instr i P h stk loc C M pc frs;
      ad \<in> allocated h'; ad \<notin> allocated h \<rbrakk>
   \<Longrightarrow> \<exists>CTn. NewHeapElem ad CTn \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
 apply(cases i)
 apply(auto 4 3 split: if_split_asm prod.split_asm sum.split_asm dest: allocate_allocatedD heap_write_allocated_same dest!: red_external_aggr_NewHeapElemD simp add: is_native.simps has_method_def)
 done
 
 lemma mexecd_NewHeapElemD:
   "\<lbrakk> mexecd P t (xcpfrs, h) ta (xcpfrs', h'); ad \<in> allocated h'; ad \<notin> allocated h \<rbrakk>
   \<Longrightarrow> \<exists>CTn. NewHeapElem ad CTn \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
 apply(cases xcpfrs)
 apply(cases xcpfrs')
 apply(simp)
 apply(erule jvmd_NormalE)
 apply(cases "fst xcpfrs")
 apply(auto dest: exec_instr_NewHeapElemD simp add: check_def)
 done
 
 lemma mexecd_allocated_multithreaded:
   "allocated_multithreaded addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated JVM_final (mexecd P) P"
 proof
   fix t x m ta x' m'
   assume "mexecd P t (x, m) ta (x', m')"
   thus "allocated m \<subseteq> allocated m'" by(rule mexecd_allocated_mono)
 next
   fix x t m ta x' m' ad CTn
   assume "mexecd P t (x, m) ta (x', m')"
     and "NewHeapElem ad CTn \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   thus "ad \<in> allocated m' \<and> ad \<notin> allocated m" by(rule mexecd_allocatedD)
 next
   fix t x m ta x' m' ad
   assume "mexecd P t (x, m) ta (x', m')"
     and "ad \<in> allocated m'" "ad \<notin> allocated m"
   thus "\<exists>CTn. NewHeapElem ad CTn \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>" by(rule mexecd_NewHeapElemD)
 next
   fix t x m ta x' m' i a CTn j CTn'
   assume "mexecd P t (x, m) ta (x', m')"
     and "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NewHeapElem a CTn" "i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
     and "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! j = NewHeapElem a CTn'" "j < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   thus "i = j" by(auto dest: exec_1_d_New_same_addr_same simp add: split_beta)
 qed
 
 end
 
 sublocale JVM_allocated_heap < execd_mthr: allocated_multithreaded 
   addr2thread_id thread_id2addr 
   spurious_wakeups
   empty_heap allocate typeof_addr heap_read heap_write allocated 
   JVM_final "mexecd P" 
   P
 by(rule mexecd_allocated_multithreaded)
 
 context JVM_allocated_heap begin
 
 lemma mexecd_known_addrs: 
   assumes wf: "wf_prog wfmd P"
   and ok: "start_heap_ok"
   shows "known_addrs addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated jvm_known_addrs JVM_final (mexecd P) P"
 proof
   fix t x m ta x' m'
   assume "mexecd P t (x, m) ta (x', m')"
   thus "jvm_known_addrs t x' \<subseteq> jvm_known_addrs t x \<union> new_obs_addrs \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
     by(rule exec_d_known_addrs_mono[OF ok])
 next
   fix t x m ta x' m' t' x'' m''
   assume "mexecd P t (x, m) ta (x', m')"
     and "NewThread t' x'' m'' \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>"
   thus "jvm_known_addrs t' x'' \<subseteq> jvm_known_addrs t x" by(rule mexecd_known_addrs_new_thread)
 next
   fix t x m ta x' m' ad al v
   assume "mexecd P t (x, m) ta (x', m')"
     and "ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   thus "ad \<in> jvm_known_addrs t x" by(rule mexecd_known_addrs_ReadMem)
 next
   fix t x m ta x' m' n ad al ad'
   assume "mexecd P t (x, m) ta (x', m')"
     and "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! n = WriteMem ad al (Addr ad')" "n < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   thus "ad' \<in> jvm_known_addrs t x \<or> ad' \<in> new_obs_addrs (take n \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
     by(rule mexecd_known_addrs_WriteMem)
 qed
 
 end
 
 context JVM_heap begin
 
 lemma exec_instr_read_typeable:
   assumes exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   and read: "ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   shows "\<exists>T'. P,h \<turnstile> ad@al : T'"
 using exec check read
 proof(cases i)
   case ALoad
   with assms show ?thesis
     by(fastforce simp add: split_beta is_Ref_def nat_less_iff word_sless_alt intro: addr_loc_type.intros split: if_split_asm)
 next
   case (Getfield F D)
   with assms show ?thesis
     by(clarsimp simp add: split_beta is_Ref_def split: if_split_asm)(blast intro: addr_loc_type.intros dest: has_visible_field has_field_mono)
 next
   case (Invoke M n)
   with exec check read obtain a vs ta' va T
     where "(ta', va, h') \<in> red_external_aggr P t a M vs h"
     and "ReadMem ad al v \<in> set \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>"
     by(auto split: if_split_asm simp add: is_Ref_def)
   thus ?thesis by(rule red_external_aggr_read_mem_typeable)
 next
   case (CAS F D)
   with assms show ?thesis
     by(clarsimp simp add: split_beta is_Ref_def conf_def split: if_split_asm)
       (force intro: addr_loc_type.intros dest: has_visible_field[THEN has_field_mono])
 qed(auto simp add: split_beta is_Ref_def split: if_split_asm)
 
 lemma exec_1_d_read_typeable:
   "\<lbrakk> P,t \<turnstile> Normal (xcp, h, frs) -ta-jvmd\<rightarrow> Normal (xcp', h', frs'); 
      ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> \<exists>T'. P,h \<turnstile> ad@al : T'"
 apply(erule jvmd_NormalE)
 apply(cases "(P, t, xcp, h, frs)" rule: exec.cases)
 apply(auto intro: exec_instr_read_typeable simp add: check_def)
 done
 
 end
 
 sublocale JVM_heap_base < execd_mthr: 
   if_multithreaded
     JVM_final
     "mexecd P"
     convert_RA
   for P
 by(unfold_locales)
 
 context JVM_heap_conf begin
 
 lemma JVM_conf_read_heap_read_typed:
   "JVM_conf_read addr2thread_id thread_id2addr empty_heap allocate typeof_addr (heap_read_typed P) heap_write hconf P"
 proof -
   interpret conf: heap_conf_read
     addr2thread_id thread_id2addr 
     spurious_wakeups
     empty_heap allocate typeof_addr "heap_read_typed P" heap_write hconf 
     P
     by(rule heap_conf_read_heap_read_typed)
   show ?thesis by(unfold_locales)
 qed
 
 lemma exec_instr_New_typeof_addrD:
   "\<lbrakk> (ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs; 
      check_instr i P h stk loc C M pc frs; hconf h;
      NewHeapElem a x \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<rbrakk>
   \<Longrightarrow> typeof_addr h' a = Some x"
 apply(cases i)
 apply(auto dest: allocate_SomeD split: prod.split_asm if_split_asm)
 apply(auto 4 4 split: extCallRet.split_asm dest!: red_external_aggr_New_typeof_addrD simp add: has_method_def is_native.simps)
 done
 
 lemma exec_1_d_New_typeof_addrD:
   "\<lbrakk> P,t \<turnstile> Normal (xcp, h, frs) -ta-jvmd\<rightarrow> Normal (xcp', h', frs'); NewHeapElem a x \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>; hconf h \<rbrakk>
   \<Longrightarrow> typeof_addr h' a = Some x"
 apply(erule jvmd_NormalE)
 apply(cases "xcp")
 apply(auto dest: exec_instr_New_typeof_addrD simp add: check_def)
 done
 
 lemma exec_instr_non_speculative_typeable:
   assumes exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   and sc: "non_speculative P vs (llist_of (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"
   and vs_conf: "vs_conf P h vs"
   and hconf: "hconf h"
   shows "(ta, xcp', h', frs') \<in> JVM_heap_base.exec_instr addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write i P t h stk loc C M pc frs"
 proof -
   note [simp] = JVM_heap_base.exec_instr.simps
     and [split] = if_split_asm prod.split_asm sum.split_asm
     and [split del] = if_split
   from assms show "?thesis"
   proof(cases i)
     case ALoad with assms show ?thesis
       by(auto 4 3 intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)
   next
     case Getfield with assms show ?thesis
       by(auto 4 3 intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)
   next
     case CAS with assms show ?thesis
       by(auto 4 3 intro!: heap_read_typedI dest: vs_confD addr_loc_type_fun)
   next
     case Invoke with assms show ?thesis
       by(fastforce dest: red_external_aggr_non_speculative_typeable simp add: has_method_def is_native.simps)
   qed(auto)
 qed
 
 lemma exec_instr_non_speculative_vs_conf:
   assumes exec: "(ta, xcp', h', frs') \<in> exec_instr i P t h stk loc C M pc frs"
   and check: "check_instr i P h stk loc C M pc frs"
   and sc: "non_speculative P vs (llist_of (take n (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
   and vs_conf: "vs_conf P h vs"
   and hconf: "hconf h"
   shows "vs_conf P h' (w_values P vs (take n (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
 proof -
   note [simp] = JVM_heap_base.exec_instr.simps take_Cons'
     and [split] = if_split_asm prod.split_asm sum.split_asm
     and [split del] = if_split
   from assms show ?thesis
   proof(cases i)
     case New with assms show ?thesis
       by(auto 4 4 dest: hext_allocate vs_conf_allocate intro: vs_conf_hext)
   next
     case NewArray with assms show ?thesis
       by(auto 4 4 dest: hext_allocate vs_conf_allocate intro: vs_conf_hext cong: if_cong)
   next
     case Invoke with assms show ?thesis
       by(fastforce dest: red_external_aggr_non_speculative_vs_conf simp add: has_method_def is_native.simps)
   next
     case AStore
     { 
       assume "hd (tl (tl stk)) \<noteq> Null"
         and "\<not> the_Intg (hd (tl stk))  <s 0"
         and "\<not> int (alen_of_htype (the (typeof_addr h (the_Addr (hd (tl (tl stk))))))) \<le> sint (the_Intg (hd (tl stk)))"
         and "P \<turnstile> the (typeof\<^bsub>h\<^esub> (hd stk)) \<le> the_Array (ty_of_htype (the (typeof_addr h (the_Addr (hd (tl (tl stk)))))))"
       moreover hence "nat (sint (the_Intg (hd (tl stk)))) < alen_of_htype (the (typeof_addr h (the_Addr (hd (tl (tl stk))))))"
         by(auto simp add: not_le nat_less_iff word_sle_eq word_sless_eq not_less)
       with assms AStore have "nat (sint (the_Intg (hd (tl stk)))) < alen_of_htype (the (typeof_addr h' (the_Addr (hd (tl (tl stk))))))"
         by(auto dest!: hext_arrD hext_heap_write)
       ultimately have "\<exists>T. P,h' \<turnstile> the_Addr (hd (tl (tl stk)))@ACell (nat (sint (the_Intg (hd (tl stk))))) : T \<and> P,h' \<turnstile> hd stk :\<le> T"
         using assms AStore
         by(auto 4 4 simp add: is_Ref_def conf_def dest!: hext_heap_write dest: hext_arrD intro!: addr_loc_type.intros intro: typeof_addr_hext_mono type_of_hext_type_of) }
     thus ?thesis using assms AStore
       by(auto intro!: vs_confI)(blast intro: addr_loc_type_hext_mono conf_hext dest: hext_heap_write vs_confD)+
   next
     case Putfield
     show ?thesis using assms Putfield
       by(auto intro!: vs_confI dest!: hext_heap_write)(blast intro: addr_loc_type.intros addr_loc_type_hext_mono typeof_addr_hext_mono has_field_mono[OF has_visible_field] conf_hext dest: vs_confD)+
   next
     case CAS
     show ?thesis using assms CAS
       by(auto intro!: vs_confI dest!: hext_heap_write)(blast intro: addr_loc_type.intros addr_loc_type_hext_mono typeof_addr_hext_mono has_field_mono[OF has_visible_field] conf_hext dest: vs_confD)+
   qed(auto)
 qed
 
 lemma mexecd_non_speculative_typeable:
   "\<lbrakk> P,t \<turnstile> Normal (xcp, h, stk) -ta-jvmd\<rightarrow> Normal (xcp', h', frs'); non_speculative P vs (llist_of (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>));
     vs_conf P h vs; hconf h \<rbrakk>
   \<Longrightarrow> JVM_heap_base.exec_1_d addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P t (Normal (xcp, h, stk)) ta (Normal (xcp', h', frs'))"
 apply(erule jvmd_NormalE)
 apply(cases xcp)
 apply(auto intro!: JVM_heap_base.exec_1_d.intros simp add: JVM_heap_base.exec_d_def check_def JVM_heap_base.exec.simps intro: exec_instr_non_speculative_typeable)
 done
 
 lemma mexecd_non_speculative_vs_conf:
   "\<lbrakk> P,t \<turnstile> Normal (xcp, h, stk) -ta-jvmd\<rightarrow> Normal (xcp', h', frs');
     non_speculative P vs (llist_of (take n (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)));
     vs_conf P h vs; hconf h \<rbrakk>
   \<Longrightarrow> vs_conf P h' (w_values P vs (take n (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
 apply(erule jvmd_NormalE)
 apply(cases xcp)
 apply(auto intro!: JVM_heap_base.exec_1_d.intros simp add: JVM_heap_base.exec_d_def check_def JVM_heap_base.exec.simps intro: exec_instr_non_speculative_vs_conf)
 done
 
 end
 
 locale JVM_allocated_heap_conf = 
   JVM_heap_conf 
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write hconf
     P
   +
   JVM_allocated_heap 
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write
     allocated
     P
   for addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
   and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
   and spurious_wakeups :: bool
   and empty_heap :: "'heap"
   and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
   and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
   and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
   and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
   and hconf :: "'heap \<Rightarrow> bool"
   and allocated :: "'heap \<Rightarrow> 'addr set"
   and P :: "'addr jvm_prog"
 begin
 
 lemma mexecd_known_addrs_typing:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and ok: "start_heap_ok"
   shows "known_addrs_typing addr2thread_id thread_id2addr empty_heap allocate typeof_addr heap_write allocated jvm_known_addrs JVM_final (mexecd P) (\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>) P"
 proof -
   from wf obtain wf_md where "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
   then
   interpret known_addrs
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write 
     allocated jvm_known_addrs
     JVM_final "mexecd P" P
     using ok by(rule mexecd_known_addrs)
   
   show ?thesis
   proof
     fix t x m ta x' m'
     assume "mexecd P t (x, m) ta (x', m')"
     thus "m \<unlhd> m'" by(auto simp add: split_beta intro: exec_1_d_hext)
   next
     fix t x m ta x' m' vs
     assume exec: "mexecd P t (x, m) ta (x', m')"
       and ts_ok: "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t:(xcp, h, frstls) \<surd>) x m"
       and vs: "vs_conf P m vs"
       and ns: "non_speculative P vs (llist_of (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"
 
     let ?mexecd = "JVM_heap_base.mexecd addr2thread_id thread_id2addr spurious_wakeups empty_heap allocate typeof_addr (heap_read_typed P) heap_write P"    
     have lift: "lifting_wf JVM_final ?mexecd (\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>)"
       by(intro JVM_conf_read.lifting_wf_correct_state_d JVM_conf_read_heap_read_typed wf)
 
     from exec ns vs ts_ok have exec': "?mexecd t (x, m) ta (x', m')"
       by(auto simp add: split_beta correct_state_def dest: mexecd_non_speculative_typeable)
     thus "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t:(xcp, h, frstls) \<surd>) x' m'" using ts_ok
       by(rule lifting_wf.preserves_red[OF lift])
     {
       fix t'' x'' m''
       assume New: "NewThread t'' x'' m'' \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>"
       with exec have "m'' = snd (x', m')" by(rule execd_mthr.new_thread_memory)
       thus "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t'':(xcp, h, frstls) \<surd>) x'' m''"
         using lifting_wf.preserves_NewThread[where ?r="?mexecd", OF lift exec' ts_ok] New
         by auto }
     { fix t'' x''
       assume "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t'':(xcp, h, frstls) \<surd>) x'' m"
       with lift exec' ts_ok show "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t'':(xcp, h, frstls) \<surd>) x'' m'"
         by(rule lifting_wf.preserves_other) }
   next
     fix t x m ta x' m' vs n
     assume exec: "mexecd P t (x, m) ta (x', m')"
       and ts_ok: "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t:(xcp, h, frstls) \<surd>) x m"
       and vs: "vs_conf P m vs"
       and ns: "non_speculative P vs (llist_of (take n (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
     thus "vs_conf P m' (w_values P vs (take n (map NormalAction \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
       by(auto simp add: correct_state_def dest: mexecd_non_speculative_vs_conf)
   next
     fix t x m ta x' m' ad al v
     assume "mexecd P t (x, m) ta (x', m')"
       and "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t:(xcp, h, frstls) \<surd>) x m"
       and "ReadMem ad al v \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
     thus "\<exists>T. P,m \<turnstile> ad@al : T"
       by(auto simp add: correct_state_def split_beta dest: exec_1_d_read_typeable)
   next
     fix t x m ta x' m' ad hT
     assume "mexecd P t (x, m) ta (x', m')"
       and "(\<lambda>(xcp, frstls) h. \<Phi> \<turnstile> t:(xcp, h, frstls) \<surd>) x m"
       and "NewHeapElem ad hT \<in> set \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
     thus "typeof_addr m' ad = \<lfloor>hT\<rfloor>"
       by(auto dest: exec_1_d_New_typeof_addrD[where x="hT"] simp add: split_beta correct_state_def)
   qed
 qed
 
 lemma executions_sc:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and wf_start: "wf_start_state P C M vs"
   and vs2: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "executions_sc_hb (JVMd_\<E> P C M vs status) P"
     (is "executions_sc_hb ?E P")
 proof -
   from wf_start obtain Ts T meth D where ok: "start_heap_ok"
     and sees: "P \<turnstile> C sees M:Ts\<rightarrow>T=\<lfloor>meth\<rfloor> in D"
     and vs1: "P,start_heap \<turnstile> vs [:\<le>] Ts" by cases
 
   interpret known_addrs_typing
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write 
     allocated jvm_known_addrs
     JVM_final "mexecd P" "\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>" P
     using wf ok by(rule mexecd_known_addrs_typing)
   
   from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
   hence "wf_syscls P" by(rule wf_prog_wf_syscls) 
   thus ?thesis
   proof(rule executions_sc_hb)
     from correct_jvm_state_initial[OF wf wf_start]
     show "correct_state_ts \<Phi> (thr (JVM_start_state P C M vs)) start_heap"
       by(simp add: correct_jvm_state_def start_state_def split_beta)
   next
     show "jvm_known_addrs start_tid ((\<lambda>(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs) \<subseteq> allocated start_heap"
       using vs2
       by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF \<open>wf_syscls P\<close> ok])
   qed
 qed
 
 end
 
 declare split_paired_Ex [simp del]
 declare eq_upto_seq_inconsist_simps [simp]
 
 context JVM_progress begin
 
 abbreviation (input) jvm_non_speculative_read_bound :: nat where
   "jvm_non_speculative_read_bound \<equiv> 2"
 
 lemma exec_instr_non_speculative_read:
   assumes hrt: "heap_read_typeable hconf P"
   and vs: "vs_conf P (shr s) vs"
   and hconf: "hconf (shr s)"
   and exec_i: "(ta, xcp', h', frs') \<in> exec_instr i P t (shr s) stk loc C M pc frs"
   and check: "check_instr i P (shr s) stk loc C M pc frs"
   and aok: "execd_mthr.mthr.if.actions_ok s t ta"
   and i: "I < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   and read: "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! I = ReadMem a'' al'' v"
   and v': "v' \<in> w_values P vs (map NormalAction (take I \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) (a'', al'')"
   and ns: "non_speculative P vs (llist_of (map NormalAction (take I \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
   shows "\<exists>ta' xcp'' h'' frs''. (ta', xcp'', h'', frs'') \<in> exec_instr i P t (shr s) stk loc C M pc frs \<and>
            execd_mthr.mthr.if.actions_ok s t ta' \<and> 
            I < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> \<and> take I \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take I \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and> 
            \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! I = ReadMem a'' al'' v' \<and> 
            length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> \<le> max jvm_non_speculative_read_bound (length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
 using exec_i i read
 proof(cases i)
   case [simp]: ALoad
   let ?a = "the_Addr (hd (tl stk))"
   let ?i = "the_Intg (hd stk)"
   from exec_i i read have Null: "hd (tl stk) \<noteq> Null"
     and bounds: "0 <=s ?i" "sint ?i < int (alen_of_htype (the (typeof_addr (shr s) ?a)))"
     and [simp]: "I = 0" "a'' = ?a" "al'' = ACell (nat (sint ?i))"
     by(auto split: if_split_asm)
 
   from Null check obtain a T n 
     where a: "length stk > 1" "hd (tl stk) = Addr a"
     and type: "typeof_addr (shr s) ?a = \<lfloor>Array_type T n\<rfloor>" by(fastforce simp add: is_Ref_def)
   from bounds type have "nat (sint ?i) < n"
     by (simp add: word_sle_eq nat_less_iff)
   with type have adal: "P,shr s \<turnstile> ?a@ACell (nat (sint ?i)) : T"
     by(rule addr_loc_type.intros)
   from v' vs adal have "P,shr s \<turnstile> v' :\<le> T" by(auto dest!: vs_confD dest: addr_loc_type_fun)
   with hrt adal have "heap_read (shr s) ?a (ACell (nat (sint ?i))) v'" using hconf by(rule heap_read_typeableD)
-  with type bounds Null aok exec_i show ?thesis by(fastforce)
+  with type Null aok exec_i show ?thesis apply auto using bounds by fastforce+
 next
   case [simp]: (Getfield F D)
   let ?a = "the_Addr (hd stk)"
 
   from exec_i i read have Null: "hd stk \<noteq> Null"
     and [simp]: "I = 0" "a'' = ?a" "al'' = CField D F"
     by(auto split: if_split_asm)
   with check obtain U T fm C' a
     where sees: "P \<turnstile> D sees F:T (fm) in D"
     and type: "typeof_addr (shr s) ?a = \<lfloor>U\<rfloor>" 
     and sub: "P \<turnstile> class_type_of U \<preceq>\<^sup>* D" 
     and a: "hd stk = Addr a" "length stk > 0" by(auto simp add: is_Ref_def)
   from has_visible_field[OF sees] sub
   have "P \<turnstile> class_type_of U has F:T (fm) in D" by(rule has_field_mono)
   with type have adal: "P,shr s \<turnstile> ?a@CField D F : T"
     by(rule addr_loc_type.intros)
   from v' vs adal have "P,shr s \<turnstile> v' :\<le> T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
   with hrt adal have "heap_read (shr s) ?a (CField D F) v'" using hconf by(rule heap_read_typeableD)
   with type Null aok exec_i show ?thesis by(fastforce)
 next
   case [simp]: (CAS F D)
   let ?a = "the_Addr (hd (tl (tl stk)))"
 
   from exec_i i read have Null: "hd (tl (tl stk)) \<noteq> Null"
     and [simp]: "I = 0" "a'' = ?a" "al'' = CField D F"
     by(auto split: if_split_asm simp add: nth_Cons')
   with check obtain U T fm C' a
     where sees: "P \<turnstile> D sees F:T (fm) in D"
     and type: "typeof_addr (shr s) ?a = \<lfloor>U\<rfloor>" 
     and sub: "P \<turnstile> class_type_of U \<preceq>\<^sup>* D" 
     and a: "hd (tl (tl stk)) = Addr a" "length stk > 2" 
     and v: "P,shr s \<turnstile> hd stk :\<le> T"
     by(auto simp add: is_Ref_def)
   from has_visible_field[OF sees] sub
   have "P \<turnstile> class_type_of U has F:T (fm) in D" by(rule has_field_mono)
   with type have adal: "P,shr s \<turnstile> ?a@CField D F : T"
     by(rule addr_loc_type.intros)
   from v' vs adal have "P,shr s \<turnstile> v' :\<le> T" by(auto dest!: vs_confD dest: addr_loc_type_fun)  
   with hrt adal have read: "heap_read (shr s) ?a (CField D F) v'" using hconf by(rule heap_read_typeableD)
   show ?thesis
   proof(cases "v' = hd (tl stk)")
     case True
     from heap_write_total[OF hconf adal v] a obtain h'
       where "heap_write (shr s) a (CField D F) (hd stk) h'" by auto
     then show ?thesis using read a True aok exec_i by fastforce
   next
     case False
     then show ?thesis using read a aok exec_i
       by(fastforce intro!: disjI2)
   qed
 next
   case [simp]: (Invoke M n)
   let ?a = "the_Addr (stk ! n)"
   let ?vs = "rev (take n stk)"
   from exec_i i read have Null: "stk ! n \<noteq> Null" 
     and iec: "snd (snd (snd (method P (class_type_of (the (typeof_addr (shr s) ?a))) M))) = Native"
     by(auto split: if_split_asm)
   with check obtain a T Ts Tr D
     where a: "stk ! n = Addr a" "n < length stk"
     and type: "typeof_addr (shr s) ?a = \<lfloor>T\<rfloor>"
     and extwt: "P \<turnstile> class_type_of T sees M:Ts\<rightarrow>Tr = Native in D" "D\<bullet>M(Ts) :: Tr"
     by(auto simp add: is_Ref_def has_method_def)
   from extwt have native: "is_native P T M" by(auto simp add: is_native.simps)
   from Null iec type exec_i obtain ta' va
     where red: "(ta', va, h') \<in> red_external_aggr P t ?a M ?vs (shr s)"
     and ta: "ta = extTA2JVM P ta'" by(fastforce)
   from aok ta have aok': "execd_mthr.mthr.if.actions_ok s t ta'" by simp
   from red_external_aggr_non_speculative_read[OF hrt vs red[unfolded a the_Addr.simps] _ aok' hconf, of I a'' al'' v v']
     native type i read v' ns a ta
   obtain ta'' va'' h''
     where "(ta'', va'', h'') \<in> red_external_aggr P t a M (rev (take n stk)) (shr s)"
     and "execd_mthr.mthr.if.actions_ok s t ta''"
     and "I < length \<lbrace>ta''\<rbrace>\<^bsub>o\<^esub>" "take I \<lbrace>ta''\<rbrace>\<^bsub>o\<^esub> = take I \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>" 
     and "\<lbrace>ta''\<rbrace>\<^bsub>o\<^esub> ! I = ReadMem a'' al'' v'" "length \<lbrace>ta''\<rbrace>\<^bsub>o\<^esub> \<le> length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>" by auto
   thus ?thesis using Null iec ta extwt a type
     by(cases va'') force+
 qed(auto simp add: split_beta split: if_split_asm)
 
 lemma exec_1_d_non_speculative_read:
   assumes hrt: "heap_read_typeable hconf P"
   and vs: "vs_conf P (shr s) vs"
   and exec: "P,t \<turnstile> Normal (xcp, shr s, frs) -ta-jvmd\<rightarrow> Normal (xcp', h', frs')"
   and aok: "execd_mthr.mthr.if.actions_ok s t ta"
   and hconf: "hconf (shr s)"
   and i: "I < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
   and read: "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! I = ReadMem a'' al'' v"
   and v': "v' \<in> w_values P vs (map NormalAction (take I \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) (a'', al'')"
   and ns: "non_speculative P vs (llist_of (map NormalAction (take I \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)))"
   shows "\<exists>ta' xcp'' h'' frs''. P,t \<turnstile> Normal (xcp, shr s, frs) -ta'-jvmd\<rightarrow> Normal (xcp'', h'', frs'') \<and>
            execd_mthr.mthr.if.actions_ok s t ta' \<and> 
            I < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> \<and> take I \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take I \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and> 
            \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! I = ReadMem a'' al'' v' \<and> 
            length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> \<le> max jvm_non_speculative_read_bound (length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
 using assms
 apply -
 apply(erule jvmd_NormalE)
 apply(cases "(P, t, xcp, shr s, frs)" rule: exec.cases)
   apply simp
  defer
  apply simp
 apply clarsimp
 apply(drule (3) exec_instr_non_speculative_read)
       apply(clarsimp simp add: check_def has_method_def)
      apply simp
     apply(rule i)
    apply(rule read)
   apply(rule v')
  apply(rule ns)
 apply(clarsimp simp add: exec_1_d.simps exec_d_def)
 done
 
 end
 
 declare split_paired_Ex [simp]
 declare eq_upto_seq_inconsist_simps [simp del]
 
 locale JVM_allocated_progress = 
   JVM_progress
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write hconf
     P
   +
   JVM_allocated_heap_conf
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write hconf
     allocated
     P
   for addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
   and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
   and spurious_wakeups :: bool
   and empty_heap :: "'heap"
   and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
   and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
   and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
   and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
   and hconf :: "'heap \<Rightarrow> bool"
   and allocated :: "'heap \<Rightarrow> 'addr set"
   and P :: "'addr jvm_prog"
 begin
 
 lemma non_speculative_read:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P"
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "execd_mthr.if.non_speculative_read jvm_non_speculative_read_bound
       (init_fin_lift_state status (JVM_start_state P C M vs)) 
       (w_values P (\<lambda>_. {}) (map snd (lift_start_obs start_tid start_heap_obs)))"
   (is "execd_mthr.if.non_speculative_read _ ?start_state ?start_vs")
 proof(rule execd_mthr.if.non_speculative_readI)
   fix ttas s' t x ta x' m' i ad al v v'
 
   assume \<tau>Red: "execd_mthr.mthr.if.RedT P ?start_state ttas s'"
     and sc: "non_speculative P ?start_vs (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas)))"
     and ts't: "thr s' t = \<lfloor>(x, no_wait_locks)\<rfloor>"
     and red: "execd_mthr.init_fin P t (x, shr s') ta (x', m')"
     and aok: "execd_mthr.mthr.if.actions_ok s' t ta"
     and i: "i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>"
     and ns': "non_speculative P (w_values P ?start_vs (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas))) (llist_of (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"
     and read: "\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v)"
     and v': "v' \<in> w_values P ?start_vs (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas) @ take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) (ad, al)"
 
   from wf_start obtain Ts T meth D where ok: "start_heap_ok"
     and sees: "P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D"
     and conf: "P,start_heap \<turnstile> vs [:\<le>] Ts" by cases
 
   let ?conv = "\<lambda>ttas. concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas)"
   let ?vs' = "w_values P ?start_vs (?conv ttas)"
   let ?wt_ok = "init_fin_lift (\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>)"
   let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
 
   from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
 
   interpret known_addrs_typing
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write 
     allocated jvm_known_addrs
     JVM_final "mexecd P" "\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>"
     using wf ok by(rule mexecd_known_addrs_typing)
 
   from conf have len2: "length vs = length Ts" by(rule list_all2_lengthD)
 
   from correct_jvm_state_initial[OF wf wf_start]
   have "correct_state_ts \<Phi> (thr (JVM_start_state P C M vs)) start_heap"
     by(simp add: correct_jvm_state_def start_state_def split_beta)
   hence ts_ok_start: "ts_ok ?wt_ok (thr ?start_state) (shr ?start_state)"
     unfolding ts_ok_init_fin_lift_init_fin_lift_state by(simp add: start_state_def split_beta)
 
   have sc': "non_speculative P ?start_vs (lmap snd (lconcat (lmap (\<lambda>(t, ta). llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) (llist_of ttas))))"
     using sc by(simp add: lmap_lconcat llist.map_comp o_def split_def lconcat_llist_of[symmetric])
   from start_state_vs_conf[OF wf_prog_wf_syscls[OF wf']]
   have vs_conf_start: "vs_conf P (shr ?start_state) ?start_vs"
     by(simp add:init_fin_lift_state_conv_simps start_state_def split_beta)
   with \<tau>Red ts_ok_start sc
   have wt': "ts_ok ?wt_ok (thr s') (shr s')"
     and vs': "vs_conf P (shr s') ?vs'" by(rule if_RedT_non_speculative_invar)+
 
   from red i read obtain xcp frs xcp' frs' ta'
     where x: "x = (Running, xcp, frs)" and x': "x' = (Running, xcp', frs')"
     and ta: "ta = convert_TA_initial (convert_obs_initial ta')"
     and red': "P,t \<turnstile> Normal (xcp, shr s', frs) -ta'-jvmd\<rightarrow> Normal (xcp', m', frs')"
     by cases fastforce+
 
   from ts't wt' x have hconf: "hconf (shr s')" by(auto dest!: ts_okD simp add: correct_state_def)
 
   have aok': "execd_mthr.mthr.if.actions_ok s' t ta'" using aok unfolding ta by simp
   
   from i read v' ns' ta have "i < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>" 
     and "\<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! i = ReadMem ad al v"
     and "v' \<in> w_values P ?vs' (map NormalAction (take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>)) (ad, al)"
     and "non_speculative P ?vs' (llist_of (map NormalAction (take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>)))"
     by(simp_all add: take_map)
 
   from exec_1_d_non_speculative_read[OF hrt vs' red' aok' hconf this]
   obtain ta'' xcp'' frs'' h''
     where red'': "P,t \<turnstile> Normal (xcp, shr s', frs) -ta''-jvmd\<rightarrow> Normal (xcp'', h'', frs'')"
     and aok'': "execd_mthr.mthr.if.actions_ok s' t ta''"
     and i'': " i < length \<lbrace>ta''\<rbrace>\<^bsub>o\<^esub>"
     and eq'': "take i \<lbrace>ta''\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>"
     and read'': "\<lbrace>ta''\<rbrace>\<^bsub>o\<^esub> ! i = ReadMem ad al v'"
     and len'': "length \<lbrace>ta''\<rbrace>\<^bsub>o\<^esub> \<le> max jvm_non_speculative_read_bound (length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>)" by blast
 
   let ?x' = "(Running, xcp'', frs'')"
   let ?ta' = "convert_TA_initial (convert_obs_initial ta'')"
   from red'' have "execd_mthr.init_fin P t (x, shr s') ?ta' (?x', h'')"
     unfolding x by -(rule execd_mthr.init_fin.NormalAction, simp)
   moreover from aok'' have "execd_mthr.mthr.if.actions_ok s' t ?ta'" by simp
   moreover from i'' have "i < length \<lbrace>?ta'\<rbrace>\<^bsub>o\<^esub>" by simp
   moreover from eq'' have "take i \<lbrace>?ta'\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>" unfolding ta by(simp add: take_map)
   moreover from read'' i'' have "\<lbrace>?ta'\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v')" by(simp add: nth_map)
   moreover from len'' have "length \<lbrace>?ta'\<rbrace>\<^bsub>o\<^esub> \<le> max jvm_non_speculative_read_bound (length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)" 
     unfolding ta by simp
   ultimately
   show "\<exists>ta' x'' m''. execd_mthr.init_fin P t (x, shr s') ta' (x'', m'') \<and>
                       execd_mthr.mthr.if.actions_ok s' t ta' \<and>
                       i < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> \<and> take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and>
                       \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v') \<and> 
                       length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> \<le> max jvm_non_speculative_read_bound (length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
     by blast
 qed
 
 lemma JVM_cut_and_update:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P" 
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "execd_mthr.if.cut_and_update (init_fin_lift_state status (JVM_start_state P C M vs))
            (mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs)))"
 proof -
   from wf_start obtain Ts T meth D where ok: "start_heap_ok"
     and sees: "P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D"
     and conf: "P,start_heap \<turnstile> vs [:\<le>] Ts" by cases
 
   interpret known_addrs_typing
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write 
     allocated jvm_known_addrs
     JVM_final "mexecd P" "\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>"
     using wf ok by(rule mexecd_known_addrs_typing)
 
   let ?start_vs = "w_values P (\<lambda>_. {}) (map snd (lift_start_obs start_tid start_heap_obs))"
   let ?wt_ok = "init_fin_lift (\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>)"
   let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
   let ?start_state = "init_fin_lift_state status (JVM_start_state P C M vs)"
 
   from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
   hence "wf_syscls P" by(rule wf_prog_wf_syscls)
   moreover
   note non_speculative_read[OF wf hrt wf_start ka]
   moreover have "ts_ok ?wt_ok (thr ?start_state) (shr ?start_state)"
     using correct_jvm_state_initial[OF wf wf_start]
     by(simp add: correct_jvm_state_def start_state_def split_beta)
   moreover have ka: "jvm_known_addrs start_tid ((\<lambda>(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs) \<subseteq> allocated start_heap"
       using ka by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF \<open>wf_syscls P\<close> ok])
   ultimately show ?thesis by(rule non_speculative_read_into_cut_and_update)
 qed
 
 lemma JVM_drf:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P"
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "drf (JVMd_\<E> P C M vs status) P"
 proof -
   from wf_start obtain Ts T meth D where ok: "start_heap_ok"
     and sees: "P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D"
     and conf: "P,start_heap \<turnstile> vs [:\<le>] Ts" by cases
 
   from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
   hence "wf_syscls P" by(rule wf_prog_wf_syscls)
   with JVM_cut_and_update[OF assms]
   show ?thesis
   proof(rule known_addrs_typing.drf[OF mexecd_known_addrs_typing[OF wf ok]])
     from correct_jvm_state_initial[OF wf wf_start]
     show "correct_state_ts \<Phi> (thr (JVM_start_state P C M vs)) start_heap"
       by(simp add: correct_jvm_state_def start_state_def split_beta)
   next
     show "jvm_known_addrs start_tid ((\<lambda>(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs) \<subseteq> allocated start_heap"
       using ka by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF \<open>wf_syscls P\<close> ok])
   qed
 qed
 
 lemma JVM_sc_legal:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P"
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
 shows "sc_legal (JVMd_\<E> P C M vs status) P"
 proof -
   from wf_start obtain Ts T meth D where ok: "start_heap_ok"
     and sees: "P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D"
     and conf: "P,start_heap \<turnstile> vs [:\<le>] Ts" by cases
 
   interpret known_addrs_typing
     addr2thread_id thread_id2addr
     spurious_wakeups
     empty_heap allocate typeof_addr heap_read heap_write 
     allocated jvm_known_addrs
     JVM_final "mexecd P" "\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>"
     using wf ok by(rule mexecd_known_addrs_typing)
 
   from wf obtain wf_md where wf': "wf_prog wf_md P" by(blast dest: wt_jvm_progD)
   hence "wf_syscls P" by(rule wf_prog_wf_syscls)
 
   let ?start_vs = "w_values P (\<lambda>_. {}) (map snd (lift_start_obs start_tid start_heap_obs))"
   let ?wt_ok = "init_fin_lift (\<lambda>t (xcp, frstls) h. \<Phi> \<turnstile> t: (xcp, h, frstls) \<surd>)"
   let ?start_obs = "map snd (lift_start_obs start_tid start_heap_obs)"
   let ?start_state = "init_fin_lift_state status (JVM_start_state P C M vs)"
 
   note \<open>wf_syscls P\<close> non_speculative_read[OF wf hrt wf_start ka]
   moreover have "ts_ok ?wt_ok (thr ?start_state) (shr ?start_state)"
     using correct_jvm_state_initial[OF wf wf_start]
     by(simp add: correct_jvm_state_def start_state_def split_beta)
   moreover
   have ka_allocated: "jvm_known_addrs start_tid ((\<lambda>(mxs, mxl0, b) vs. (None, [([], Null # vs @ replicate mxl0 undefined_value, fst (method P C M), M, 0)])) (the (snd (snd (snd (method P C M))))) vs) \<subseteq> allocated start_heap"
     using ka by(auto simp add: split_beta start_addrs_allocated jvm_known_addrs_def intro: start_tid_start_addrs[OF \<open>wf_syscls P\<close> ok])
   ultimately have "execd_mthr.if.hb_completion ?start_state (lift_start_obs start_tid start_heap_obs)"
     by(rule non_speculative_read_into_hb_completion)
 
   thus ?thesis using \<open>wf_syscls P\<close>
   proof(rule sc_legal)
     from correct_jvm_state_initial[OF wf wf_start]
     show "correct_state_ts \<Phi> (thr (JVM_start_state P C M vs)) start_heap"
       by(simp add: correct_jvm_state_def start_state_def split_beta)
   qed(rule ka_allocated)
 qed
 
 lemma JVM_jmm_consistent:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P"
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "jmm_consistent (JVMd_\<E> P C M vs status) P"
     (is "jmm_consistent ?\<E> P")
 proof -
   interpret drf "?\<E>" P using assms by(rule JVM_drf)
   interpret sc_legal "?\<E>" P using assms by(rule JVM_sc_legal)
   show ?thesis by unfold_locales
 qed
 
 lemma JVM_ex_sc_exec:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P"
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "\<exists>E ws. E \<in> JVMd_\<E> P C M vs status \<and> P \<turnstile> (E, ws) \<surd> \<and> sequentially_consistent P (E, ws)"
   (is "\<exists>E ws. _ \<in> ?\<E> \<and> _")
 proof -
   interpret jmm: executions_sc_hb ?\<E> P using assms by -(rule executions_sc)
 
   let ?start_state = "init_fin_lift_state status (JVM_start_state P C M vs)"
   let ?start_mrw = "mrw_values P Map.empty (map snd (lift_start_obs start_tid start_heap_obs))"
 
   from execd_mthr.if.sequential_completion_Runs[OF execd_mthr.if.cut_and_update_imp_sc_completion[OF JVM_cut_and_update[OF assms]] ta_seq_consist_convert_RA]
   obtain ttas where Red: "execd_mthr.mthr.if.mthr.Runs P ?start_state ttas"
     and sc: "ta_seq_consist P ?start_mrw (lconcat (lmap (\<lambda>(t, ta). llist_of \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas))" by blast
   let ?E = "lappend (llist_of (lift_start_obs start_tid start_heap_obs)) (lconcat (lmap (\<lambda>(t, ta). llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) ttas))"
   from Red have "?E \<in> ?\<E>" by(blast intro: execd_mthr.mthr.if.\<E>.intros)
   moreover from Red have tsa: "thread_start_actions_ok ?E"
     by(blast intro: execd_mthr.thread_start_actions_ok_init_fin execd_mthr.mthr.if.\<E>.intros)
   from sc have "ta_seq_consist P Map.empty (lmap snd ?E)"
     unfolding lmap_lappend_distrib lmap_lconcat llist.map_comp split_def o_def lmap_llist_of map_map snd_conv
     by(simp add: ta_seq_consist_lappend ta_seq_consist_start_heap_obs)
   from ta_seq_consist_imp_sequentially_consistent[OF tsa jmm.\<E>_new_actions_for_fun[OF \<open>?E \<in> ?\<E>\<close>] this]
   obtain ws where "sequentially_consistent P (?E, ws)" "P \<turnstile> (?E, ws) \<surd>" by iprover
   ultimately show ?thesis by blast
 qed
 
 theorem JVM_consistent:
   assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
   and hrt: "heap_read_typeable hconf P"
   and wf_start: "wf_start_state P C M vs"
   and ka: "\<Union>(ka_Val ` set vs) \<subseteq> set start_addrs"
   shows "\<exists>E ws. legal_execution P (JVMd_\<E> P C M vs status) (E, ws)"
 proof -
   let ?\<E> = "JVMd_\<E> P C M vs status"
   interpret sc_legal "?\<E>" P using assms by(rule JVM_sc_legal)
   from JVM_ex_sc_exec[OF assms]
   obtain E ws where "E \<in> ?\<E>" "P \<turnstile> (E, ws) \<surd>" "sequentially_consistent P (E, ws)" by blast
   hence "legal_execution P ?\<E> (E, ws)" by(rule SC_is_legal)
   thus ?thesis by blast
 qed
 
 end
 
 text \<open>
   One could now also prove that the aggressive JVM satisfies @{term drf}.
   The key would be that \<open>welltyped_commute\<close> also holds for @{term "non_speculative"} prefixes from start.
 \<close>
 
 end
diff --git a/thys/Median_Of_Medians_Selection/Median_Of_Medians_Selection.thy b/thys/Median_Of_Medians_Selection/Median_Of_Medians_Selection.thy
--- a/thys/Median_Of_Medians_Selection/Median_Of_Medians_Selection.thy
+++ b/thys/Median_Of_Medians_Selection/Median_Of_Medians_Selection.thy
@@ -1,974 +1,975 @@
 (*
   File:     Median_Of_Medians_Selection.thy
   Author:   Manuel Eberl, TU München
 
   The median-of-medians selection algorithm, which runs deterministically in linear time.
 *)
 section \<open>The Median-of-Medians Selection Algorithm\<close>
 theory Median_Of_Medians_Selection
   imports Complex_Main "HOL-Library.Multiset"
 begin
 
 subsection \<open>Some facts about lists and multisets\<close>
 
 lemma mset_concat: "mset (concat xss) = sum_list (map mset xss)"
   by (induction xss) simp_all
 
 lemma set_mset_sum_list [simp]: "set_mset (sum_list xs) = (\<Union>x\<in>set xs. set_mset x)"
   by (induction xs) auto
 
 lemma filter_mset_image_mset:
   "filter_mset P (image_mset f A) = image_mset f (filter_mset (\<lambda>x. P (f x)) A)"
   by (induction A) auto
 
 lemma filter_mset_sum_list: "filter_mset P (sum_list xs) = sum_list (map (filter_mset P) xs)"
   by (induction xs) simp_all
 
 lemma sum_mset_mset_mono: 
   assumes "(\<And>x. x \<in># A \<Longrightarrow> f x \<subseteq># g x)"
   shows   "(\<Sum>x\<in>#A. f x) \<subseteq># (\<Sum>x\<in>#A. g x)"
   using assms by (induction A) (auto intro!: subset_mset.add_mono)
 
 lemma mset_filter_mono:
   assumes "A \<subseteq># B" "\<And>x. x \<in># A \<Longrightarrow> P x \<Longrightarrow> Q x"
   shows   "filter_mset P A \<subseteq># filter_mset Q B"
   by (rule mset_subset_eqI) (insert assms, auto simp: mset_subset_eq_count count_eq_zero_iff)
 
 lemma size_mset_sum_mset_distrib: "size (sum_mset A :: 'a multiset) = sum_mset (image_mset size A)"
   by (induction A) auto
 
 lemma sum_mset_mono:
   assumes "\<And>x. x \<in># A \<Longrightarrow> f x \<le> (g x :: 'a :: {ordered_ab_semigroup_add,comm_monoid_add})"
   shows   "(\<Sum>x\<in>#A. f x) \<le> (\<Sum>x\<in>#A. g x)"
   using assms by (induction A) (auto intro!: add_mono)
 
 lemma filter_mset_is_empty_iff: "filter_mset P A = {#} \<longleftrightarrow> (\<forall>x. x \<in># A \<longrightarrow> \<not>P x)"
   by (auto simp: multiset_eq_iff count_eq_zero_iff)
 
 lemma sorted_filter_less_subset_take:
   assumes "sorted xs" "i < length xs"
   shows   "{# x \<in># mset xs. x < xs ! i #} \<subseteq># mset (take i xs)"
   using assms
 proof (induction xs arbitrary: i rule: list.induct)
   case (Cons x xs i)
   show ?case
   proof (cases i)
     case 0
     thus ?thesis using Cons.prems by (auto simp: filter_mset_is_empty_iff)
   next
     case (Suc i')
     have "{#y \<in># mset (x # xs). y < (x # xs) ! i#} \<subseteq># add_mset x {#y \<in># mset xs. y < xs ! i'#}"
       using Suc Cons.prems by (auto)
     also have "\<dots> \<subseteq># add_mset x (mset (take i' xs))"
       unfolding mset_subset_eq_add_mset_cancel using Cons.prems Suc
       by (intro Cons.IH) (auto)
     also have "\<dots> = mset (take i (x # xs))" by (simp add: Suc)
     finally show ?thesis .
   qed
 qed auto
 
 lemma sorted_filter_greater_subset_drop:
   assumes "sorted xs" "i < length xs"
   shows   "{# x \<in># mset xs. x > xs ! i #} \<subseteq># mset (drop (Suc i) xs)"
   using assms
 proof (induction xs arbitrary: i rule: list.induct)
   case (Cons x xs i)
   show ?case
   proof (cases i)
     case 0
     thus ?thesis by (auto simp: sorted_append filter_mset_is_empty_iff)
   next
     case (Suc i')
     have "{#y \<in># mset (x # xs). y > (x # xs) ! i#} \<subseteq># {#y \<in># mset xs. y > xs ! i'#}"
       using Suc Cons.prems by (auto simp: set_conv_nth)
     also have "\<dots> \<subseteq># mset (drop (Suc i') xs)"
       using Cons.prems Suc by (intro Cons.IH) (auto)
     also have "\<dots> = mset (drop (Suc i) (x # xs))" by (simp add: Suc)
     finally show ?thesis .
   qed
 qed auto
 
 
 subsection \<open>The dual order type\<close>
 
 text \<open>
   The following type is a copy of a given ordered base type, but with the ordering reversed.
   This will be useful later because we can do some of our reasoning simply by symmetry.
 \<close>
 typedef 'a dual_ord = "UNIV :: 'a set" morphisms of_dual_ord to_dual_ord
   by auto
 
 setup_lifting type_definition_dual_ord
 
 instantiation dual_ord :: (ord) ord
 begin
 
 lift_definition less_eq_dual_ord :: "'a dual_ord \<Rightarrow> 'a dual_ord \<Rightarrow> bool" is
   "\<lambda>a b :: 'a. a \<ge> b" .
 
 lift_definition less_dual_ord :: "'a dual_ord \<Rightarrow> 'a dual_ord \<Rightarrow> bool" is
   "\<lambda>a b :: 'a. a > b" .
 
 instance ..
 end
 
 instance dual_ord :: (preorder) preorder
   by standard (transfer; force simp: less_le_not_le intro: order_trans)+
 
 instance dual_ord :: (linorder) linorder
   by standard (transfer; force simp: not_le)+
 
 
 subsection \<open>Chopping a list into equal-sized sublists\<close>
 
 (* TODO: Move to library? *)
 function chop :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
   "chop n [] = []"
 | "chop 0 xs = []"
 | "n > 0 \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> chop n xs = take n xs # chop n (drop n xs)"
   by force+
 termination by lexicographic_order
 
 context
   includes lifting_syntax
 begin
 
 lemma chop_transfer [transfer_rule]: 
   "((=) ===> list_all2 R ===> list_all2 (list_all2 R)) chop chop"
 proof (intro rel_funI)
   fix m n ::nat and xs :: "'a list" and ys :: "'b list"
   assume "m = n" "list_all2 R xs ys"
   from this(2) have "list_all2 (list_all2 R) (chop n xs) (chop n ys)"
   proof (induction n xs arbitrary: ys rule: chop.induct)
     case (3 n xs ys)
     hence "ys \<noteq> []" by auto
     with 3 show ?case by auto
   qed auto
   with \<open>m = n\<close> show "list_all2 (list_all2 R) (chop m xs) (chop n ys)" by simp
 qed
 
 end
 
 lemma chop_reduce: "chop n xs = (if n = 0 \<or> xs = [] then [] else take n xs # chop n (drop n xs))"
   by (cases "n = 0"; cases "xs = []") auto
 
 lemma concat_chop [simp]: "n > 0 \<Longrightarrow> concat (chop n xs) = xs"
   by (induction n xs rule: chop.induct) auto
 
 lemma chop_elem_not_Nil [simp,dest]: "ys \<in> set (chop n xs) \<Longrightarrow> ys \<noteq> []"
   by (induction n xs rule: chop.induct) (auto simp: eq_commute[of "[]"])
 
 lemma chop_eq_Nil_iff [simp]: "chop n xs = [] \<longleftrightarrow> n = 0 \<or> xs = []"
   by (induction n xs rule: chop.induct) auto  
 
 lemma chop_ge_length_eq: "n > 0 \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> n \<ge> length xs \<Longrightarrow> chop n xs = [xs]"
   by simp
 
 lemma length_chop_part_le: "ys \<in> set (chop n xs) \<Longrightarrow> length ys \<le> n"
   by (induction n xs rule: chop.induct) auto
 
 lemma length_nth_chop:
   assumes "i < length (chop n xs)"
   shows   "length (chop n xs ! i) = 
              (if i = length (chop n xs) - 1 \<and> \<not>n dvd length xs then length xs mod n else n)"
 proof (cases "n = 0")
   case False
   thus ?thesis
     using assms
   proof (induction n xs arbitrary: i rule: chop.induct)
     case (3 n xs i)
     show ?case
     proof (cases i)
       case 0
       thus ?thesis using "3.prems"
       by (cases "length xs < n") (auto simp: le_Suc_eq dest: dvd_imp_le)
     next
       case [simp]: (Suc i')
       with "3.prems" have [simp]: "xs \<noteq> []" by auto
       with "3.prems" have *: "length xs > n" by (cases "length xs \<le> n") simp_all
       with "3.prems" have "chop n xs ! i = chop n (drop n xs) ! i'" by simp
       also have "length \<dots> = (if i = length (chop n xs) - 1 \<and> \<not> n dvd (length xs - n)
                                 then (length xs - n) mod n else n)"
         by (subst "3.IH") (use Suc "3.prems" in auto)
       also have "n dvd (length xs - n) \<longleftrightarrow> n dvd length xs"
         using * by (subst dvd_minus_self) auto
       also have "(length xs - n) mod n = length xs mod n"
         using * by (subst le_mod_geq [symmetric]) auto
       finally show ?thesis .
     qed
   qed auto
 qed (insert assms, auto)
 
 lemma length_chop:
   assumes "n > 0"
   shows   "length (chop n xs) = nat \<lceil>length xs / n\<rceil>"
   using assms
 proof (induction n xs rule: chop.induct)
   case (3 n xs)
   show ?case
   proof (cases "length xs \<ge> n")
     case False
     hence "\<lceil>real (length xs) / real n\<rceil> = 1" using "3.hyps"
       by (intro ceiling_unique) auto
     with False show ?thesis using "3.prems" "3.hyps"
       by (auto simp: chop_ge_length_eq not_le)
   next
     case True
     hence "real (length xs) = real n + real (length (drop n xs))"
       by simp
     also have "\<dots> / real n = real (length (drop n xs)) / real n + 1"
       using \<open>n > 0\<close> by (simp add: divide_simps)
     also have "ceiling \<dots> = ceiling (real (length (drop n xs)) / real n) + 1" by simp
     also have "nat \<dots> = nat (ceiling (real (length (drop n xs)) / real n)) + nat 1"
       by (intro nat_add_distrib[OF order.trans[OF _ ceiling_mono[of 0]]]) auto
     also have "\<dots> = length (chop n xs)"
       using \<open>n > 0\<close> "3.hyps" by (subst "3.IH" [symmetric]) auto
     finally show ?thesis ..
   qed
 qed auto
 
 lemma sum_msets_chop: "n > 0 \<Longrightarrow> (\<Sum>ys\<leftarrow>chop n xs. mset ys) = mset xs"
   by (subst mset_concat [symmetric]) simp_all
 
 lemma UN_sets_chop: "n > 0 \<Longrightarrow> (\<Union>ys\<in>set (chop n xs). set ys) = set xs"
   by (simp only: set_concat [symmetric] concat_chop)
 
 lemma in_set_chopD [dest]:
   assumes "x \<in> set ys" "ys \<in> set (chop d xs)"
   shows   "x \<in> set xs"
 proof (cases "d > 0")
   case True
   thus ?thesis by (subst UN_sets_chop [symmetric]) (use assms in auto)
 qed (use assms in auto)
 
 
 subsection \<open>$k$-th order statistics and medians\<close>
 
 text \<open>
   This returns the $k$-th smallest element of a list. This is also known as the $k$-th order
   statistic.
 \<close>
 definition select :: "nat \<Rightarrow> 'a list \<Rightarrow> ('a :: linorder)" where
   "select k xs = sort xs ! k"
 
 text \<open>
   The median of a list, where, for lists of even lengths, the smaller one is favoured:
 \<close>
 definition median where "median xs = select ((length xs - 1) div 2) xs"
 
 lemma select_in_set [intro,simp]:
   assumes "k < length xs"
   shows   "select k xs \<in> set xs"
 proof -
   from assms have "sort xs ! k \<in> set (sort xs)" by (intro nth_mem) auto
   also have "set (sort xs) = set xs" by simp
   finally show ?thesis by (simp add: select_def)
 qed
 
 lemma median_in_set [intro, simp]: 
   assumes "xs \<noteq> []"
   shows   "median xs \<in> set xs"
 proof -
   from assms have "length xs > 0" by auto
   hence "(length xs - 1) div 2 < length xs" by linarith
   thus ?thesis by (simp add: median_def)
 qed
 
 text \<open>
   We show that selection and medians does not depend on the order of the elements:
 \<close>
 lemma sort_cong: "mset xs = mset ys \<Longrightarrow> sort xs = sort ys"
   by (rule properties_for_sort) simp_all
 
 lemma select_cong:
   "k = k' \<Longrightarrow> mset xs = mset xs' \<Longrightarrow> select k xs = select k' xs'"
   by (auto simp: select_def dest: sort_cong)
 
 lemma median_cong: "mset xs = mset xs' \<Longrightarrow> median xs = median xs'"
   unfolding median_def by (intro select_cong) (auto dest: mset_eq_length)
 
 
 text \<open>
   Selection distributes over appending lists under certain conditions:
 \<close>
 lemma sort_append:
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> x \<le> y"
   shows   "sort (xs @ ys) = sort xs @ sort ys"
   using assms  by (intro properties_for_sort) (auto simp: sorted_append)
 
 lemma select_append:
   assumes "\<And>y z. y \<in> set ys \<Longrightarrow> z \<in> set zs \<Longrightarrow> y \<le> z"
   shows   "k < length ys \<Longrightarrow> select k (ys @ zs) = select k ys"
           "k \<in> {length ys..<length ys + length zs} \<Longrightarrow>
              select k (ys @ zs) = select (k - length ys) zs"
   using assms by (simp_all add: select_def sort_append nth_append)
 
 lemma select_append':
   assumes "\<And>y z. y \<in> set ys \<Longrightarrow> z \<in> set zs \<Longrightarrow> y \<le> z" "k < length ys + length zs"
   shows   "select k (ys @ zs) = (if k < length ys then select k ys else select (k - length ys) zs)"
   using assms by (auto intro!: select_append)
 
 
 text \<open>
   We can find simple upper bounds for the number of elements that are strictly less than (resp.
   greater than) the median of a list.
 \<close>
 lemma size_less_than_median:
   "size {#y \<in># mset xs. y < median xs#} \<le> (length xs - 1) div 2"
 proof (cases "xs = []")
   case False
   hence "length xs > 0" by simp
   hence "(length xs - 1) div 2 < length xs" by linarith
   hence "size {#y \<in># mset (sort xs). y < median xs#} \<le> 
            size (mset (take ((length xs - 1) div 2) (sort xs)))"
     unfolding median_def select_def using False
     by (intro size_mset_mono sorted_filter_less_subset_take) auto
   thus ?thesis using False by simp
 qed auto
 
 lemma size_greater_than_median:
   "size {#y \<in># mset xs. y > median xs#} \<le> length xs div 2"
 proof (cases "xs = []")
   case False
   hence "length xs > 0" by simp
   hence "(length xs - 1) div 2 < length xs" by linarith
   hence "size {#y \<in># mset (sort xs). y > median xs#} \<le> 
            size (mset (drop (Suc ((length xs - 1) div 2)) (sort xs)))"
     unfolding median_def select_def using False
     by (intro size_mset_mono sorted_filter_greater_subset_drop) auto
   hence "size (filter_mset (\<lambda>y. y > median xs) (mset xs)) \<le>
            length xs - Suc ((length xs - 1) div 2)" by simp
   also have "\<dots> = length xs div 2" by linarith
   finally show ?thesis .
 qed auto
 
 
 subsection \<open>A more liberal notion of medians\<close>
 
 text \<open>
   We now define a more relaxed version of being ``a median'' as opposed to being ``\emph{the}
   median''. A value is a median if at most half the values in the list are strictly smaller 
   than it and at most half are strictly greater. Note that, by this definition, the median does
   not even have to be in the list itself.
 \<close>
 definition is_median :: "'a :: linorder \<Rightarrow> 'a list \<Rightarrow> bool" where
   "is_median x xs \<longleftrightarrow> length (filter (\<lambda>y. y < x) xs) \<le> length xs div 2 \<and>
                       length (filter (\<lambda>y. y > x) xs) \<le> length xs div 2"
 
 text \<open>
   We set up some transfer rules for @{const is_median}. In particular, we have a rule that
   shows that something is a median for a list iff it is a median on that list w.\,r.\,t.\ 
   the dual order, which will later allow us to argue by symmetry.
 \<close>
 context
   includes lifting_syntax
 begin
 lemma transfer_is_median [transfer_rule]:
   assumes [transfer_rule]: "(r ===> r ===> (=)) (<) (<)"
   shows   "(r ===> list_all2 r ===> (=)) is_median is_median"
   unfolding is_median_def by transfer_prover
 
 lemma list_all2_eq_fun_conv_map: "list_all2 (\<lambda>x y. x = f y) xs ys \<longleftrightarrow> xs = map f ys"
 proof
   assume "list_all2 (\<lambda>x y. x = f y) xs ys"
   thus "xs = map f ys" by induction auto
 next
   assume "xs = map f ys"
   moreover have "list_all2 (\<lambda>x y. x = f y) (map f ys) ys"
     by (induction ys) auto
   ultimately show "list_all2 (\<lambda>x y. x = f y) xs ys" by simp
 qed
 
 lemma transfer_is_median_dual_ord [transfer_rule]:
   "(pcr_dual_ord (=) ===> list_all2 (pcr_dual_ord (=)) ===> (=)) is_median is_median"
   by (auto simp: pcr_dual_ord_def cr_dual_ord_def OO_def rel_fun_def is_median_def 
         list_all2_eq_fun_conv_map o_def less_dual_ord.rep_eq)
 end
 
 lemma is_median_to_dual_ord_iff [simp]:
   "is_median (to_dual_ord x) (map to_dual_ord xs) \<longleftrightarrow> is_median x xs"
   unfolding is_median_def by transfer auto
 
 
 text \<open>
   The following is an obviously equivalent definition of @{const is_median} in terms of
   multisets that is occasionally nicer to use.
 \<close>
 lemma is_median_altdef:
   "is_median x xs \<longleftrightarrow> size (filter_mset (\<lambda>y. y < x) (mset xs)) \<le> length xs div 2 \<and>
                       size (filter_mset (\<lambda>y. y > x) (mset xs)) \<le> length xs div 2"
 proof -
   have *: "length (filter P xs) = size (filter_mset P (mset xs))" for P and xs :: "'a list"
     by (simp flip: mset_filter)
   show ?thesis by (simp only: is_median_def *)
 qed
 
 lemma is_median_cong:
   assumes "x = y" "mset xs = mset ys"
   shows   "is_median x xs \<longleftrightarrow> is_median y ys"
   unfolding is_median_altdef by (simp only: assms mset_eq_length[OF assms(2)])
 
 text \<open>
   If an element is the median of a list of odd length, we can add any element to the list
   and the element is still a median. Conversely, if we want to compute a median of a list with
   even length $n$, we can simply drop one element and reduce the problem to a median of a list
   of size $n - 1$.
 \<close>
 lemma is_median_Cons_odd:
   assumes "is_median x xs" and "odd (length xs)"
   shows   "is_median x (y # xs)"
   using assms by (auto simp: is_median_def)
 
 text \<open>
   And, of course, \emph{the} median is a median.
 \<close>
 lemma is_median_median [simp,intro]: "is_median (median xs) xs"
   using size_less_than_median[of xs] size_greater_than_median[of xs]
   unfolding is_median_def size_mset [symmetric] mset_filter by linarith+
 
 
 subsection \<open>Properties of a median-of-medians\<close>
 
 text \<open>
   We can now bound the number of list elements that can be strictly smaller than a 
   median-of-medians of a chopped-up list (where each part has length $d$ except for the last one,
   which can also be shorter).
 
   The core argument is that at least roughly half of the medians of the sublists are greater or 
   equal to the median-of-medians, and about $\frac{d}{2}$ elements in each such sublist are greater
   than or equal to their median and thereby also than the median-of-medians.
 \<close>
 lemma size_less_than_median_of_medians_strong:
   fixes xs :: "'a :: linorder list" and d :: nat
   assumes d: "d > 0"
   assumes median: "\<And>xs. xs \<noteq> [] \<Longrightarrow> length xs \<le> d \<Longrightarrow> is_median (med xs) xs"
   assumes median': "is_median x (map med (chop d xs))"
   defines "m \<equiv> length (chop d xs)"
   shows   "size {#y \<in># mset xs. y < x#} \<le> m * (d div 2) + m div 2 * ((d + 1) div 2)"
 proof -
   define n where [simp]: "n = length xs"
   \<comment> \<open>The medians of the sublists\<close>
   define M where "M = mset (map med (chop d xs))"
   define YS where "YS = mset (chop d xs)"
   \<comment> \<open>The sublists with a smaller median than the median-of-medians @{term x} and the rest.\<close>
   define YS1 where "YS1 = filter_mset (\<lambda>ys. med ys < x) (mset (chop d xs))"
   define YS2 where "YS2 = filter_mset (\<lambda>ys. \<not>(med ys < x)) (mset (chop d xs))"
 
   \<comment> \<open>At most roughly half of the lists have a median that is smaller than @{term M}\<close>
   have "size YS1 = size (image_mset med YS1)" by simp
   also have "image_mset med YS1 = {#y \<in># mset (map med (chop d xs)). y < x#}"
     unfolding YS1_def by (subst filter_mset_image_mset [symmetric]) simp_all
   also have "size \<dots> \<le> (length (map med (chop d xs))) div 2"
     using median' unfolding is_median_altdef by simp
   also have "\<dots> = m div 2" by (simp add: m_def)
   finally have size_YS1: "size YS1 \<le> m div 2" .
 
   have "m = size (mset (chop d xs))" by (simp add: m_def)
   also have "mset (chop d xs) = YS1 + YS2" unfolding YS1_def YS2_def
     by (rule multiset_partition)
   finally have m_eq: "m = size YS1 + size YS2" by simp
 
   \<comment> \<open>We estimate the number of elements less than @{term x} by grouping them into elements
       coming from @{term YS1} and elements coming from @{term YS2}. In the first case, we 
       just note that no more than @{term d} elements can come from each sublist, whereas in
       the second case, we make the analysis more precise and note that only elements that are
       less than the median of their sublist can be less than @{term x}.\<close>
   have "{# y \<in># mset xs. y < x#} = {# y \<in># (\<Sum>ys\<leftarrow>chop d xs. mset ys). y < x#}" using d
     by (subst sum_msets_chop) simp_all
   also have "\<dots> = (\<Sum>ys\<leftarrow>chop d xs. {#y \<in># mset ys. y < x#})"
     by (subst filter_mset_sum_list) (simp add: o_def)
   also have "\<dots> = (\<Sum>ys\<in>#YS. {#y \<in># mset ys. y < x#})" unfolding YS_def
     by (subst sum_mset_sum_list [symmetric]) simp_all
   also have "YS = YS1 + YS2"
     by (simp add: YS_def YS1_def YS2_def not_le)
   also have "(\<Sum>ys\<in>#\<dots>. {#y \<in># mset ys. y < x#}) = 
                (\<Sum>ys\<in>#YS1. {#y \<in># mset ys. y < x#}) + (\<Sum>ys\<in>#YS2. {#y \<in># mset ys. y < x#})"
     by simp
   also have "\<dots> \<subseteq># (\<Sum>ys\<in>#YS1. mset ys) + (\<Sum>ys\<in>#YS2. {#y \<in># mset ys. y < med ys#})"
     by (intro subset_mset.add_mono sum_mset_mset_mono mset_filter_mono) (auto simp: YS2_def)
   finally have "{# y \<in># mset xs. y < x #} \<subseteq># \<dots>" .
   hence "size {# y \<in># mset xs. y < x #} \<le> size \<dots>" by (rule size_mset_mono)
 
   \<comment> \<open>We do some further straightforward estimations and arrive at our goal.\<close>
   also have "\<dots> = (\<Sum>ys\<in>#YS1. length ys) + (\<Sum>x\<in>#YS2. size {#y \<in># mset x. y < med x#})"
     by (simp add: size_mset_sum_mset_distrib multiset.map_comp o_def)
   also have "(\<Sum>ys\<in>#YS1. length ys) \<le> (\<Sum>ys\<in>#YS1. d)"
     by (intro sum_mset_mono) (auto simp: YS1_def length_chop_part_le)
   also have "\<dots> = size YS1 * d" by simp
   also have d: "d = (d div 2) + ((d + 1) div 2)" using d by linarith
   have "size YS1 * d = size YS1 * (d div 2) + size YS1 * ((d + 1) div 2)"
     by (subst d) (simp add: algebra_simps)
   also have "(\<Sum>ys\<in>#YS2. size {#y \<in># mset ys. y < med ys#}) \<le>
                (\<Sum>ys\<in>#YS2. length ys div 2)"
   proof (intro sum_mset_mono size_less_than_median, goal_cases)
     case (1 ys)
     hence "ys \<noteq> []" "length ys \<le> d" by (auto simp: YS2_def length_chop_part_le)
     from median[OF this] show ?case by (auto simp: is_median_altdef)
   qed
   also have "\<dots> \<le> (\<Sum>ys\<in>#YS2. d div 2)"
     by (intro sum_mset_mono div_le_mono diff_le_mono) (auto simp: YS2_def dest: length_chop_part_le)
   also have "\<dots> = size YS2 * (d div 2)" by simp
   also have "size YS1 * (d div 2) + size YS1 * ((d + 1) div 2) + \<dots> =
                m * (d div 2) + size YS1 * ((d + 1) div 2)" by (simp add: m_eq algebra_simps)
   also have "size YS1 * ((d + 1) div 2) \<le> (m div 2) * ((d + 1) div 2)"
     by (intro mult_right_mono size_YS1) auto
   finally show "size {#y \<in># mset xs. y < x#} \<le>
                   m * (d div 2) + m div 2 * ((d + 1) div 2)" by simp_all
 qed
 
 text \<open>
   We now focus on the case of an odd chopping size and make some further estimations to 
   simplify the above result a little bit.
 \<close>
 theorem size_less_than_median_of_medians:
   fixes xs :: "'a :: linorder list" and d :: nat
   assumes median: "\<And>xs. xs \<noteq> [] \<Longrightarrow> length xs \<le> Suc (2 * d) \<Longrightarrow> is_median (med xs) xs"
   assumes median': "is_median x (map med (chop (Suc (2*d)) xs))"
   defines "n \<equiv> length xs"
   defines "c \<equiv> (3 * real d + 1) / (2 * (2 * d + 1))"
   shows   "size {#y \<in># mset xs. y < x#} \<le> nat \<lceil>c * n\<rceil> + (5 * d) div 2 + 1"
 proof (cases "xs = []")
   case False
   define m where "m = length (chop (Suc (2*d)) xs)"
 
   have "real (m div 2) \<le> real (nat \<lceil>real n / (1 + 2 * real d)\<rceil>) / 2"
     by (simp add: m_def length_chop n_def)
   also have "real (nat \<lceil>real n / (1 + 2 * real d)\<rceil>) =
                of_int \<lceil>real n / (1 + 2 * real d)\<rceil>"
     by (intro of_nat_nat) (auto simp: divide_simps)
   also have "\<dots> / 2 \<le> (real n / (1 + 2 * real d) + 1) / 2"
     by (intro divide_right_mono) linarith+
   also have "\<dots> = n / (2 * (2 * real d + 1)) + 1 / 2" by (simp add: field_simps)
   finally have m: "real (m div 2) \<le> \<dots>" .
 
   have "size {#y \<in># mset xs. y < x#} \<le> d * m + Suc d * (m div 2)"
     using size_less_than_median_of_medians_strong[of "Suc (2 * d)" med x xs] assms
     unfolding m_def by (simp add: algebra_simps)
   also have "\<dots> \<le> d * (2 * (m div 2) + 1) + Suc d * (m div 2)"
     by (intro add_mono mult_left_mono) linarith+
   also have "\<dots> = (3 * d + 1) * (m div 2) + d"
     by (simp add: algebra_simps)
   finally have "real (size {#y \<in># mset xs. y < x#}) \<le> real \<dots>"
     by (subst of_nat_le_iff)
   also have "\<dots> \<le> (3 * real d + 1) * (n / (2 * (2 * d + 1)) + 1/2) + real d"
     unfolding of_nat_add of_nat_mult of_nat_1 of_nat_numeral
     by (intro add_mono mult_mono order.refl m) (auto simp: m_def length_chop n_def add_ac)
   also have "\<dots> = c * real n + (5 * real d + 1) / 2"
     by (simp add: field_simps c_def)
   also have "\<dots> \<le> real (nat \<lceil>c * n\<rceil> + ((5 * d) div 2 + 1))"
     unfolding of_nat_add by (intro add_mono) (linarith, simp add: field_simps)
   finally show ?thesis by (subst (asm) of_nat_le_iff) (simp_all add: add_ac)
 qed auto
 
 text \<open>
   We get the analogous result for the number of elements that are greater than a median-of-medians
   by looking at the dual order and using the \emph{transfer} method.
 \<close>
 theorem size_greater_than_median_of_medians:
   fixes xs :: "'a :: linorder list" and d :: nat
   assumes median: "\<And>xs. xs \<noteq> [] \<Longrightarrow> length xs \<le> Suc (2 * d) \<Longrightarrow> is_median (med xs) xs"
   assumes median': "is_median x (map med (chop (Suc (2*d)) xs))" 
   defines "n \<equiv> length xs"
   defines "c \<equiv> (3 * real d + 1) / (2 * (2 * d + 1))"
   shows   "size {#y \<in># mset xs. y > x#} \<le> nat \<lceil>c * n\<rceil> + (5 * d) div 2 + 1"
 proof -
   include lifting_syntax
   define med' where "med' = (\<lambda>xs. to_dual_ord (med (map of_dual_ord xs)))"
   have "xs = map of_dual_ord ys" if "list_all2 cr_dual_ord xs ys" for xs :: "'a list" and ys
     using that by induction (auto simp: cr_dual_ord_def)
   hence [transfer_rule]: "(list_all2 (pcr_dual_ord (=)) ===> pcr_dual_ord (=)) med med'"
     by (auto simp: rel_fun_def pcr_dual_ord_def OO_def med'_def cr_dual_ord_def 
                    dual_ord.to_dual_ord_inverse)
 
   have "size {#y \<in># mset xs. y > x#} = length (filter (\<lambda>y. y > x) xs)"
     by (subst size_mset [symmetric]) (simp only: mset_filter)
   also have "\<dots> = length (map to_dual_ord (filter (\<lambda>y. y > x) xs))" by simp
   also have "(\<lambda>y. y > x) = (\<lambda>y. to_dual_ord y < to_dual_ord x)"
     by transfer simp_all
   hence "length (map to_dual_ord (filter (\<lambda>y. y > x) xs)) = length (map to_dual_ord (filter \<dots> xs))"
     by simp
   also have "\<dots> = length (filter (\<lambda>y. y < to_dual_ord x) (map to_dual_ord xs))"
     unfolding filter_map o_def by simp
   also have "\<dots> = size {#y \<in># mset (map to_dual_ord xs). y < to_dual_ord x#}"
     by (subst size_mset [symmetric]) (simp only: mset_filter)
   also have "\<dots> \<le> nat \<lceil>(3 * real d + 1) / real (2 * (2 * d + 1)) * length (map to_dual_ord xs)\<rceil>
                     + 5 * d div 2 + 1"
   proof (intro size_less_than_median_of_medians)
     fix xs :: "'a dual_ord list" assume xs: "xs \<noteq> []" "length xs \<le> Suc (2 * d)"
     from xs show "is_median (med' xs) xs" by (transfer fixing: d) (rule median)
   next
     show "is_median (to_dual_ord x) (map med' (chop (Suc (2 * d)) (map to_dual_ord xs)))"
       by (transfer fixing: d x xs) (use median' in simp_all)
   qed
   finally show ?thesis by (simp add: n_def c_def)
 qed
 
 
 text \<open>
   The most important case is that of chopping size 5, since that is the most practical one
   for the median-of-medians selection algorithm. For it, we obtain the following nice
   and simple bounds:
 \<close>
 corollary size_less_greater_median_of_medians_5:
   fixes xs :: "'a :: linorder list"
   assumes "\<And>xs. xs \<noteq> [] \<Longrightarrow> length xs \<le> 5 \<Longrightarrow> is_median (med xs) xs"
   assumes "is_median x (map med (chop 5 xs))" 
   shows "length (filter (\<lambda>y. y < x) xs) \<le> nat \<lceil>0.7 * length xs\<rceil> + 6"
     and "length (filter (\<lambda>y. y > x) xs) \<le> nat \<lceil>0.7 * length xs\<rceil> + 6"
   using size_less_than_median_of_medians[of 2 med x xs]
         size_greater_than_median_of_medians[of 2 med x xs] assms
   by (simp_all add: size_mset [symmetric] mset_filter mult_ac add_ac del: size_mset)
 
 
 subsection \<open>The recursive step\<close>
 
 text \<open>
   We now turn to the actual selection algorithm itself. The following simple reduction lemma 
   illustrates the idea of the algorithm quite well already, but it has the disadvantage that,
   if one were to use it as a recursive algorithm, it would only work for lists with distinct
   elements. If the list contains repeated elements, this may not even terminate.
 
   The basic idea is that we choose some pivot element, partition the list into elements that 
   are bigger than the pivot and those that are not, and then recurse into one of these (hopefully
   smaller) lists.
 \<close>
 theorem select_rec_partition:
   assumes "d > 0" "k < length xs"
   shows "select k xs = (
            let (ys, zs) = partition (\<lambda>y. y \<le> x) xs
            in  if k < length ys then select k ys else select (k - length ys) zs
           )" (is "_ = ?rhs")
 proof -
   define ys zs where "ys = filter (\<lambda>y. y \<le> x) xs" and "zs = filter (\<lambda>y. \<not>(y \<le> x)) xs"
   have "select k xs = select k (ys @ zs)"
     by (intro select_cong) (simp_all add: ys_def zs_def)
   also have "\<dots> = (if k < length ys then select k ys else select (k - length ys) zs)"
     using assms(2) by (intro select_append') (auto simp: ys_def zs_def sum_length_filter_compl)
   finally show ?thesis by (simp add: ys_def zs_def Let_def o_def)
 qed
 
 text \<open>
   The following variant uses a three-way partitioning function instead. This way, the size of
   the list in the final recursive call decreases by a factor of at least $\frac{3d'+1}{2(2d'+1)}$ 
   by the previous estimates, given that the chopping size is $d = 2d'+1$. For a chopping size of 5,
   we get a factor of $0.7$. 
 \<close>
 definition threeway_partition :: "'a \<Rightarrow> 'a :: linorder list \<Rightarrow> 'a list \<times> 'a list \<times> 'a list" where
   "threeway_partition x xs = (filter (\<lambda>y. y < x) xs, filter (\<lambda>y. y = x) xs, filter (\<lambda>y. y > x) xs)"
 
 lemma threeway_partition_code [code]:
   "threeway_partition x [] = ([], [], [])"
   "threeway_partition x (y # ys) =
      (case threeway_partition x ys of (ls, es, gs) \<Rightarrow>
         if y < x then (y # ls, es, gs) else if x = y then (ls, y # es, gs) else (ls, es, y # gs))"
   by (auto simp: threeway_partition_def)
 
 theorem select_rec_threeway_partition:
   assumes "d > 0" "k < length xs"
   shows "select k xs = (
            let (ls, es, gs) = threeway_partition x xs;
                nl = length ls; ne = length es
            in
              if k < nl then select k ls 
              else if k < nl + ne then x
              else select (k - nl - ne) gs
           )" (is "_ = ?rhs")
 proof -
   define ls es gs where "ls = filter (\<lambda>y. y < x) xs" and "es = filter (\<lambda>y. y = x) xs"
                     and "gs = filter (\<lambda>y. y > x) xs"
   define nl ne where [simp]: "nl = length ls" "ne = length es"
   have mset_eq: "mset xs = mset ls + mset es + mset gs" unfolding ls_def es_def gs_def
     by (induction xs) auto
   have length_eq: "length xs = length ls + length es + length gs" unfolding ls_def es_def gs_def
-    by (induction xs) auto
+    by (induction xs) (auto simp del: filter_True)
+    
   have [simp]: "select i es = x" if "i < length es" for i
   proof -
     have "select i es \<in> set (sort es)" unfolding select_def
       using that by (intro nth_mem) auto
     hence "select i es \<in> set es" using that by (auto simp: select_def)
     also have "set es \<subseteq> {x}" unfolding es_def by (induction es) auto
     finally show ?thesis by simp
   qed
 
   have "select k xs = select k (ls @ (es @ gs))"
     by (intro select_cong) (simp_all add: mset_eq)
   also have "\<dots> = (if k < nl then select k ls else select (k - nl) (es @ gs))" 
     unfolding nl_ne_def using assms
     by (intro select_append') (auto simp: ls_def es_def gs_def length_eq)
   also have "\<dots> = (if k < nl then select k ls else if k < nl + ne then x
                     else select (k - nl - ne) gs)" (is "?lhs' = ?rhs'")
   proof (cases "k < nl")
     case False
     hence "?lhs' = select (k - nl) (es @ gs)" by simp
     also have "\<dots> = (if k - nl < ne then select (k - nl) es else select (k - nl - ne) gs)"
       unfolding nl_ne_def using assms False
       by (intro select_append') (auto simp: ls_def es_def gs_def length_eq)
     also have "\<dots> = (if k - nl < ne then x else select (k - nl - ne) gs)"
       by simp
     also from False have "\<dots> = ?rhs'" by auto
     finally show ?thesis .
   qed simp_all
   also have "\<dots> = ?rhs"
     by (simp add: threeway_partition_def Let_def ls_def es_def gs_def)
   finally show ?thesis .
 qed
 
 text \<open>
   By the above results, it can be seen quite easily that, in each recursive step, the algorithm
   takes a list of length $n$, does $O(n)$ work for the chopping, computing the medians of the
   sublists, and partitioning, and it calls itself recursively with lists of size at most
   $\lceil 0.2n\rceil$ and $\lceil 0.7n\rceil + 6$, respectively. This means that the runtime
   of the algorithm is bounded above by the Akra--Bazzi-style recurrence
     \[T(n) = T(\lceil 0.2n\rceil) + T(\lceil 0.7n\rceil + 6) + O(n)\]
   which, by the Akra--Bazzi theorem, can be shown to fulfil $T\in \Theta(n)$.
 
   However, a proper analysis of this would require an actual execution model and some way of 
   measuring the runtime of the algorithm, which is not what we aim to do here. Additionally, the
   entire algorithm can be performed in-place in an imperative way, but this because quite tedious.
 
   Instead of this, we will now focus on developing the above recursion into an executable 
   functional algorithm.
 \<close>
 
 
 subsection \<open>Medians of lists of length at most 5\<close>
 
 text \<open>
   We now show some basic results about how to efficiently find a median of a list of size
   at most 5. For length 1 or 2, this is trivial, since we can just pick any element. For length 
   3 and 4, we need at most three comparisons. For length 5, we need at most six comparisons.
 
   This allows us to save some comparisons compared with the naive method of performing insertion
   sort and then returning the element in the middle.
 \<close>
 definition median_3 :: "'a :: linorder \<Rightarrow> _" where
   "median_3 a b c =
      (if a \<le> b then
         if b \<le> c then b else max a c
       else
         if c \<le> b then b else min a c)"
 
 lemma median_3: "median_3 a b c = median [a, b, c]"
   by (auto simp: median_3_def median_def select_def min_def max_def)
 
 definition median_5_aux :: "'a :: linorder \<Rightarrow> _" where
   "median_5_aux x1 x2 x3 x4 x5 = (
      if x2 \<le> x3 then if x2 \<le> x4 then min x3 x4 else min x2 x5
      else if x4 \<le> x3 then min x3 x5 else min x2 x4)"
 
 lemma median_5_aux:
   assumes "x1 \<le> x2" "x4 \<le> x5" "x1 \<le> x4" 
   shows   "median_5_aux x1 x2 x3 x4 x5 = median [x1,x2,x3,x4,x5]"
   using assms by (auto simp: median_5_aux_def median_def select_def min_def)
 
 definition median_5 :: "'a :: linorder \<Rightarrow> _" where
   "median_5 a b c d e = (
      let (x1, x2) = (if a \<le> b then (a, b) else (b, a));
          (x4, x5) = (if d \<le> e then (d, e) else (e, d))
      in
          if x1 \<le> x4 then median_5_aux x1 x2 c x4 x5 else median_5_aux x4 x5 c x1 x2)"
 
 lemma median_5: "median_5 a b c d e = median [a, b, c, d, e]"
   by (auto simp: median_5_def Let_def median_5_aux intro: median_cong)
 
 fun median_le_5 where
   "median_le_5 [a] = a"
 | "median_le_5 [a,b] = a"
 | "median_le_5 [a,b,c] = median_3 a b c"
 | "median_le_5 [a,b,c,d] = median_3 a b c"
 | "median_le_5 [a,b,c,d,e] = median_5 a b c d e"
 | "median_le_5 _ = undefined"
 
 lemma median_5_in_set: "median_5 a b c d e \<in> {a, b, c, d, e}"
 proof -
   have "median_5 a b c d e \<in> set [a, b, c, d, e]"
     unfolding median_5 by (rule median_in_set) auto
   thus ?thesis by simp
 qed
 
 lemma median_le_5_in_set:
   assumes "xs \<noteq> []" "length xs \<le> 5"
   shows   "median_le_5 xs \<in> set xs"
 proof (cases xs rule: median_le_5.cases)
   case (5 a b c d e)
   with median_5_in_set[of a b c d e] show ?thesis by simp
 qed (insert assms, auto simp: median_3_def min_def max_def)
 
 lemma median_le_5:
   assumes "xs \<noteq> []" "length xs \<le> 5"
   shows   "is_median (median_le_5 xs) xs"
 proof (cases xs rule: median_le_5.cases)
   case (3 a b c)
   have "is_median (median xs) xs" by simp
   also have "median xs = median_3 a b c" by (simp add: median_3 3)
   finally show ?thesis using 3 by simp
 next
   case (4 a b c d)
   have "is_median (median [a,b,c]) [a,b,c]" by simp
   also have "median [a,b,c] = median_3 a b c" by (simp add: median_3 4)
   finally have "is_median (median_3 a b c) (d # [a,b,c])" by (rule is_median_Cons_odd) auto
   also have "?this \<longleftrightarrow> is_median (median_3 a b c) [a,b,c,d]" by (intro is_median_cong) auto
   finally show ?thesis using 4 by simp
 next
   case (5 a b c d e)
   have "is_median (median xs) xs" by simp
   also have "median xs = median_5 a b c d e" by (simp add: median_5 5)
   finally show ?thesis using 5 by simp  
 qed (insert assms, auto simp: is_median_def)
 
 
 subsection \<open>Median-of-medians selection algorithm\<close>
 
 text \<open>
   The fast selection function now simply computes the median-of-medians of the chopped-up list
   as a pivot, partitions the list into with respect to that pivot, and recurses into one of 
   the resulting sublists.
 \<close>
 function fast_select where
   "fast_select k xs = (
      if length xs \<le> 20 then
        sort xs ! k
      else
        let x = fast_select (((length xs + 4) div 5 - 1) div 2) (map median_le_5 (chop 5 xs));
            (ls, es, gs) = threeway_partition x xs
        in
          if k < length ls then fast_select k ls 
          else if k < length ls + length es then x
          else fast_select (k - length ls - length es) gs
       )"
   by auto
 
 text \<open>
   The correctness of this is obvious from the above theorems, but the proof is still
   somewhat complicated by the fact that termination depends on the correctness of the
   function.
 \<close>
 lemma fast_select_correct_aux:
   assumes "fast_select_dom (k, xs)" "k < length xs"
   shows   "fast_select k xs = select k xs"
   using assms
 proof induction
   case (1 k xs)
   show ?case
   proof (cases "length xs \<le> 20")
     case True
     thus ?thesis using "1.prems" "1.hyps"
       by (subst fast_select.psimps) (auto simp: select_def)
   next
     case False
     define x where
       "x = fast_select (((length xs + 4) div 5 - Suc 0) div 2) (map median_le_5 (chop 5 xs))"
     define ls where "ls = filter (\<lambda>y. y < x) xs"
     define es where "es = filter (\<lambda>y. y = x) xs"
     define gs where "gs = filter (\<lambda>y. y > x) xs"
     define nl ne where "nl = length ls" and "ne = length es"
     note defs = nl_def ne_def x_def ls_def es_def gs_def
     have tw: "(ls, es, gs) = threeway_partition (fast_select (((length xs + 4) div 5 - 1) div 2)
                                (map median_le_5 (chop 5 xs))) xs"
       unfolding threeway_partition_def defs One_nat_def ..
     have tw': "(ls, es, gs) = threeway_partition x xs"
       by (simp add: tw x_def)
 
     have "fast_select k xs = (if k < nl then fast_select k ls else if k < nl + ne then x
                                 else fast_select (k - nl - ne) gs)" using "1.hyps" False
       by (subst fast_select.psimps) (simp_all add: threeway_partition_def defs [symmetric])
     also have "\<dots> = (if k < nl then select k ls else if k < nl + ne then x 
                        else select (k - nl - ne) gs)"
     proof (intro if_cong refl)
       assume *: "k < nl"
       show "fast_select k ls = select k ls"
         by (rule 1; (rule refl tw)?) 
            (insert *, auto simp: False threeway_partition_def ls_def x_def nl_def)+
     next
       assume *: "\<not>k < nl" "\<not>k < nl + ne"
       have **: "length xs = length ls + length es + length gs"
-        unfolding ls_def es_def gs_def by (induction xs) auto
+        unfolding ls_def es_def gs_def by (induction xs) (auto simp del: filter_True)
       show "fast_select (k - nl - ne) gs = select (k - nl - ne) gs"
         unfolding nl_def ne_def
         by (rule 1; (rule refl tw)?) (insert False * ** \<open>k < length xs\<close>, auto simp: nl_def ne_def)
     qed
     also have "\<dots> = select k xs" using \<open>k < length xs\<close>
       by (subst (3) select_rec_threeway_partition[of "5::nat" _ _ x])
          (unfold Let_def nl_def ne_def ls_def gs_def es_def x_def threeway_partition_def, simp_all)
     finally show ?thesis .
   qed
 qed
 
 text \<open>
   Termination of the algorithm is reasonably obvious because the lists that are recursed into
   never contain the pivot (the median-of-medians), while the original list clearly does.
   The proof is still somewhat technical though.
 \<close>
 lemma fast_select_termination: "All fast_select_dom"
 proof (relation "measure (length \<circ> snd)"; (safe)?, goal_cases)
   case (1 k xs)
   thus ?case
     by (auto simp: length_chop nat_less_iff ceiling_less_iff)
 next
   fix k :: nat and xs ls es gs :: "'a list"
   define x where "x = fast_select (((length xs + 4) div 5 - 1) div 2) (map median_le_5 (chop 5 xs))"
   assume A: "\<not> length xs \<le> 20" 
             "(ls, es, gs) = threeway_partition x xs"
             "fast_select_dom (((length xs + 4) div 5 - 1) div 2, 
                              map median_le_5 (chop 5 xs))"
   from A have eq: "ls = filter (\<lambda>y. y < x) xs" "gs = filter (\<lambda>y. y > x) xs"
     by (simp_all add: x_def threeway_partition_def)
   have len: "(length xs + 4) div 5 = nat \<lceil>length xs / 5\<rceil>" by linarith
   have less: "(nat \<lceil>real (length xs) / 5\<rceil> - Suc 0) div 2 < nat \<lceil>real (length xs) / 5\<rceil>"
     using A(1) by linarith
   have "x = select (((length xs + 4) div 5 - 1) div 2) (map median_le_5 (chop 5 xs))"
     using less unfolding x_def by (intro fast_select_correct_aux A) (auto simp: length_chop len)
   also have "\<dots> = median (map median_le_5 (chop 5 xs))" by (simp add: median_def len length_chop)
   finally have x: "x = \<dots>" .
   moreover {
     have "x \<in> set (map median_le_5 (chop 5 xs))"
       using A(1) unfolding x by (intro median_in_set) auto
     also have "\<dots> \<subseteq> (\<Union>ys\<in>set (chop 5 xs). {median_le_5 ys})" by auto
     also have "\<dots> \<subseteq> (\<Union>ys\<in>set (chop 5 xs). set ys)" using A(1)
       by (intro UN_mono) (auto simp: median_le_5_in_set length_chop_part_le)
     also have "\<dots> = set xs" by (subst UN_sets_chop) auto
     finally have "x \<in> set xs" .
   }  
   ultimately show "((k, ls), k, xs) \<in> measure (length \<circ> snd)"
               and "((k - length ls - length es, gs), k, xs) \<in> measure (length \<circ> snd)"
     using A(1) by (auto simp: eq intro!: length_filter_less[of x])
 qed
 
 
 text \<open>
   We now have all the ingredients to show that @{const fast_select} terminates and does,
   indeed, compute the $k$-th order statistic.
 \<close>
 termination fast_select by (rule fast_select_termination)
 
 theorem fast_select_correct: "k < length xs \<Longrightarrow> fast_select k xs = select k xs"
   using fast_select_termination by (intro fast_select_correct_aux) auto
 
 
 text \<open>
   The following version is then suitable for code export.
 \<close>
 lemma fast_select_code [code]:
   "fast_select k xs = (
      if length xs \<le> 20 then
        fold insort xs [] ! k
      else
        let x = fast_select (((length xs + 4) div 5 - 1) div 2) (map median_le_5 (chop 5 xs));
            (ls, es, gs) = threeway_partition x xs;
            nl = length ls; ne = nl + length es
        in
          if k < nl then fast_select k ls 
          else if k < ne then x
          else fast_select (k - ne) gs
       )"
   by (subst fast_select.simps) (simp_all only: Let_def algebra_simps sort_conv_fold)
 
 lemma select_code [code]: 
   "select k xs = (if k < length xs then fast_select k xs 
                     else Code.abort (STR ''Selection index out of bounds.'') (\<lambda>_. select k xs))"
 proof (cases "k < length xs")
   case True
   thus ?thesis by (simp only: if_True fast_select_correct)
 qed (simp_all only: Code.abort_def if_False)
 
 end
diff --git a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy
--- a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy
+++ b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy
@@ -1,1716 +1,1714 @@
 theory Concrete_Reachability_Analysis_C1
 imports
   Concrete_Reachability_Analysis
   Abstract_Reachability_Analysis_C1
 begin
 
 definition "op_card_vec TYPE('a) = CARD('a)"
 lemma op_card_vec_pat_def[autoref_op_pat_def]: "CARD('a) \<equiv> OP (op_card_vec TYPE('a))"
   by (auto simp: op_card_vec_def)
 lemma op_card_vec_impl[autoref_rules]:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::enum rvec) E"
   shows "(E, op_card_vec TYPE('a)) \<in> nat_rel"
   using assms by (auto simp: op_card_vec_def)
 
 
 context approximate_sets
 begin
 
 sublocale approximate_sets_ode' where ode_ops = ode_ops for ode_ops ..\<comment> \<open>parametrized by \<open>ode_ops\<close>\<close>
 
 end
 
 context approximate_sets
 begin
 
 lemma nonneg_reals_autoref[autoref_rules]: "(None, nonneg_reals) \<in> \<langle>Id\<rangle>phantom_rel"
   and pos_reals_autoref[autoref_rules]: "(None, pos_reals) \<in> \<langle>Id\<rangle>phantom_rel"
   by (auto simp: phantom_rel_def)
 
 lemma appr1_relI:
   assumes "c1_info_invar DIM('n::executable_euclidean_space) X0i"
   shows "(X0i, (c1_info_of_appr X0i::'n c1_info set)) \<in> appr1_rel"
     using assms
   apply (cases "snd X0i")
   subgoal
     apply (simp add: c1_info_of_appr_def c1_info_invar_def)
     unfolding appr1_rel_internal
     apply (rule UnI1)
     apply auto
     apply (rule exI[where x="fst X0i"])
     apply safe
     subgoal by (auto simp: prod_eq_iff)
     subgoal
       apply (rule exI[where x="eucl_of_list ` set_of_appr (fst X0i)"])
       apply (auto simp: appr_rel_def)
       by (auto simp: appr_rell_internal lv_rel_def set_rel_br br_chain length_set_of_appr
           intro!: brI)
     done
   subgoal for D
     apply (simp add: c1_info_of_appr_def c1_info_invar_def)
     unfolding appr1_rel_internal
     apply (rule UnI2)
     apply (auto simp: set_rel_br)
     apply (rule exI[where x="fst X0i"])
     apply (rule exI[where x=D])
     apply safe
     subgoal by (auto simp: prod_eq_iff)
     subgoal
       by (auto simp: appr_rell_internal lv_rel_def set_rel_br br_chain length_set_of_appr
           intro!: brI) (auto simp:  power2_eq_square)
     done
   done
 
 lemma appr1_rel_br: "appr1_rel = br (c1_info_of_appr::_\<Rightarrow>('n c1_info)set) (c1_info_invar DIM('n::executable_euclidean_space))"
   apply (auto simp: dest!: brD intro!: appr1_relI)
   apply (rule brI)
   subgoal by (auto simp: appr1_rel_internal c1_info_of_appr_def appr_rel_br set_rel_br dest!: brD)
   subgoal by (auto simp: c1_info_invar_def appr1_rel_internal appr_rel_br power2_eq_square dest!: brD)
   done
 
 lemma appr1_rel_aux:
   "{((xs, Some ys), X) |xs ys X. (xs @ ys, X) \<in> appr_rel \<and> length ys = (length xs)\<^sup>2} O
     \<langle>br flow1_of_vec1 top\<rangle>set_rel =
   {((xs, Some ys), X::'n eucl1 set) |xs ys X.
      X = (\<lambda>xs. flow1_of_vec1 (eucl_of_list xs)) ` set_of_appr (xs @ ys) \<and>
      length xs = DIM((real, 'n::enum) vec) \<and> length ys = DIM((real, 'n) vec) * DIM((real, 'n) vec)}"
   apply (auto simp: set_rel_br appr_rel_br power2_eq_square dest!: brD)
   apply (rule relcompI)
    apply simp
    apply (rule brI) apply (rule refl) apply simp
   apply (rule brI) defer apply simp
   apply auto
   done
 
 lemma flow1_of_list_def':
   shows "flow1_of_list xs = flow1_of_vec1 (eucl_of_list xs)"
   by (auto simp: flow1_of_list_def flow1_of_vec1_def eucl_of_list_prod
       blinfun_of_list_eq_blinfun_of_vmatrix)
 
 lemma appr1_rel_def:
   "appr1_rel =
     {((xs, None   ), X \<times> UNIV)| xs X. (xs, X) \<in> appr_rel} \<union>
     {((xs, Some ys), X)| xs ys X. (xs @ ys, X) \<in> appr_rel \<and> length ys = (length xs)\<^sup>2} O \<langle>br flow1_of_vec1 top\<rangle>set_rel"
   unfolding appr1_rel_internal flow1_of_list_def'[abs_def] appr1_rel_aux ..
 
 lemmas [autoref_rel_intf] = REL_INTFI[of appr1_rel i_appr1]
 lemma [autoref_op_pat]: "(`) flow1_of_vec1 \<equiv> OP op_image_flow1_of_vec1"
   by auto
 
 lemma op_image_flow1_of_vec1[autoref_rules]:
   assumes "DIM_precond TYPE('a rvec) E"
   shows "(\<lambda>xs. (take E xs, Some (drop E xs)),
     op_image_flow1_of_vec1::('a::enum) vec1 set\<Rightarrow>_) \<in> appr_rel \<rightarrow> appr1_rel"
   using assms
   apply (auto simp: appr1_rel_def set_rel_br flow1_of_vec1_def[abs_def] intro!: brI elim!: notE
       split: option.splits list.splits)
   apply (rule relcompI[OF _ brI[OF refl]])
    apply (auto simp: power2_eq_square min_def appr_rel_br br_def)
   done
 
 lemma index_autoref[autoref_rules]:
   "(index, index) \<in> \<langle>lv_rel\<rangle>list_rel \<rightarrow> lv_rel \<rightarrow> nat_rel"
   unfolding index_def[abs_def] find_index_def
   apply parametricity
   apply (auto simp: lv_rel_def br_def list_rel_def)
   using list_of_eucl_eucl_of_list by force
 
 lemma [autoref_op_pat]: "(`) fst \<equiv> OP op_image_fst"
   by auto
 
 lemma op_image_fst_flow1[autoref_rules]:
   shows "(\<lambda>x. fst x, op_image_fst::_\<Rightarrow>'n::executable_euclidean_space set) \<in> appr1_rel \<rightarrow> appr_rel"
   apply (auto simp: appr1_rel_internal flow1_of_list_def set_rel_br image_image power2_eq_square dest!: brD)
   apply (auto simp: br_def appr_rel_br length_set_of_appr image_image eucl_of_list_prod
       dest!: set_of_appr_takeD)
   subgoal for xs ys a
     apply (rule image_eqI[where x="take DIM('n) a"])
     by (auto intro!: take_set_of_apprI dest: length_set_of_appr)
   subgoal for xs ys a
     apply (frule set_of_appr_ex_append2[where b=ys])
     apply auto
     subgoal for r
       apply (rule image_eqI[where x="a @ r"])
        apply (auto simp: length_set_of_appr )
       apply (rule eucl_of_list_eqI)
       by (auto dest!: length_set_of_appr)
     done
   done
 
 lemma op_image_fste_impl[autoref_rules]:
   "((\<lambda>(_, x, _). x), op_image_fste) \<in> appr1e_rel \<rightarrow> appr_rel"
   by (auto simp: image_image split_beta' scaleR2_rel_def
       dest!: op_image_fst_flow1[param_fo] brD)
 
 lemma DIM_precond_vec1I[autoref_rules_raw]:
   assumes "DIM_precond TYPE('n::enum rvec) E"
   shows "DIM_precond TYPE('n::enum vec1) (E + E*E)"
   using assms
   by (auto simp: )
 
 lemma vec1rep_impl[autoref_rules]:
   "(\<lambda>(a, bs). RETURN (map_option ((@) a) bs), vec1rep) \<in> appr1_rel \<rightarrow> \<langle>\<langle>appr_rel\<rangle>option_rel\<rangle>nres_rel"
   apply (auto simp: vec1rep_def appr1_rel_def set_rel_br appr_rel_def power2_eq_square nres_rel_def
       dest!: brD
       intro!: RETURN_SPEC_refine)
   subgoal for xs ys a b
     apply (rule exI[where x="Some (eucl_of_list ` set_of_appr (xs @ ys))"])
     apply (auto simp: appr_rell_internal image_image lv_rel_def set_rel_br length_set_of_appr
         intro!: brI dest!: brD)
     done
   done
 
 lemma [autoref_op_pat]: "X \<times> UNIV \<equiv> OP op_times_UNIV $ X" by simp
 
 lemma op_times_UNIV_impl[autoref_rules]: "(\<lambda>x. (x, None), op_times_UNIV) \<in> appr_rel \<rightarrow> appr1_rel"
   by (auto simp: appr1_rel_internal)
 
 schematic_goal solve_poincare_plane_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(ni, n) \<in> lv_rel" and CX[autoref_rules]: "(CXi, CX) \<in> appr1_rel"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   shows "(nres_of (?R), solve_poincare_plane odo n (CX::'n eucl1 set)) \<in> \<langle>appr1_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding solve_poincare_plane_def
   including art
   by autoref_monadic
 concrete_definition solve_poincare_plane_impl for ni CXi uses solve_poincare_plane_impl
 lemmas solve_poincare_plane_impl_refine[autoref_rules] = solve_poincare_plane_impl.refine[autoref_higher_order_rule (1)]
 sublocale autoref_op_pat_def solve_poincare_plane .
 
 lemma [autoref_rules_raw]:
   assumes "DIM_precond TYPE((real, 'n::enum) vec) K"
   shows "DIM_precond TYPE(((real, 'n) vec, 'n) vec) (K * K)"
   using assms by auto
 
 lemma embed1_impl[autoref_rules]:
   assumes "DIM_precond TYPE((real, 'n::enum) vec) E"
   shows "((\<lambda>x. x @ replicate (E * E) 0), embed1::'n rvec\<Rightarrow>_) \<in> lv_rel \<rightarrow> lv_rel"
   using assms
   by (auto simp: lv_rel_def br_def eucl_of_list_prod)
 
 definition "var_ode_ops_impl = (\<lambda>(ode_ops, _, _, vode_slps).
     (var_ode_ops ode_ops, (case vode_slps of None =>
       let _ = print_msg_impl ''ODE solver not properly initialized: vode_slps missing!'' in
       ode_slps_of (approximate_sets_ode'.var_ode_ops ode_ops)
     | Some (vode_slps) => vode_slps), None, None))"
 
 lemma var_ode_ops[autoref_rules]: "(var_ode_ops_impl, var_ode_ops) \<in> ode_ops_rel \<rightarrow> ode_ops_rel"
   by (auto simp: var_ode_ops_impl_def ode_ops_rel_def init_ode_ops_def split: option.splits)
 
 schematic_goal choose_step1_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
     "ncc_precond TYPE('n vec1)"
     "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1_rel" "(hi, h) \<in> rnv_rel"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   notes [autoref_post_simps] = fst_conv
   shows "(nres_of ?f, choose_step1 odo X h) \<in> \<langle>rnv_rel \<times>\<^sub>r appr1_rel \<times>\<^sub>r appr1_rel \<times>\<^sub>r appr1_rel\<rangle>nres_rel"
   unfolding choose_step1_def
   including art
   by autoref_monadic
 concrete_definition choose_step1_impl for Xi hi uses choose_step1_impl
 lemmas [autoref_rules] = choose_step1_impl.refine[autoref_higher_order_rule (1 2 3)]
 sublocale autoref_op_pat_def choose_step1 .
 
 lemma op_image_zerofst_impl[autoref_rules]:
   "(\<lambda>(_, x). (appr_of_ivl ops (replicate E 0) (replicate E 0), x), op_image_zerofst::'n c1_info set \<Rightarrow> _)
     \<in> appr1_rel \<rightarrow> appr1_rel"
   if "DIM_precond (TYPE('n::executable_euclidean_space)) E"
   using that
   apply (auto simp: appr1_rel_br dest!: brD intro!: brI)
   subgoal by (force simp: c1_info_of_appr_def image_image flow1_of_list_def
         set_of_appr_of_ivl_point_append eucl_of_list_prod c1_info_invar_def length_set_of_appr
         split: option.splits elim!: mem_set_of_appr_appendE cong del: image_cong_simp)
   subgoal for a b c d
     apply (auto simp: c1_info_of_appr_def
         split: option.splits)
     subgoal using set_of_appr_nonempty[of a]
       by (force  simp del: set_of_appr_nonempty)
     subgoal
       supply [simp del] = eucl_of_list_take_DIM
       apply (auto simp: image_image set_of_appr_of_ivl_point_append
           flow1_of_list_def)
       apply (frule set_of_appr_ex_append1[where b=a])
       apply auto
       apply (rule image_eqI) prefer 2 apply assumption
       by (auto simp: eucl_of_list_prod c1_info_invar_def
           dest!: length_set_of_appr)
     done
   subgoal
     by (auto simp: c1_info_of_appr_def flow1_of_vec1_def image_image
         set_of_appr_of_ivl_point_append eucl_of_list_prod c1_info_invar_def length_set_of_appr
         split: option.splits elim!: mem_set_of_appr_appendE)
   done
 sublocale autoref_op_pat_def op_image_zerofst .
 
 lemma op_image_zerofst_vec_impl[autoref_rules]:
   "(\<lambda>x. (appr_of_ivl ops (replicate E 0) (replicate E 0) @ drop E x), op_image_zerofst_vec::'n vec1 set \<Rightarrow> _)
     \<in> appr_rel \<rightarrow> appr_rel"
   if "DIM_precond (TYPE('n::enum rvec)) E"
   using that
   apply (auto simp: appr_rel_br set_of_appr_of_ivl_point_append image_image eucl_of_list_prod
       dest!: brD intro!: brI
       dest: drop_set_of_apprD[where n="CARD('n)"] cong del: image_cong_simp)
   subgoal for a b
     apply (drule set_of_appr_dropD)
     apply safe
     apply (rule image_eqI) defer apply assumption
     apply (auto simp: eucl_of_list_prod)
     apply (rule eucl_of_list_eq_takeI)
     apply simp
     done
   done
 sublocale autoref_op_pat_def op_image_zerofst_vec .
 
 lemma [autoref_op_pat_def]: "embed1 ` X \<equiv> OP op_image_embed1 $ X"
   by auto
 
 lemma op_image_embed1_impl[autoref_rules]:
   assumes "DIM_precond TYPE((real, 'n::enum) vec) E"
   shows "(\<lambda>x. x@appr_of_ivl ops (replicate (E*E) 0) (replicate (E*E) 0), op_image_embed1::'n rvec set \<Rightarrow> _)
     \<in> appr_rel \<rightarrow> appr_rel"
   using assms
   by (force simp: appr_rel_br br_def set_of_appr_of_ivl_point_append set_of_appr_of_ivl_append_point
       image_image eucl_of_list_prod length_set_of_appr)
 sublocale autoref_op_pat_def op_image_embed1 .
 
 lemma sv_appr1_rel[relator_props]: "single_valued appr1_rel"
   apply (auto simp:  appr1_rel_internal appr_rel_def intro!: relator_props single_valued_union)
    apply (auto simp: single_valued_def)
    apply (auto simp: lv_rel_def set_rel_br)
    apply (auto simp: br_def)
    apply (rule imageI)
   apply (metis single_valued_def sv_appr_rell)
   by (metis imageI single_valued_def sv_appr_rell)
 
 schematic_goal inter_sctn1_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E" "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(Xi, (X::'n eucl1 set)) \<in> appr1_rel" "(hi, h) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   shows "(nres_of ?f, inter_sctn1_spec X h) \<in> \<langle>appr1_rel \<times>\<^sub>r appr1_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding inter_sctn1_spec_def
   including art
   by autoref_monadic
 concrete_definition inter_sctn1_impl for Xi hi uses inter_sctn1_impl
 lemmas [autoref_rules] = inter_sctn1_impl.refine[autoref_higher_order_rule (1 2)]
 sublocale autoref_op_pat_def inter_sctn1_spec .
 
 schematic_goal op_image_fst_coll_nres_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::executable_euclidean_space) E"
   assumes [autoref_rules]: "(XSi, (XS::'n c1_info set)) \<in> clw_rel appr1_rel"
   shows "(RETURN ?r, op_image_fst_coll_nres XS) \<in> \<langle>clw_rel appr_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding op_image_fst_coll_nres_def
   including art
   by (autoref_monadic (plain))
 concrete_definition op_image_fst_coll_nres_impl for XSi uses op_image_fst_coll_nres_impl
 lemmas [autoref_rules] = op_image_fst_coll_nres_impl.refine[autoref_higher_order_rule (1)]
 sublocale autoref_op_pat_def op_image_fst_coll_nres .
 
 lemma [autoref_op_pat]: "(`) fst \<equiv> OP op_image_fst_coll"
   by auto
 lemma op_image_fst_coll_impl[autoref_rules]:
   assumes "DIM_precond TYPE('n::executable_euclidean_space) E"
   shows "(op_image_fst_coll_nres_impl, op_image_fst_coll::_\<Rightarrow>'n set) \<in> clw_rel appr1_rel \<rightarrow> clw_rel appr_rel"
   apply rule
   subgoal premises prems for x
     using nres_rel_trans2[OF op_image_fst_coll_nres_spec[OF order_refl]
       op_image_fst_coll_nres_impl.refine[OF assms, simplified, OF prems]]
     by (auto simp: nres_rel_def RETURN_RES_refine_iff)
   done
 
 schematic_goal fst_safe_coll_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::executable_euclidean_space) E"
   assumes [autoref_rules]: "(XSi, (XS::'n c1_info set)) \<in> clw_rel appr1_rel"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   shows "(nres_of ?r, fst_safe_coll odo XS) \<in> \<langle>clw_rel appr_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding fst_safe_coll_def
   including art
   by autoref_monadic
 concrete_definition fst_safe_coll_impl for XSi uses fst_safe_coll_impl
 lemmas [autoref_rules] = fst_safe_coll_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def fst_safe_coll_impl .
 
 lemma [autoref_op_pat]: "(`) flow1_of_vec1 \<equiv> OP op_image_flow1_of_vec1_coll"
   by auto
 
 lemma op_image_flow1_of_vec1_coll[autoref_rules]:
   "(map (\<lambda>x. (take E x, Some (drop E x))), op_image_flow1_of_vec1_coll::_\<Rightarrow>'n eucl1 set) \<in> clw_rel appr_rel \<rightarrow> clw_rel appr1_rel"
   if "DIM_precond TYPE('n::enum rvec) E"
   apply (rule lift_clw_rel_map)
      apply (rule relator_props)
   apply (rule relator_props)
   unfolding op_image_flow1_of_vec1_coll_def op_image_flow1_of_vec1_def[symmetric]
   apply (rule op_image_flow1_of_vec1)
   using that
   by auto
 sublocale autoref_op_pat_def op_image_flow1_of_vec1_coll .
 
 schematic_goal vec1reps_impl:
   assumes [autoref_rules]: "(Xi, X) \<in> clw_rel appr1_rel"
   shows "(RETURN ?r, vec1reps X) \<in> \<langle>\<langle>clw_rel appr_rel\<rangle>option_rel\<rangle>nres_rel"
   unfolding vec1reps_def
   including art
   by (autoref_monadic (plain))
 concrete_definition vec1reps_impl for Xi uses vec1reps_impl
 lemma vec1reps_impl_refine[autoref_rules]:
   "(\<lambda>x. RETURN (vec1reps_impl x), vec1reps) \<in> clw_rel appr1_rel \<rightarrow> \<langle>\<langle>clw_rel appr_rel\<rangle>option_rel\<rangle>nres_rel"
   using vec1reps_impl.refine by force
 sublocale autoref_op_pat_def vec1reps .
 
 abbreviation "intersection_STATE_rel \<equiv>
   (appr1_rel \<times>\<^sub>r \<langle>Id\<rangle>phantom_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r
     clw_rel (\<langle>appr_rel, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r bool_rel \<times>\<^sub>r bool_rel)"
 
 lemma print_set_impl1[autoref_rules]:
   shows "(\<lambda>a s. printing_fun optns a (list_of_appr1 s), print_set1) \<in> bool_rel \<rightarrow> A \<rightarrow> Id"
   by auto
 sublocale autoref_op_pat_def print_set1 .
 
 lemma trace_set1_impl1[autoref_rules]:
   shows "(\<lambda>s a. tracing_fun optns s (map_option list_of_appr1 a), trace_set1) \<in> string_rel \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> Id"
   by auto
 sublocale autoref_op_pat_def trace_set1 .
 
 lemma print_set_impl1e[autoref_rules]:
   shows "(\<lambda>a s. printing_fun optns a (list_of_appr1e s), print_set1e) \<in> bool_rel \<rightarrow> A \<rightarrow> Id"
   by auto
 sublocale autoref_op_pat_def print_set1e .
 lemma trace_set1_impl1e[autoref_rules]:
   shows "(\<lambda>s a. tracing_fun optns s (map_option (list_of_appr1e) a), trace_set1e) \<in> string_rel \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> Id"
   by auto
 sublocale autoref_op_pat_def trace_set1e .
 
 schematic_goal split_spec_param1_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::enum rvec) E"
   assumes [autoref_rules]: "(Xi, X) \<in> appr1_rel"
   notes [autoref_post_simps] = case_prod_eta
   shows "(nres_of (?f), split_spec_param1 (X::'a eucl1 set)) \<in> \<langle>appr1_rel \<times>\<^sub>r appr1_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding split_spec_param1_def
   including art
   by autoref_monadic
 concrete_definition split_spec_param1_impl for Xi uses split_spec_param1_impl
 lemmas split_spec_param1_refine[autoref_rules] =
   split_spec_param1_impl.refine[autoref_higher_order_rule (1)]
 sublocale autoref_op_pat_def split_spec_param1 .
 
 lemma [autoref_op_pat del]: "{} \<equiv> OP op_empty_default" "{} \<equiv> OP op_empty_coll"
   and [autoref_op_pat_def del]: "get_inter p \<equiv> OP (get_inter p)"
   by simp_all
 
 lemma fst_image_c1_info_of_appr:
   "c1_info_invar (DIM('a)) X \<Longrightarrow>
     (fst ` c1_info_of_appr X::'a::executable_euclidean_space set) = eucl_of_list ` (set_of_appr (fst X))"
   apply (auto simp: c1_info_invar_def power2_eq_square image_image flow1_of_list_def
       c1_info_of_appr_def flow1_of_vec1_def eucl_of_list_prod split: option.splits)
   subgoal for a b
     by (rule image_eqI[where x="take DIM('a) b"]) (auto intro!: take_set_of_apprI simp: length_set_of_appr)
   subgoal for a b
     apply (frule set_of_appr_ex_append2[where b=a])
     apply auto
     subgoal for r
       by (rule image_eqI[where x="b@r"])
          (auto intro!: eucl_of_list_eqI dest!: length_set_of_appr)
     done
   done
 
 lemma op_image_fst_colle_impl[autoref_rules]:
   "(map (\<lambda>(_, x, _). x), op_image_fst_colle) \<in> clw_rel appr1e_rel \<rightarrow> clw_rel appr_rel"
   apply (rule fun_relI)
   unfolding appr_rel_br
   apply (rule map_mem_clw_rel_br)
   unfolding appr1_rel_br
   unfolding scaleR2_rel_br
   unfolding clw_rel_br
    apply (auto dest!: brD simp: image_Union split_beta')
     apply (drule bspec, assumption)
     apply auto
     apply (drule bspec, assumption)
     apply (auto simp: fst_image_c1_info_of_appr)
    apply (rule bexI) prefer 2 apply assumption
    apply (auto simp: scaleR2_rel_br scaleR2_def image_def c1_info_of_appr_def
       split: option.splits)
   subgoal for a b c d e f g h i
     apply (rule bexI[where x="take DIM('a) i"])
     by (auto intro!: take_set_of_apprI simp: flow1_of_list_def eucl_of_list_prod c1_info_invar_def
         length_set_of_appr)
   subgoal
     by (auto intro!: take_set_of_apprI simp: flow1_of_vec1_def eucl_of_list_prod
         length_set_of_appr c1_info_invar_def)
   done
 sublocale autoref_op_pat_def op_image_fst_colle .
 
 lemma is_empty_appr1_rel[autoref_rules]:
   "(\<lambda>_. False, is_empty) \<in> appr1_rel \<rightarrow> bool_rel"
   by (auto simp: appr1_rel_internal set_rel_br) (auto simp: appr_rel_br br_def)
 sublocale autoref_op_pat_def is_empty .
 
 schematic_goal split_spec_param1e_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::enum rvec) E"
   assumes [autoref_rules]: "(Xi, X) \<in> \<langle>appr1_rel\<rangle>scaleR2_rel"
   notes [autoref_post_simps] = case_prod_eta
   shows "(nres_of (?f), split_spec_param1e (X::'a eucl1 set)) \<in>
     \<langle>\<langle>appr1_rel\<rangle>scaleR2_rel \<times>\<^sub>r \<langle>appr1_rel\<rangle>scaleR2_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding split_spec_param1e_def
   including art
   by autoref_monadic
 concrete_definition split_spec_param1e_impl for Xi uses split_spec_param1e_impl
 lemmas split_spec_param1e_refine[autoref_rules] =
   split_spec_param1e_impl.refine[autoref_higher_order_rule (1)]
 sublocale autoref_op_pat_def split_spec_param1e .
 
 schematic_goal reduce_spec1_impl:
   "(nres_of ?r, reduce_spec1 C X) \<in> \<langle>appr1_rel\<rangle>nres_rel"
   if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
     and [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1_rel" "(Ci, C) \<in> reduce_argument_rel TYPE('b)"
   unfolding reduce_spec1_def
   including art
   by autoref_monadic
 concrete_definition reduce_spec1_impl for Ci Xi uses reduce_spec1_impl
 lemmas reduce_spec1_impl_refine[autoref_rules] = reduce_spec1_impl.refine[autoref_higher_order_rule (1)]
 sublocale autoref_op_pat_def reduce_spec1 .
 
 schematic_goal reduce_spec1e_impl:
   "(nres_of ?r, reduce_spec1e C X) \<in> \<langle>\<langle>appr1_rel\<rangle>scaleR2_rel\<rangle>nres_rel"
   if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
   and [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> \<langle>appr1_rel\<rangle>scaleR2_rel" "(Ci, C) \<in> reduce_argument_rel TYPE('b)"
   unfolding reduce_spec1e_def
   including art
   by autoref_monadic
 concrete_definition reduce_spec1e_impl for Ci Xi uses reduce_spec1e_impl
 lemmas reduce_spec1e_impl_refine[autoref_rules] =
   reduce_spec1e_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def reduce_spec1e .
 
 lemma eq_spec_impl[autoref_rules]:
   "(\<lambda>a b. RETURN (a = b), eq_spec) \<in> A \<rightarrow> A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
   if "PREFER single_valued A"
   using that by (auto simp: nres_rel_def single_valued_def)
 
 schematic_goal select_with_inter_impl:
   assumes [relator_props]: "single_valued A" "single_valued P"
   assumes [autoref_rules]: "(ci, c) \<in> clw_rel (\<langle>A, P\<rangle>inter_rel)" "(ai, a) \<in> clw_rel A"
   shows "(RETURN ?r, select_with_inter $ c $ a) \<in> \<langle>clw_rel (\<langle>A, P\<rangle>inter_rel)\<rangle>nres_rel"
   unfolding select_with_inter_def
   including art
   by (autoref_monadic (plain))
 concrete_definition select_with_inter_impl for ci ai uses select_with_inter_impl
 lemmas [autoref_rules] = select_with_inter_impl.refine[OF PREFER_sv_D PREFER_sv_D]
 sublocale autoref_op_pat_def select_with_inter .
 
 schematic_goal choose_step1e_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
     "ncc_precond TYPE('n vec1)"
     "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1e_rel" "(hi, h) \<in> rnv_rel"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   shows "(nres_of ?r, choose_step1e odo X h) \<in> \<langle>rnv_rel \<times>\<^sub>r appr1_rel \<times>\<^sub>r appr_rel \<times>\<^sub>r appr1e_rel\<rangle>nres_rel"
   unfolding choose_step1e_def
   including art
   by autoref_monadic
 concrete_definition choose_step1e_impl for Xi hi uses choose_step1e_impl
 lemmas [autoref_rules] = choose_step1e_impl.refine[autoref_higher_order_rule (1 2 3)]
 sublocale autoref_op_pat_def choose_step1e .
 
 lemma pre_split_reduce_impl[autoref_rules]:
   "(\<lambda>ro. RETURN (pre_split_reduce ro), pre_split_reduce_spec) \<in> reach_optns_rel \<rightarrow> \<langle>reduce_argument_rel TYPE('b)\<rangle>nres_rel"
   by (auto simp: pre_split_reduce_spec_def nres_rel_def reduce_argument_rel_def RETURN_RES_refine)
 
 schematic_goal step_split_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1e_rel"
     and [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   shows "(nres_of (?f), step_split odo ro X)\<in>\<langle>clw_rel appr1e_rel\<rangle>nres_rel"
   using assms
   unfolding step_split_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition step_split_impl for odoi Xi uses step_split_impl
 lemmas [autoref_rules] = step_split_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def step_split .
 
 schematic_goal width_spec_appr1_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1_rel"
   shows "(?r, width_spec_appr1 X) \<in> \<langle>rnv_rel\<rangle>nres_rel"
   unfolding width_spec_appr1_def
   by autoref_monadic
 concrete_definition width_spec_appr1_impl for Xi uses width_spec_appr1_impl
 lemmas width_spec_appr1_impl_refine[autoref_rules] =
   width_spec_appr1_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def width_spec_appr1 .
 
 schematic_goal split_under_threshold_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
   assumes [autoref_rules]: "(thi, th) \<in> rnv_rel" "(Xi, X) \<in> clw_rel (\<langle>appr1_rel\<rangle>scaleR2_rel)"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   shows "(nres_of ?x, split_under_threshold ro th (X::'n eucl1 set)) \<in> \<langle>clw_rel (\<langle>appr1_rel\<rangle>scaleR2_rel)\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding split_under_threshold_def
   by autoref_monadic
 concrete_definition split_under_threshold_impl for thi Xi uses split_under_threshold_impl
 lemmas [autoref_rules] = split_under_threshold_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def split_under_threshold .
 
 schematic_goal pre_intersection_step_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]:
     "(Xi, X::'n eucl1 set) \<in> appr1e_rel"
     "(hi, (h::real)) \<in> rnv_rel"
     and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
     "(odoi, odo) \<in> ode_ops_rel"
   shows "(nres_of ?r, pre_intersection_step odo roptns X h) \<in>
     \<langle>clw_rel (iinfo_rel appr1e_rel) \<times>\<^sub>r clw_rel appr_rel \<times>\<^sub>r clw_rel (iinfo_rel appr1e_rel)\<rangle>nres_rel"
   unfolding pre_intersection_step_def
   including art
   by autoref_monadic
 concrete_definition pre_intersection_step_impl for roptnsi Xi hi uses pre_intersection_step_impl
 lemmas [autoref_rules] = pre_intersection_step_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def pre_intersection_step .
 
 schematic_goal subset_spec_plane_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a) E"
   assumes [autoref_rules]: "(Xi, X::'a::executable_euclidean_space set) \<in> lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   shows "(nres_of ?R, subset_spec_plane X sctn) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding subset_spec_plane_def
   by autoref_monadic
 concrete_definition subset_spec_plane_impl for Xi sctni uses subset_spec_plane_impl
 lemmas [autoref_rules] = subset_spec_plane_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def subset_spec_plane .
 
 schematic_goal op_eventually_within_sctn_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
   assumes [autoref_rules]: "(Xi, X::'a set) \<in> appr_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel" "(Si, S) \<in> lvivl_rel"
   shows "(nres_of ?R, op_eventually_within_sctn X sctn S) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding op_eventually_within_sctn_def
   including art
   by autoref_monadic
 concrete_definition op_eventually_within_sctn_impl for Xi sctni Si uses op_eventually_within_sctn_impl
 lemmas [autoref_rules] = op_eventually_within_sctn_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def op_eventually_within_sctn .
 
 schematic_goal nonzero_component_within_impl:
   "(nres_of ?r, nonzero_component_within odo ivl sctn (PDP::'n eucl1 set)) \<in> \<langle>bool_rel\<rangle>nres_rel"
   if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
   and [autoref_rules]:
     "(ivli, ivl) \<in> lvivl_rel"
     "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     "(PDPi, PDP) \<in> appr1_rel"
     "(odoi, odo) \<in> ode_ops_rel"
   unfolding nonzero_component_within_def
   including art
   by autoref_monadic
 concrete_definition nonzero_component_within_impl uses nonzero_component_within_impl
 lemmas [autoref_rules] = nonzero_component_within_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def nonzero_component_within .
 
 schematic_goal disjoints_spec_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(Xi, (X::'n::enum rvec set)) \<in> clw_rel appr_rel" "(Yi, (Y::'n rvec set)) \<in> clw_rel lvivl_rel"
   shows "(nres_of ?f, disjoints_spec X Y) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding disjoints_spec_def op_coll_is_empty_def[symmetric]
   including art
   by autoref_monadic
 concrete_definition disjoints_spec_impl for Xi Yi uses disjoints_spec_impl
 lemmas [autoref_rules] = disjoints_spec_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def disjoints_spec .
 
 schematic_goal do_intersection_body_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(hi, h) \<in> rnv_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel lvivl_rel"
     and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
     and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   and [autoref_rules]: "(STATEi, STATE) \<in> intersection_STATE_rel"
   notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl]
   shows "(nres_of ?f, do_intersection_body odo guards ivl sctn h STATE) \<in> \<langle>intersection_STATE_rel\<rangle>nres_rel"
   unfolding do_intersection_body_def
   by autoref_monadic
 concrete_definition do_intersection_body_impl for odoi guardsi ivli sctni hi STATEi uses do_intersection_body_impl
 lemmas do_intersection_body_impl_refine[autoref_rules] =
   do_intersection_body_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def do_intersection_body .
 
 schematic_goal do_intersection_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(Xi, X) \<in> appr1_rel" "(hi, h) \<in> rnv_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (\<langle>lvivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel)"
     and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
     and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl]
   shows "(nres_of ?f, do_intersection odo guards ivl sctn (X::'n eucl1 set) h)\<in>
     \<langle>bool_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r
       clw_rel (\<langle>appr_rel, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel)\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding do_intersection_def
   including art
   by autoref_monadic
 concrete_definition do_intersection_impl for odoi guardsi ivli sctni Xi hi uses do_intersection_impl
 lemmas do_intersection_impl_refine[autoref_rules] =
   do_intersection_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def do_intersection .
 
 schematic_goal tolerate_error1_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) dd"
   assumes [autoref_rules]: "(Yi, Y::'n eucl1 set) \<in> appr1e_rel"
   assumes [autoref_rules]: "(Ei, E) \<in> appr1_rel"
   shows "(nres_of ?r, tolerate_error1 Y E) \<in> \<langle>bool_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
   unfolding tolerate_error1_def
   including art
   by autoref_monadic
 concrete_definition tolerate_error1_impl for dd Yi Ei uses tolerate_error1_impl
 lemmas tolerate_error1_refine[autoref_rules] = tolerate_error1_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def tolerate_error1 .
 
 lemma lower_impl[autoref_rules]: "(lower, lower) \<in> Id \<rightarrow> Id"
   and upper_impl[autoref_rules]: "(lower, lower) \<in> Id \<rightarrow> Id"
   by auto
 
 schematic_goal step_adapt_time_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(hi, h) \<in> rnv_rel"
     "(Xi, X::'n eucl1 set) \<in> (appr1e_rel)"
   shows "(nres_of ?f, step_adapt_time odo X h)\<in>\<langle>rnv_rel \<times>\<^sub>r appr_rel \<times>\<^sub>r appr1e_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
   unfolding step_adapt_time_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition step_adapt_time_impl for Xi hi uses step_adapt_time_impl
 lemmas [autoref_rules] = step_adapt_time_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def step_adapt_time .
 
 
 schematic_goal resolve_step_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(hi, h) \<in> rnv_rel"
     "(Xi, X::'n eucl1 set) \<in> (appr1e_rel)"
     "(roptnsi, roptns) \<in> reach_optns_rel"
   shows "(nres_of ?f, resolve_step odo roptns X h)\<in>\<langle>rnv_rel \<times>\<^sub>r clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
   unfolding resolve_step_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition resolve_step_impl for roptnsi Xi hi uses resolve_step_impl
 lemmas [autoref_rules] = resolve_step_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def resolve_step .
 
 sublocale autoref_op_pat_def fst_safe_coll .
 
 schematic_goal reach_cont_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(XSi, XS) \<in> clw_rel appr1e_rel"
     "(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
     and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
   notes [relator_props, autoref_rules_raw] = sv_appr1_rel
   shows "(nres_of (?f::?'f dres), reach_cont odo roptns guards XS)\<in>?R"
   unfolding autoref_tag_defs
   unfolding reach_cont_def
   including art
   by autoref_monadic
 concrete_definition reach_cont_impl for guardsi XSi uses reach_cont_impl
 lemmas reach_cont_ho[autoref_rules] = reach_cont_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def reach_cont .
 
 schematic_goal reach_cont_par_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(XSi, XS) \<in> clw_rel appr1e_rel"
     "(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
     and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
   shows "(nres_of (?f::?'f dres), reach_cont_par odo roptns guards XS)\<in>?R"
   unfolding autoref_tag_defs
   unfolding reach_cont_par_def
   including art
   by autoref_monadic
 concrete_definition reach_cont_par_impl for roptnsi guardsi XSi uses reach_cont_par_impl
 lemmas reach_cont_par_impl_refine[autoref_rules] = reach_cont_par_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def reach_cont_par .
 
 schematic_goal subset_iplane_coll_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
   assumes [autoref_rules]: "(xi, x::'a set) \<in> iplane_rel lvivl_rel"
   assumes [autoref_rules]: "(icsi, ics) \<in> clw_rel (iplane_rel lvivl_rel)"
   shows "(nres_of ?r, subset_iplane_coll x ics) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding subset_iplane_coll_def
   including art
   by autoref_monadic
 concrete_definition subset_iplane_coll_impl uses subset_iplane_coll_impl
 lemmas subset_iplane_coll_impl_refine[autoref_rules] = subset_iplane_coll_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def subset_iplane_coll .
 
 
 schematic_goal subsets_iplane_coll_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
   assumes [autoref_rules]: "(xi, x::'a set set) \<in> \<langle>iplane_rel lvivl_rel\<rangle>list_wset_rel"
   assumes [autoref_rules]: "(icsi, ics) \<in> clw_rel (iplane_rel lvivl_rel)"
   shows "(nres_of ?r, subsets_iplane_coll x ics) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding subsets_iplane_coll_def
   including art
   by autoref_monadic
 concrete_definition subsets_iplane_coll_impl uses subsets_iplane_coll_impl
 lemmas [autoref_rules] = subsets_iplane_coll_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def subsets_iplane_coll .
 
 
 schematic_goal symstart_coll_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
   shows "(nres_of ?r, symstart_coll $ odo $ symstart $ XS) \<in> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding symstart_coll_def
   including art
   by autoref_monadic
 concrete_definition symstart_coll_impl for symstartd XSi uses symstart_coll_impl
 lemmas [autoref_rules] = symstart_coll_impl.refine
 sublocale autoref_op_pat_def symstart_coll .
 
 schematic_goal reach_cont_symstart_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
     "(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
     "(roptnsi, roptns) \<in> reach_optns_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
   shows "(nres_of (?r), reach_cont_symstart $ odo $ roptns $ symstart $ guards $ XS) \<in>
   \<langle>clw_rel appr_rel \<times>\<^sub>r
     clw_rel (\<langle>iplane_rel lvivl_rel::(_ \<times> 'n rvec set)set, iinfo_rel appr1e_rel\<rangle>info_rel)\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding reach_cont_symstart_def Let_def
   including art
   by autoref_monadic
 concrete_definition reach_cont_symstart_impl for roptnsi symstartd XSi uses reach_cont_symstart_impl
 lemmas [autoref_rules] = reach_cont_symstart_impl.refine
 sublocale autoref_op_pat_def reach_cont_symstart .
 
 lemma sv_reach_conts_impl_aux:
   "single_valued (clw_rel (iinfo_rel appr1e_rel))" by (auto intro!: relator_props)
 
 schematic_goal reach_conts_impl:
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(XSi, XS) \<in> clw_rel appr1e_rel"
     "(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
     and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
   notes [simp] = list_wset_rel_finite[OF sv_reach_conts_impl_aux]
     assumes "(trapi, trap) \<in> ghost_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
   shows "(nres_of (?f::?'f dres), reach_conts $ odo $ roptns $ symstart $ trap $ guards $ XS)\<in>?R"
   unfolding autoref_tag_defs
   unfolding reach_conts_def
   including art
   by autoref_monadic
 concrete_definition reach_conts_impl for odoi guardsi XSi uses reach_conts_impl
 lemmas [autoref_rules] = reach_conts_impl.refine
 sublocale autoref_op_pat_def reach_conts .
 
 lemma get_sctns_autoref[autoref_rules]:
   "(\<lambda>x. RETURN x, get_sctns) \<in> \<langle>R\<rangle>halfspaces_rel \<rightarrow> \<langle>\<langle>\<langle>R\<rangle>sctn_rel\<rangle>list_set_rel\<rangle>nres_rel"
   by (auto simp: get_sctns_def nres_rel_def halfspaces_rel_def br_def intro!: RETURN_SPEC_refine)
 sublocale autoref_op_pat_def get_sctns .
 
 schematic_goal leaves_halfspace_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes nccp[autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   notes [simp] = ncc_precondD[OF nccp]
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(Si, S) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
   assumes [autoref_rules]: "(Xi, X::'n rvec set) \<in> clw_rel appr_rel"
   shows "(nres_of ?r, leaves_halfspace $ odo $ S $ X) \<in> \<langle>\<langle>\<langle>lv_rel\<rangle>sctn_rel\<rangle>option_rel\<rangle>nres_rel"
   unfolding leaves_halfspace_def
   including art
   by autoref_monadic
 concrete_definition leaves_halfspace_impl for Si Xi uses leaves_halfspace_impl
 lemmas [autoref_rules] = leaves_halfspace_impl.refine
 sublocale autoref_op_pat_def leaves_halfspace .
 
 schematic_goal poincare_start_on_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes ncc2[autoref_rules_raw]: "ncc_precond TYPE('n::enum rvec)"
   assumes ncc2[autoref_rules_raw]: "ncc_precond TYPE('n::enum vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]:
     "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     "(guardsi, guards) \<in> clw_rel lvivl_rel"
     "(X0i, X0::'n eucl1 set) \<in> clw_rel (appr1e_rel)"
   shows "(nres_of (?f), poincare_start_on $ odo $ guards $ sctn $ X0) \<in>
       \<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_start_on_def
   including art
   by autoref_monadic
 concrete_definition poincare_start_on_impl for guardsi sctni X0i uses poincare_start_on_impl
 lemmas [autoref_rules] = poincare_start_on_impl.refine
 sublocale autoref_op_pat_def poincare_start_on .
 
 lemma isets_of_iivls[autoref_rules]:
   assumes "PREFER single_valued A"
   assumes le[THEN GEN_OP_D, param_fo]: "GEN_OP le (\<le>) ((lv_rel::(_ \<times> 'a::executable_euclidean_space)set) \<rightarrow> lv_rel \<rightarrow> bool_rel)"
   shows "(\<lambda>xs. map (\<lambda>((i, s), x). (appr_of_ivl ops i s, x)) [((i,s), x) \<leftarrow> xs. le i s], isets_of_iivls::_\<Rightarrow>'a set)
     \<in> clw_rel (\<langle>lvivl_rel, A\<rangle>inter_rel) \<rightarrow> clw_rel (\<langle>appr_rel, A\<rangle>inter_rel)"
   apply (rule fun_relI)
   using assms
   apply (auto elim!: single_valued_as_brE)
   unfolding appr_rel_br ivl_rel_br clw_rel_br lvivl_rel_br inter_rel_br
   apply (auto simp: br_def set_of_ivl_def)
   subgoal for a b c d e f g
     apply (rule exI[where x=e])
     apply (rule exI[where x=f])
     apply (rule exI[where x=g])
     apply (rule conjI)
     apply (assumption)
     apply (rule conjI)
     subgoal
       using transfer_operations1[where 'a='a, of "eucl_of_list e" "eucl_of_list f" e f]
         le[of e _ f _, OF lv_relI lv_relI]
       by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def)
     subgoal
       apply (drule bspec, assumption)
       using transfer_operations1[where 'a='a, of "eucl_of_list e" "eucl_of_list f" e f]
         le[of e _ f _, OF lv_relI lv_relI]
       apply (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def)
       using atLeastAtMost_iff apply blast
-      apply (drule order_trans)
-       apply assumption apply simp
       done
     done
   subgoal for a b c d e f g
     apply (drule bspec, assumption)
     using transfer_operations1[where 'a='a, of "eucl_of_list d" "eucl_of_list e" d e]
       le[of d _ e _, OF lv_relI lv_relI]
     by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def intro!: bexI)
   subgoal for a b c d e f
     apply (drule bspec, assumption)
     using transfer_operations1[where 'a='a, of "eucl_of_list d" "eucl_of_list e" d e]
       le[of d _ e _, OF lv_relI lv_relI]
     by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def intro!: bexI)
   done
 sublocale autoref_op_pat_def isets_of_iivls .
 
 lemma [autoref_op_pat]: "X \<times> UNIV \<equiv> OP op_times_UNIV_coll $ X" by simp
 
 lemma op_times_UNIV_coll_impl[autoref_rules]: "(map (\<lambda>x. (x, None)), op_times_UNIV_coll) \<in> clw_rel appr_rel \<rightarrow> clw_rel appr1_rel"
   apply (rule lift_clw_rel_map)
      apply (rule relator_props)
     apply (rule relator_props)
   unfolding op_times_UNIV_coll_def op_times_UNIV_def[symmetric]
    apply (rule op_times_UNIV_impl)
   by auto
 sublocale autoref_op_pat_def op_times_UNIV_coll .
 
 schematic_goal do_intersection_core_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> iinfo_rel appr1e_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
     and csctns[autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     and csctns[autoref_rules]: "(ivli, ivl) \<in> lvivl_rel"
   notes [simp] = list_set_rel_finiteD
   shows "(nres_of ?f, do_intersection_core odo guards ivl sctn X) \<in>
       \<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding do_intersection_core_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition do_intersection_core_impl for guardsi ivli sctni Xi uses do_intersection_core_impl
 sublocale autoref_op_pat_def do_intersection_core .
 
 lemmas do_intersection_core_impl_refine[autoref_rules] =
   do_intersection_core_impl.refine[autoref_higher_order_rule(1 2 3)]
 
 lemma finite_ra1eicacacslsbicae1lw: "(xc, x'c) \<in> \<langle>\<langle>rnv_rel, appr1e_rel\<rangle>info_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel
            (\<langle>appr_rel,
             \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r
           clw_rel appr1e_rel\<rangle>list_wset_rel \<Longrightarrow> finite x'c"
   for x'c::"('n::enum eucl1 set * 'n eucl1 set * 'n eucl1 set * 'n rvec set * 'n eucl1 set) set"
   apply (rule list_wset_rel_finite)
   by (auto intro!: relator_props)
 
 schematic_goal do_intersection_coll_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> clw_rel (iinfo_rel appr1e_rel)"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
     and csctns[autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     and csctns[autoref_rules]: "(ivli, ivl) \<in> lvivl_rel"
   notes [simp] = finite_ra1eicacacslsbicae1lw[where 'n='n]
   shows "(nres_of ?f, do_intersection_coll odo guards ivl sctn X) \<in>
       \<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding do_intersection_coll_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition do_intersection_coll_impl for guardsi ivli sctni Xi uses do_intersection_coll_impl
 lemmas [autoref_rules] = do_intersection_coll_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def do_intersection_coll .
 
 schematic_goal op_enlarge_ivl_sctn_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
   assumes [autoref_rules]: "(ivli, ivl::'a set) \<in> lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel" "(di, d) \<in> rnv_rel"
   shows "(nres_of ?R, op_enlarge_ivl_sctn $ ivl $ sctn $ d) \<in> \<langle>lvivl_rel\<rangle>nres_rel"
   unfolding op_enlarge_ivl_sctn_def
   including art
   by autoref_monadic
 concrete_definition op_enlarge_ivl_sctn_impl for ivli sctni di uses op_enlarge_ivl_sctn_impl
 lemmas [autoref_rules] = op_enlarge_ivl_sctn_impl.refine
 sublocale autoref_op_pat_def op_enlarge_ivl_sctn .
 
 schematic_goal resolve_ivlplanes_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS::('n rvec set \<times> 'n eucl1 set) set) \<in> \<langle>iplane_rel lvivl_rel \<times>\<^sub>r clw_rel (iinfo_rel appr1e_rel)\<rangle>list_wset_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
     and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
   notes [intro, simp] = list_set_rel_finiteD
   shows "(nres_of ?r, resolve_ivlplanes odo guards ivlplanes XS) \<in>
     \<langle>\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r clw_rel (isbelows_rel appr_rel)\<rangle>list_wset_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding resolve_ivlplanes_def
   including art
   by autoref_monadic
 concrete_definition resolve_ivlplanes_impl for guardsi ivlplanesi XSi uses resolve_ivlplanes_impl
 lemmas [autoref_rules] = resolve_ivlplanes_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def resolve_ivlplanes .
 
 schematic_goal poincare_onto_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
   assumes [autoref_rules]: "(CXSi, CXS::'n rvec set) \<in> clw_rel appr_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
     and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   assumes [autoref_rules]: "((), trap) \<in> ghost_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
   notes [intro, simp] = list_set_rel_finiteD
   shows "(nres_of ?r, poincare_onto $ odo $ ro $ symstart $ trap $ guards $ ivlplanes $ XS $ CXS) \<in>
     \<langle>\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel
       \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto_def
   including art
   by autoref_monadic
 concrete_definition poincare_onto_impl for odoi roi symstarti guardsi ivlplanesi XSi uses poincare_onto_impl
 lemmas [autoref_rules] = poincare_onto_impl.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def poincare_onto .
 
 schematic_goal empty_remainders_impl:
   assumes [autoref_rules]:
     "(PSi, PS) \<in> \<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel
             \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel"
   shows "(nres_of ?r, empty_remainders PS) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding empty_remainders_def
   including art
   by autoref_monadic
 concrete_definition empty_remainders_impl uses empty_remainders_impl
 
 lemmas empty_remainders_impl_refine[autoref_rules] = empty_remainders_impl.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def empty_remainders .
 
 lemma empty_trap_impl[autoref_rules]: "((), empty_trap) \<in> ghost_rel"
   by (auto intro!: ghost_relI)
 sublocale autoref_op_pat_def empty_trap .
 
 lemma empty_symstart_impl:\<comment> \<open>why this? \<close>
   "((\<lambda>x. nres_of (dRETURN ([], [x]))), empty_symstart) \<in>
     appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding empty_symstart_def
   using mk_coll[unfolded autoref_tag_defs, OF sv_appr1e_rel[OF sv_appr1_rel], param_fo]
   by (auto intro!: nres_relI simp:)
 lemma empty_symstart_nres_rel[autoref_rules]:
   "((\<lambda>x. RETURN ([], [x])), empty_symstart::'n::enum eucl1 set\<Rightarrow>_) \<in>
     appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   using mk_coll[OF PREFER_I[of single_valued, OF sv_appr1e_rel[OF sv_appr1_rel]], param_fo, of x y for x and y::"'n eucl1 set"]
   by (auto simp: mk_coll_def[abs_def] nres_rel_def)
 sublocale autoref_op_pat_def empty_symstart .
 lemma empty_symstart_dres_nres_rel:
   "((\<lambda>x. dRETURN ([], [x])), empty_symstart::'n::enum eucl1 set\<Rightarrow>_) \<in>
     (appr1e_rel) \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>dres_nres_rel"
   using mk_coll[OF PREFER_I[of single_valued, OF sv_appr1e_rel[OF sv_appr1_rel]], param_fo, of x y for x and y::"'n eucl1 set"]
   by (auto simp: mk_coll_def[abs_def] dres_nres_rel_def)
 
 
 schematic_goal poincare_onto_empty_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
   assumes [autoref_rules]: "(CXSi, CXS::'n rvec set) \<in> clw_rel appr_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
     and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   notes [intro, simp] = list_set_rel_finiteD
   shows "(nres_of (?r), poincare_onto_empty odo ro guards ivlplanes XS CXS) \<in>
     \<langle>\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel
       \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto_empty_def
   including art
   apply (rule autoref_monadicI)
    apply (autoref phases: id_op rel_inf fix_rel)\<comment> \<open>TODO: what is going wrong here?\<close>
   apply (simp only: autoref_tag_defs)
    apply (rule poincare_onto_impl.refine[unfolded autoref_tag_defs])
             apply fact+
      apply (rule ghost_relI)
     apply (rule empty_symstart_impl)
    apply refine_transfer
   apply refine_transfer
   done
 
 concrete_definition poincare_onto_empty_impl for guardsi XSi CXSi uses poincare_onto_empty_impl
 lemmas [autoref_rules] = poincare_onto_empty_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def poincare_onto_empty .
 
 lemma sv_thingy: "single_valued (clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           \<langle>lv_rel\<rangle>ivl_rel \<times>\<^sub>r
           \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
           clw_rel
            (\<langle>appr_rel,
             \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r
           clw_rel appr_rel)"
   by (intro relator_props)
 
 schematic_goal poincare_onto2_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
   assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
     and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   assumes [autoref_rules]: "((), trap) \<in> ghost_rel"
   notes [intro, simp] = list_set_rel_finiteD list_wset_rel_finite[OF sv_thingy]
   shows "(nres_of (?r), poincare_onto2 $ odo $ ro $ symstart $ trap $ guards $ ivlplanes $ XS) \<in>
     \<langle>\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
       clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto2_def
     including art
   by autoref_monadic
 concrete_definition poincare_onto2_impl for odoi guardsi XSi uses poincare_onto2_impl
 lemmas [autoref_rules] = poincare_onto2_impl.refine
 sublocale autoref_op_pat_def poincare_onto2 .
 
 schematic_goal width_spec_ivl_impl:
   assumes [autoref_rules]: "(Mi, M) \<in> nat_rel" "(xi, x) \<in> lvivl_rel"
   shows "(RETURN ?r, width_spec_ivl M x) \<in> \<langle>rnv_rel\<rangle>nres_rel"
   unfolding width_spec_ivl_def
   including art
   by (autoref_monadic (plain))
 concrete_definition width_spec_ivl_impl for Mi xi uses width_spec_ivl_impl
 
 lemmas width_spec_ivl_impl_refine[autoref_rules]
   = width_spec_ivl_impl.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def width_spec_ivl .
 
 schematic_goal partition_ivl_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
   assumes [autoref_rules]: "(xsi, xs::'a set)\<in> clw_rel lvivl_rel" "(roi, ro) \<in> reach_optns_rel"
   shows "(nres_of (?f), partition_ivl ro xs)\<in>\<langle>clw_rel lvivl_rel\<rangle>nres_rel"
   unfolding partition_ivl_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition partition_ivl_impl for roi xsi uses partition_ivl_impl
 lemmas [autoref_rules] = partition_ivl_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def partition_ivl .
 
 schematic_goal vec1repse_impl:
   assumes [autoref_rules]: "(Xi, X) \<in> clw_rel appr1e_rel"
   shows "(nres_of ?r, vec1repse X) \<in> \<langle>\<langle>clw_rel appre_rel\<rangle>option_rel\<rangle>nres_rel"
   unfolding vec1repse_def
   including art
   by autoref_monadic
 concrete_definition vec1repse_impl for Xi uses vec1repse_impl
 lemmas vec1repse_impl_refine[autoref_rules] = vec1repse_impl.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def vec1repse .
 
 schematic_goal scaleR2_rep1_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(Yi, Y::'n vec1 set) \<in> appre_rel"
   shows "(nres_of ?r, scaleR2_rep1 Y) \<in> \<langle>elvivl_rel\<rangle>nres_rel"
   unfolding scaleR2_rep1_def
   including art
   by autoref_monadic
 concrete_definition scaleR2_rep1_impl uses scaleR2_rep1_impl
 lemmas [autoref_rules] = scaleR2_rep1_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def scaleR2_rep1 .
 
 schematic_goal ivlse_of_setse_impl:
   "(nres_of ?r, ivlse_of_setse X) \<in> \<langle>clw_rel elvivl_rel\<rangle>nres_rel"
   if [autoref_rules_raw]:"DIM_precond TYPE('n::enum rvec) E"
     and [autoref_rules]: "(Xi, X::'n vec1 set) \<in> clw_rel (appre_rel)"
   unfolding ivlse_of_setse_def
   including art
   by autoref_monadic
 concrete_definition ivlse_of_setse_impl uses ivlse_of_setse_impl
 lemmas [autoref_rules] = ivlse_of_setse_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def ivlse_of_setse .
 
 schematic_goal setse_of_ivlse_impl:
   "(nres_of ?r, setse_of_ivlse X) \<in> \<langle>clw_rel (appre_rel)\<rangle>nres_rel"
   if [autoref_rules]: "(Xi, X) \<in> clw_rel elvivl_rel"
   unfolding setse_of_ivlse_def
   including art
   by autoref_monadic
 concrete_definition setse_of_ivlse_impl uses setse_of_ivlse_impl
 lemmas setse_of_ivlse_impl_refine[autoref_rules] =
   setse_of_ivlse_impl.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def setse_of_ivlse .
 
 lemma op_image_flow1_of_vec1_colle[autoref_rules]:
   "(map (\<lambda>(lu, x). (lu, (take E x, Some (drop E x)))), op_image_flow1_of_vec1_colle::_\<Rightarrow>'n eucl1 set) \<in> clw_rel appre_rel \<rightarrow> clw_rel appr1e_rel"
   if "DIM_precond TYPE('n::enum rvec) E"
   apply (rule lift_clw_rel_map)
      apply (rule relator_props)
      apply (rule relator_props)
     apply (rule relator_props)
     apply (rule relator_props)
     apply (rule lift_scaleR2)
   unfolding op_image_flow1_of_vec1_colle_def op_image_flow1_of_vec1_coll_def op_image_flow1_of_vec1_def[symmetric]
     apply (rule op_image_flow1_of_vec1)
   using that
   subgoal by force
   subgoal for l u x
     unfolding op_image_flow1_of_vec1_def flow1_of_vec1_def scaleR2_def
     apply (auto simp: image_def vimage_def)
     subgoal for a b c d e
       apply (rule exI[where x="c *\<^sub>R e"])
       apply (auto simp: blinfun_of_vmatrix_scaleR)
       apply (rule exI[where x="c"])
       apply auto
       apply (rule bexI) prefer 2 apply assumption
       apply auto
       done
     subgoal for a b c d e
       apply (rule exI[where x="c"])
       apply (auto simp: blinfun_of_vmatrix_scaleR)
       apply (rule exI[where x="blinfun_of_vmatrix e"])
       apply auto
       apply (rule bexI) prefer 2 apply assumption
       apply auto
       done
     done
   subgoal by auto
   done
 sublocale autoref_op_pat_def op_image_flow1_of_vec1_colle .
 
 schematic_goal okay_granularity_impl:
   assumes [autoref_rules]: "(ivli,ivl::'n::enum vec1 set)\<in> lvivl_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   shows "(nres_of ?f, okay_granularity ro ivl) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding okay_granularity_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition okay_granularity_impl for roi ivli uses okay_granularity_impl
 lemmas [autoref_rules] = okay_granularity_impl.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def okay_granularity .
 
 lemma le_post_inter_granularity_op[autoref_rules]:
   "(\<lambda>roi (ls, us). RETURN (width_appr ops optns (appr_of_ivl ops ls us) \<le> post_inter_granularity roi),
     (le_post_inter_granularity_op::_\<Rightarrow>'a::executable_euclidean_space set\<Rightarrow>_)) \<in>
     (reach_optns_rel \<rightarrow> lvivl_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel)"
   by (auto simp: nres_rel_def le_post_inter_granularity_op_def)
 sublocale autoref_op_pat_def le_post_inter_granularity_op .
 
 schematic_goal partition_set_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(xsi,xs::'n eucl1 set)\<in> clw_rel appr1e_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   shows "(nres_of (?f), partition_set ro xs) \<in> \<langle>clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding partition_set_def
   including art
   by autoref_monadic
 
 concrete_definition partition_set_impl for roi xsi uses partition_set_impl
 lemmas [autoref_rules] = partition_set_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def partition_set .
 
 schematic_goal partition_sets_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(xsi,xs::(bool \<times> 'n eucl1 set \<times> _)set)\<in>
     \<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel
               \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
       clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   shows "(nres_of (?f), partition_sets ro xs)\<in>\<langle>clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding partition_sets_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition partition_sets_impl for roi xsi uses partition_sets_impl
 lemmas [autoref_rules] = partition_sets_impl.refine[autoref_higher_order_rule(1)]
 sublocale autoref_op_pat_def partition_sets .
 
 lemma [autoref_rules]:
   assumes "PREFER single_valued A"
   shows "(\<lambda>xs. case xs of [x] \<Rightarrow> RETURN x | _ \<Rightarrow> SUCCEED, singleton_spec) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>A\<rangle>nres_rel"
   using assms
   by (auto simp: nres_rel_def singleton_spec_def list_wset_rel_def set_rel_br
       split: list.splits elim!: single_valued_as_brE dest!: brD
       intro!: RETURN_SPEC_refine brI)
 sublocale autoref_op_pat_def singleton_spec .
 
 lemma closed_ivl_prod8_list_rel:
   assumes "(xl, x'l)
        \<in> \<langle>bool_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           clw_rel appr1e_rel \<times>\<^sub>r
           \<langle>lv_rel\<rangle>ivl_rel \<times>\<^sub>r
           \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r clw_rel (\<langle>appr_rel, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel"
   shows "(\<forall>(b, X, PS1, PS2, R, ivl, sctn, CX, CXS)\<in>x'l. closed ivl)"
   using assms
   unfolding list_wset_rel_def set_rel_sv[OF single_valued_Id_arbitrary_interface]
   apply (subst (asm) set_rel_sv)
   subgoal
     by (auto simp: Id_arbitrary_interface_def intro!: relator_props intro: single_valuedI)
   by (auto simp: Id_arbitrary_interface_def)
 
 lemma
   poincare_onto_series_rec_list_eq:\<comment> \<open>TODO: here is a problem if interrupt gets uncurried, too\<close>
   "poincare_onto_series odo interrupt trap guards XS ivl sctn ro = rec_list
       (\<lambda>(((((trap), XS0), ivl), sctn), ro).
           let guard0 = mk_coll (mk_inter ivl (plane_of sctn))
           in ASSUME (closed guard0) \<bind>
              (\<lambda>_. (poincare_onto2 odo (ro ::: reach_optns_rel) (interrupt:::appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel) trap
                     (op_empty_coll ::: clw_rel (\<langle>\<langle>lv_rel\<rangle>ivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel)) guard0 XS0 :::
                    \<langle>\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
       clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel) \<bind>
                   (\<lambda>(XS1).
                       singleton_spec XS1 \<bind>
                       (\<lambda>(b, X, PS1, PS2, R, ivl', sctn', CX, CXS). CHECKs ''poincare_onto_series: last return!'' (ivl' = ivl \<and> sctn' = sctn) \<bind> (\<lambda>_. RETURN PS2)))))
       (\<lambda>x xs rr (((((trap), XS0), ivl), sctn), ro0).
           case x of
           (guard, ro) \<Rightarrow>
             ASSUME (closed ivl) \<bind> 
             (\<lambda>_. let guard0 = mk_coll (mk_inter ivl (plane_of sctn))
                  in ASSUME (closed guard0) \<bind>
                  (\<lambda>_. ASSUME (\<forall>(guard, ro)\<in>set (x # xs). closed guard) \<bind>
                       (\<lambda>_. let guardset = \<Union>(guard, ro)\<in>set ((guard0, ro0) # xs). guard
                            in (poincare_onto2 odo ro (interrupt:::appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel) trap (guardset ::: clw_rel (\<langle>\<langle>lv_rel\<rangle>ivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel))
                                 guard XS0 :::
                                \<langle>\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
       clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel) \<bind>
                               (\<lambda>(XS1).
                                   ASSUME (\<forall>(b, X, PS, PS2, R, ivl, sctn, CX, CXS)\<in>XS1. closed ivl) \<bind>
                                   (\<lambda>_.
                                     partition_sets ro XS1 \<bind>
                                     (\<lambda>XS2. fst_safe_colle odo XS2 \<bind> (\<lambda>_. rr (((((trap), XS2), ivl), sctn), ro0 ::: reach_optns_rel) \<bind> RETURN))))))))
       guards (((((trap), XS), ivl), sctn), ro)"
   by (induction guards arbitrary: XS ivl sctn ro) (auto simp: split_beta' split: prod.splits)
 
 schematic_goal poincare_onto_series_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel" "(ivli, ivl) \<in> lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
     and [autoref_rules]: "((), trap) \<in> ghost_rel"
   notes [intro, simp] = list_set_rel_finiteD closed_ivl_prod3_list_rel closed_clw_rel_iplane_rel
     closed_ivl_prod8_list_rel
   notes [autoref_rules_raw] = ghost_relI[of x for x::"'n eucl1 set"]
   shows "(nres_of ?r, poincare_onto_series $ odo $ symstart $ trap $ guards $ XS $ ivl $ sctn $ ro) \<in> \<langle>clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto_series_rec_list_eq
   including art
   apply autoref_monadic
   apply (rule ghost_relI)
   apply (autoref phases: trans)
   apply (autoref phases: trans)
   apply (rule ghost_relI)
   apply (autoref phases: trans)
   apply (autoref phases: trans)
   apply simp
   apply (autoref phases: trans)
     apply (autoref phases: trans)
    apply simp
   apply (refine_transfer)
   done
 
 concrete_definition poincare_onto_series_impl for symstartd guardsi XSi ivli sctni roi uses poincare_onto_series_impl
 lemmas [autoref_rules] = poincare_onto_series_impl.refine
 sublocale autoref_op_pat_def poincare_onto_series .
 
 schematic_goal poincare_onto_from_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel appr1e_rel"
     and [autoref_rules]: "(Si, S) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
     and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
     and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
     and [autoref_rules]: "((), trap) \<in> ghost_rel"
   notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl] closed_ivl_prod3_list_rel
   shows "(nres_of ?r, poincare_onto_from $ odo $ symstart $ trap $ S $ guards $ ivl $ sctn $ ro $ XS) \<in>
     \<langle>clw_rel appr1e_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto_from_def
   including art
   by autoref_monadic
 
 concrete_definition poincare_onto_from_impl for symstartd Si guardsi ivli sctni roi XSi uses poincare_onto_from_impl
 lemmas [autoref_rules] = poincare_onto_from_impl.refine
 sublocale autoref_op_pat_def poincare_onto_from .
 
 schematic_goal subset_spec1_impl:
   "(nres_of ?r, subset_spec1 R P dP) \<in> \<langle>bool_rel\<rangle>nres_rel"
   if [autoref_rules]:
     "(Ri, R) \<in> appr1_rel"
     "(Pimpl, P) \<in> lvivl_rel"
     "(dPi, dP) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
   unfolding subset_spec1_def
   including art
   by autoref_monadic
 lemmas [autoref_rules] = subset_spec1_impl[autoref_higher_order_rule]
 sublocale autoref_op_pat_def subset_spec1 .
 
 schematic_goal subset_spec1_collc:
   "(nres_of (?f), subset_spec1_coll R P dP) \<in> \<langle>bool_rel\<rangle>nres_rel"
   if [autoref_rules]:
     "(Ri, R) \<in> clw_rel appr1_rel"
     "(Pimpl, P) \<in> lvivl_rel"
     "(dPi, dP) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
   unfolding subset_spec1_coll_def
   including art
   by autoref_monadic
 concrete_definition subset_spec1_collc for Ri Pimpl dPi uses subset_spec1_collc
 lemmas subset_spec1_collc_refine[autoref_rules] = subset_spec1_collc.refine[autoref_higher_order_rule]
 sublocale autoref_op_pat_def subset_spec1_coll .
 
 schematic_goal one_step_until_time_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \<in> appr1e_rel"
   assumes [autoref_rules]: "(phi, ph) \<in> bool_rel"
   assumes [autoref_rules]: "(t1i, t1) \<in> rnv_rel"
   notes [autoref_tyrel] = ty_REL[where 'a="real" and R="Id"]
   shows "(nres_of ?f, one_step_until_time odo X0 ph t1)\<in>\<langle>appr1e_rel \<times>\<^sub>r \<langle>clw_rel appr_rel\<rangle>phantom_rel\<rangle>nres_rel"
   unfolding one_step_until_time_def[abs_def]
   including art
   by autoref_monadic
 concrete_definition one_step_until_time_impl for odoi X0i phi t1i uses one_step_until_time_impl
 lemmas one_step_until_time_impl_refine[autoref_rules] = one_step_until_time_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def one_step_until_time .
 
 schematic_goal ivl_of_appr1_coll_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules]: "(Xi, X::'n::enum rvec set) \<in> clw_rel appr_rel"
   shows "(nres_of ?r, ivl_of_eucl_coll X) \<in> \<langle>appr1_rel\<rangle>nres_rel"
   unfolding ivl_of_eucl_coll_def
   by autoref_monadic
 concrete_definition ivl_of_appr1_coll_impl uses ivl_of_appr1_coll_impl
 sublocale autoref_op_pat_def ivl_of_eucl_coll .
 lemmas ivl_of_appr1_coll_impl_refine[autoref_rules] =
   ivl_of_appr1_coll_impl.refine[autoref_higher_order_rule(1)]
 
 schematic_goal one_step_until_time_ivl_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \<in> appr1e_rel"
   assumes [autoref_rules]: "(phi, ph) \<in> bool_rel"
   assumes [autoref_rules]: "(t1i, t1) \<in> rnv_rel"
   assumes [autoref_rules]: "(t2i, t2) \<in> rnv_rel"
   shows "(nres_of ?r, one_step_until_time_ivl odo X0 ph t1 t2) \<in> \<langle>appr1e_rel \<times>\<^sub>r \<langle>clw_rel appr_rel\<rangle>phantom_rel\<rangle>nres_rel"
   unfolding one_step_until_time_ivl_def
   including art
   by autoref_monadic
 concrete_definition one_step_until_time_ivl_impl for X0i phi t1i t2i uses one_step_until_time_ivl_impl
 lemmas [autoref_rules] = one_step_until_time_ivl_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def one_step_until_time_ivl .
 
 
 schematic_goal poincare_onto_from_in_ivl_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel appr1e_rel"
     and [autoref_rules]: "(Si, S) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
     and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
     and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
   assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
     \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
   assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
     and [autoref_rules]: "((), trap) \<in> ghost_rel"
     "(Pimpl, P) \<in> lvivl_rel"
     "(dPi, dP) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
   notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl] closed_ivl_prod3_list_rel
   shows "(nres_of ?r, poincare_onto_from_in_ivl
       $ odo $ symstart $ trap $ S $ guards $ ivl $ sctn $ ro $ XS $ P $ dP) \<in>
     \<langle>bool_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto_from_in_ivl_def
   including art
   by autoref_monadic
 
 concrete_definition poincare_onto_from_in_ivl_impl for E odoi symstartd Si guardsi ivli sctni roi XSi Pimpl dPi uses poincare_onto_from_in_ivl_impl
 lemmas [autoref_rules] = poincare_onto_from_in_ivl_impl.refine
 sublocale autoref_op_pat_def poincare_onto_from_in_ivl .
 
 lemma TRANSFER_I: "x \<Longrightarrow> TRANSFER x"
   by simp
 
 lemma dres_nres_rel_nres_relD: "(symstartd, symstart) \<in> A \<rightarrow> \<langle>B\<rangle>dres_nres_rel \<Longrightarrow> (\<lambda>x. nres_of (symstartd x), symstart) \<in> A \<rightarrow> \<langle>B\<rangle>nres_rel"
   by (auto simp: dres_nres_rel_def nres_rel_def dest!: fun_relD)
 
 lemma c1_info_of_apprsI:
   assumes "(b, a) \<in> clw_rel appr1_rel"
   assumes "x \<in> a"
   shows "x \<in> c1_info_of_apprs b"
   using assms
   by (auto simp: appr1_rel_br clw_rel_br c1_info_of_apprs_def dest!: brD)
 
 lemma clw_rel_appr1_relI:
   assumes "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invar CARD('n::enum) X"
   shows "(XS, c1_info_of_apprs XS::('n rvec\<times>_)set) \<in> clw_rel appr1_rel"
   by (auto simp: appr1_rel_br clw_rel_br c1_info_of_apprs_def intro!: brI assms)
 
 lemma c1_info_of_appr'I:
   assumes "(b, a) \<in> \<langle>clw_rel appr1_rel\<rangle>phantom_rel"
   assumes "x \<in> a"
   shows "x \<in> c1_info_of_appr' b"
   using assms
   by (auto simp add: c1_info_of_appr'_def intro!: c1_info_of_apprsI split: option.splits)
 
 lemma appr1e_relI:
   assumes "c1_info_invare CARD('n::enum) X0i"
   shows "(X0i, c1_info_of_appre X0i::'n eucl1 set) \<in> appr1e_rel"
   using assms
   apply (cases X0i)
   apply (auto simp: scaleR2_rel_def c1_info_of_appre_def c1_info_invare_def)
   apply (rule relcompI)
    apply (rule prod_relI)
     apply (rule IdI)
    apply (rule appr1_relI)
     apply (auto simp: vimage_def intro!: brI)
    apply (metis ereal_dense2 less_imp_le)
     apply (rule relcompI)
    apply (rule prod_relI)
     apply (rule IdI)
    apply (rule appr1_relI)
    apply (auto simp: vimage_def intro!: brI)
   by (metis basic_trans_rules(23) ereal_cases ereal_less_eq(1) ereal_top order_eq_refl)
 
 lemma c1_info_of_apprI:
   assumes "(b, a) \<in> appr1_rel"
   assumes "x \<in> a"
   shows "x \<in> c1_info_of_appr b"
   using assms
   apply (auto simp add: c1_info_of_appr_def c1_info_invar_def appr1_rel_internal appr_rel_def lv_rel_def
       set_rel_br
       dest!: brD
       split: option.splits)
    apply (auto simp add:  appr_rell_internal dest!: brD)
   done
 
 lemma c1_info_of_appreI:
   assumes "(lub, a) \<in> appr1e_rel"
   assumes "x \<in> a"
   shows "x \<in> c1_info_of_appre lub"
   using assms
   apply (auto simp add: scaleR2_def c1_info_of_appre_def image_def vimage_def scaleR2_rel_def
       dest!: brD
       intro!: c1_info_of_apprsI split: option.splits)
   subgoal for a b c d e f g h i
     apply (rule exI[where x=g])
     apply (rule conjI, assumption)+
     apply (rule bexI)
      prefer 2
      apply (rule c1_info_of_apprI) apply assumption
      apply assumption apply simp
     done
   done
 
 lemma c1_info_of_apprseI:
   assumes "(b, a) \<in> clw_rel appr1e_rel"
   assumes "x \<in> a"
   shows "x \<in> c1_info_of_apprse b"
   using assms
   by (force simp: appr1_rel_br scaleR2_rel_br clw_rel_br c1_info_of_appre_def c1_info_of_apprse_def
       dest!: brD)
 
 lemma clw_rel_appr1e_relI:
   assumes "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n::enum) X"
   shows "(XS, c1_info_of_apprse XS::('n rvec\<times>_)set) \<in> clw_rel appr1e_rel"
   using assms
   apply (auto simp: c1_info_of_apprse_def c1_info_of_appre_def c1_info_invare_def)
   unfolding appr1_rel_br scaleR2_rel_br clw_rel_br
   apply (rule brI)
    apply (auto simp: c1_info_invar_def vimage_def)
   subgoal premises prems for a b c d
     using prems(1)[OF prems(2)]
     by (cases a; cases b) auto
   done
 
 schematic_goal one_step_until_time_ivl_in_ivl_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n::enum rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \<in> appr1e_rel"
   assumes [autoref_rules]: "(t1i, t1) \<in> rnv_rel"
   assumes [autoref_rules]: "(t2i, t2) \<in> rnv_rel"
       "(Ri, R) \<in> lvivl_rel"
       "(dRi, dR) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
   shows "(nres_of ?r, one_step_until_time_ivl_in_ivl odo X0 t1 t2 R dR) \<in> \<langle>bool_rel\<rangle>nres_rel"
   unfolding one_step_until_time_ivl_in_ivl_def
   including art
   by autoref_monadic
 concrete_definition one_step_until_time_ivl_in_ivl_impl for odoi X0i t1i t2i Ri dRi
   uses one_step_until_time_ivl_in_ivl_impl
 lemmas one_step_until_time_ivl_in_ivl_impl_refine[autoref_rules] =
   one_step_until_time_ivl_in_ivl_impl.refine[autoref_higher_order_rule(1 2 3)]
 sublocale autoref_op_pat_def one_step_until_time_ivl_in_ivl .
 
 schematic_goal poincare_onto_in_ivl_impl:
   assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n::enum rvec)"
   assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
   assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
   assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel appr1e_rel"
     and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
     and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
     and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
       "(Pimpl, P::'n rvec set) \<in> lvivl_rel"
       "(dPi, dP:: ((real, 'n) vec, 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
   notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl] closed_ivl_prod3_list_rel
   shows "(nres_of ?r,
     poincare_onto_in_ivl odo guards ivl sctn ro XS P dP) \<in>
     \<langle>bool_rel\<rangle>nres_rel"
   unfolding autoref_tag_defs
   unfolding poincare_onto_in_ivl_def
   including art
   apply (rule autoref_monadicI)
    apply (autoref phases: id_op rel_inf fix_rel)
    apply (autoref_trans_step)
     apply (autoref_trans_step)
      apply (autoref_trans_step)
     apply (simp only: autoref_tag_defs)
     apply (rule poincare_onto_series_impl.refine[unfolded autoref_tag_defs])\<comment> \<open>TODO: why?\<close>
                apply fact+
       apply (rule empty_symstart_impl)
      apply refine_transfer
     apply (rule ghost_relI)
    apply (autoref phases: trans)
   unfolding autoref_tag_defs
   by refine_transfer
 
 concrete_definition poincare_onto_in_ivl_impl for E odoi guardsi ivli sctni roi XSi Pimpl dPi
   uses poincare_onto_in_ivl_impl
 lemmas [autoref_rules] = poincare_onto_in_ivl_impl.refine[autoref_higher_order_rule(1 2 3)]
 
 
 subsection \<open>Main (executable) interfaces to the ODE solver, with initialization\<close>
 
 definition "carries_c1 = Not o Option.is_none o (snd o snd)"
 
 definition "solves_poincare_map odo symstart S guards ivli sctni roi XS P dP \<longleftrightarrow>
   poincare_onto_from_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 (hd XS)) odo) symstart S guards ivli sctni
     roi XS P dP = dRETURN True"
 
 definition "solves_poincare_map' odo S = solves_poincare_map odo (\<lambda>x. dRETURN ([], [x])) [S]"
 
 definition "one_step_until_time_ivl_in_ivl_check odo X t0 t1 Ri dRi \<longleftrightarrow>
   one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 Ri dRi = dRETURN True"
 
 definition "solves_poincare_map_onto odo guards ivli sctni roi XS P dP \<longleftrightarrow>
   poincare_onto_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 (hd XS)) odo) guards ivli sctni roi XS P dP = dRETURN True"
 
 end
 
 context approximate_sets begin
 
 lemma c1_info_of_appre_c0_I:
   "(x, d) \<in> c1_info_of_appre ((1, 1), X0, None)"
   if "list_of_eucl x \<in> set_of_appr X0"
   using that
   by (force simp: c1_info_of_appre_def c1_info_of_appr_def)
 
 lemma lvivl'_invar_None[simp]: "lvivl'_invar n None"
   by (auto simp: lvivl'_invar_def)
 
 lemma c1_info_invar_None: "c1_info_invar n (u, None) \<longleftrightarrow> length u = n"
   by (auto simp: c1_info_invar_def)
 
 lemma c1_info_invare_None: "c1_info_invare n ((l, u), x, None) \<longleftrightarrow>((l < u \<or> -\<infinity> < l \<and> l \<le> u \<and> u < \<infinity>) \<and> length x = n)"
   by (auto simp: c1_info_invare_def Let_def c1_info_invar_None)
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy b/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy
--- a/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy
+++ b/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy
@@ -1,2896 +1,2892 @@
 theory Refine_Reachability_Analysis_C1
   imports
     Abstract_Reachability_Analysis_C1
     Refine_Reachability_Analysis
 begin
 
 lemma fst_flow1_of_vec1[simp]: "fst (flow1_of_vec1 x) = fst x"
   by (auto simp: flow1_of_vec1_def)
 
 lemma fst_vec1_of_flow[simp]: "fst (vec1_of_flow1 x) = fst x"
   by (auto simp: vec1_of_flow1_def)
 
 context approximate_sets_ode'
 begin
 
 lemma poincare_mapsto_scaleR2I:
   "poincare_mapsto P (scaleR2 x1 x2 baa) UNIV x1b (scaleR2 x1 x2 aca)"
   if "poincare_mapsto P (baa) UNIV x1b (aca)"
   using that
   apply (auto simp: poincare_mapsto_def scaleR2_def image_def vimage_def)
   apply (drule bspec, assumption)
   apply auto
   apply (rule exI, rule conjI, assumption)
   apply (rule exI, rule conjI, assumption, rule conjI, assumption)
   apply (rule bexI) prefer 2 apply assumption
   apply (auto simp: scaleR_blinfun_compose_right)
   done
 
 context includes ode_ops.lifting begin
 lemma var_safe_form_eq[simp]: "var.safe_form = safe_form"
   unfolding var.safe_form_def
   by transfer (auto simp: var_ode_ops_def safe_form_def)
 
 lemma var_ode_e: "var.ode_e = ode_e'"
   unfolding var.ode_e_def
   by transfer (auto simp: var_ode_ops_def)
 end
 
 lemma wd_imp_var_wd[refine_vcg, intro]: "wd (TYPE('n rvec)) \<Longrightarrow> var.wd (TYPE('n::enum vec1))"
   unfolding var.wd_def
   by (auto simp: wd_def length_concat o_def sum_list_distinct_conv_sum_set
       concat_map_map_index var_ode_e D_def ode_e'_def
       intro!: max_Var_floatariths_mmult_fa[le] max_Var_floatariths_mapI
       max_Var_floatarith_FDERIV_floatarith[le]
       max_Var_floatariths_fold_const_fa[le]
       max_Var_floatarith_le_max_Var_floatariths_nthI
       max_Var_floatariths_list_updateI max_Var_floatariths_replicateI)
 
 lemma safe_eq:
   assumes "wd TYPE('n::enum rvec)"
   shows "var.Csafe = ((Csafe \<times> UNIV)::'n vec1 set)"
   using assms var.wdD[OF wd_imp_var_wd[OF assms]] wdD[OF assms]
   unfolding var.safe_def safe_def var.wd_def wd_def var.Csafe_def Csafe_def
   unfolding ode_e'_def var_ode_e
   apply (auto simp: D_def)
   subgoal
     apply (subst interpret_form_max_Var_cong) prefer 2 apply assumption
     by (auto simp: nth_Basis_list_prod)
   subgoal for a b
     apply (drule isFDERIV_appendD1)
         apply simp apply simp apply (auto intro!: max_Var_floatariths_fold_const_fa[le])[]
     apply (rule isFDERIV_max_Var_congI, assumption)
     by (auto simp: nth_Basis_list_prod)
   subgoal
     apply (subst interpret_form_max_Var_cong) prefer 2 apply assumption
     by (auto simp: nth_Basis_list_prod)
   subgoal for a b
     apply (rule isFDERIV_appendI1)
     apply (rule isFDERIV_max_Var_congI, assumption)
         apply (auto simp: nth_Basis_list_prod)
      apply (auto simp: isFDERIV_def FDERIV_floatariths_def in_set_conv_nth isDERIV_inner_iff
       length_concat o_def sum_list_distinct_conv_sum_set concat_map_map_index
         intro!: isDERIV_FDERIV_floatarith isDERIV_mmult_fa_nth)
      apply (rule isDERIV_max_Var_floatarithI[where ys="list_of_eucl a"])
     subgoal for i j k
       apply (cases "i < CARD('n)")
       subgoal by auto
       subgoal apply (rule isDERIV_max_VarI)
          apply (rule max_Var_floatarith_le_max_Var_floatariths_nthI)
           apply force
          apply auto
         done
       done
     subgoal for i j k l by (auto dest!: max_Var_floatariths_lessI simp: nth_Basis_list_prod)
     subgoal by (auto simp: nth_list_update)
     done
   done
 
 lemma
   var_ode_eq:
   fixes x::"'n::enum vec1"
   assumes "wd TYPE('n rvec)" and [simp]: "(fst x) \<in> Csafe"
   shows "var.ode x = (ode (fst x), matrix (ode_d1 (fst x)) ** snd x)"
 proof -
   have "interpret_floatariths ode_e (list_of_eucl x) =
     interpret_floatariths ode_e (list_of_eucl (fst x))"
     apply (rule interpret_floatariths_max_Var_cong)
     using wdD[OF \<open>wd _\<close>]
     by (auto simp: list_of_eucl_nth_if nth_Basis_list_prod inner_prod_def)
   moreover
   have "eucl_of_list
             (interpret_floatariths
               (mmult_fa D D D
        (concat (map (\<lambda>j. map (\<lambda>i. FDERIV_floatarith (ode_e ! j) [0..<D] ((replicate D 0)[i := 1])) [0..<D]) [0..<D]))
        (map floatarith.Var [D..<D + D * D])) (list_of_eucl x)) =
     matrix (blinfun_apply (ode_d 0 (fst x) 0)) ** snd x"
     unfolding matrix_eq
     apply auto
     apply (subst matrix_vector_mul_assoc[symmetric])
     apply (subst matrix_works)
     subgoal by (auto simp: linear_matrix_vector_mul_eq
           intro!: bounded_linear.linear blinfun.bounded_linear_right)
     apply (subst einterpret_mmult_fa[where 'n='n and 'm = 'n and 'l='n])
     subgoal by (simp add: wdD[OF \<open>wd _\<close>])
     subgoal by (simp add: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF \<open>wd _\<close>])
     subgoal by (simp add: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF \<open>wd _\<close>])
     subgoal for v
     proof -
       have v: "einterpret (map floatarith.Var [D..<D + D * D]) (list_of_eucl x) *v v = snd x *v v"
         apply (vector matrix_vector_mult_def)
         apply (simp add: vec_nth_eq_list_of_eucl2 wdD[OF \<open>wd _\<close>])
         apply (auto simp: vec_nth_eq_list_of_eucl1 sum_index_enum_eq)
         apply (subst sum_index_enum_eq)+
         apply (rule sum.cong)
         by (auto simp: nth_Basis_list_prod prod_eq_iff inner_prod_def)
       show ?thesis
         unfolding matrix_vector_mul_assoc[symmetric]
         apply (subst v)
         apply (auto simp: concat_map_map_index vec_nth_eq_list_of_eucl2)
         apply (subst  eucl_of_list_list_of_eucl[of "snd x *v v", symmetric])
         apply (subst (2) eucl_of_list_list_of_eucl[of "snd x *v v", symmetric])
         apply (subst eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list)
         subgoal by (simp add: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF \<open>wd _\<close>])
         subgoal by simp
         apply (subst blinfun_apply_eq_sum)
          apply (auto simp: vec_nth_eq_list_of_eucl1 sum_index_enum_eq)
         apply (auto simp: scaleR_sum_left ode_d.rep_eq intro!: sum.cong[OF refl])
         apply (auto simp: ode_d_raw_def wdD[OF \<open>wd _\<close>] eucl_of_list_inner )
         apply (auto simp: ode_d_expr_def FDERIV_floatariths_def wdD[OF \<open>wd _\<close>] )
         apply (rule interpret_floatarith_FDERIV_floatarith_cong)
         subgoal for x y i
           using wdD[OF \<open>wd _\<close>]
           by (auto simp add: nth_append inner_prod_def
               nth_Basis_list_prod dest!: max_Var_floatariths_lessI)
         subgoal by auto
         subgoal by auto
         subgoal
           apply (auto simp: wdD[OF \<open>wd _\<close>] nth_list_update inner_Basis intro!: nth_equalityI)
           by (metis \<open>length (list_of_eucl (snd x *v v)) = CARD('n)\<close> index_Basis_list_nth length_list_of_eucl)
         done
     qed
     done
   ultimately show ?thesis
     unfolding var.ode_def ode_def
     unfolding ode_e'_def var_ode_e
     by (auto simp: wdD[OF \<open>wd _\<close>] ode_d1_def intro!: euclidean_eqI[where 'a="'n vec1"])
 qed
 
 lemma var_existence_ivl_imp_existence_ivl:
   fixes x::"'n::enum vec1"
   assumes wd: "wd TYPE('n rvec)"
   assumes t: "t \<in> var.existence_ivl0 x"
   shows "t \<in> existence_ivl0 (fst x)"
 proof (rule existence_ivl_maximal_segment)
   from var.flow_solves_ode[OF UNIV_I var.mem_existence_ivl_iv_defined(2), OF t]
   have D: "(var.flow0 x solves_ode (\<lambda>_. var.ode)) {0--t} (var.Csafe)"
     apply (rule solves_ode_on_subset)
      apply (rule var.closed_segment_subset_existence_ivl)
      apply (rule t)
     apply simp
     done
   show "((\<lambda>t. fst (var.flow0 x t)) solves_ode (\<lambda>_. ode)) {0--t} (Csafe)"
     using var.closed_segment_subset_existence_ivl[OF t]
     apply (auto simp: has_vderiv_on_def has_vector_derivative_def subset_iff
         intro!: solves_odeI derivative_eq_intros)
         apply (rule refl)
        apply (rule refl)
       apply (rule refl)
      apply (auto simp: var.flowderiv_def )
      apply (subst var_ode_eq[OF wd(1)])
       apply (auto simp: blinfun.bilinear_simps)
     subgoal for s
       using solves_odeD(2)[OF D, of s]
       by (subst(asm) (3) safe_eq[OF wd]) (auto )
     subgoal for s
       using solves_odeD(2)[OF D, of s]
       by (subst(asm) (3) safe_eq[OF wd]) (auto )
     done
 next
   show "fst (var.flow0 x 0) = fst x"
     apply (subst var.flow_initial_time)
       apply simp
     apply (rule var.mem_existence_ivl_iv_defined[OF t])
     apply auto
     done
 qed simp
 
 lemma existence_ivl_imp_var_existence_ivl:
   fixes x::"'n::enum rvec"
   assumes wd: "wd TYPE('n rvec)"
   assumes t: "t \<in> existence_ivl0 x"
   shows "t \<in> var.existence_ivl0 ((x, W)::'n vec1)"
 proof (rule var.existence_ivl_maximal_segment)
   from flow_solves_ode[OF UNIV_I mem_existence_ivl_iv_defined(2), OF t]
   have D: "(flow0 x solves_ode (\<lambda>_. ode)) {0--t} (Csafe)"
     apply (rule solves_ode_on_subset)
      apply (rule closed_segment_subset_existence_ivl)
      apply (rule t)
     apply simp
     done
   show "((\<lambda>t. (flow0 x t, matrix (Dflow x t) ** W)) solves_ode (\<lambda>_. var.ode)) {0--t} (var.Csafe)"
     using closed_segment_subset_existence_ivl[OF t]
     apply (auto simp: has_vderiv_on_def has_vector_derivative_def subset_iff
         intro!: solves_odeI derivative_eq_intros)
         apply (rule refl)
         apply (rule refl)
         apply (rule refl)
        apply (rule has_derivative_at_withinI)
        apply (rule Dflow_has_derivative)
        apply force
       apply (rule refl)
      apply (auto simp: flowderiv_def )
      apply (subst var_ode_eq)
      apply (auto simp: blinfun.bilinear_simps matrix_blinfun_compose wd
         intro!: ext)
     subgoal for s h
       unfolding matrix_scaleR matrix_blinfun_compose matrix_mul_assoc matrix_scaleR_right ..
     subgoal for s
       using solves_odeD(2)[OF D, of s] safe_eq[OF wd]
       by auto
     done
 next
   have "x \<in> Csafe" by rule fact
   then show "(flow0 x 0, matrix (blinfun_apply (Dflow x 0)) ** W) = (x, W)"
     apply (auto )
     apply (vector matrix_def matrix_matrix_mult_def axis_def)
     by (auto simp:  if_distrib if_distribR cong: if_cong)
 qed auto
 
 theorem var_existence_ivl0_eq_existence_ivl0:
   fixes x::"'n::enum vec1"
   assumes wd: "wd TYPE('n rvec)"
   shows "var.existence_ivl0 (x::'n vec1) = existence_ivl0 (fst x)"
   apply safe
   subgoal by (rule var_existence_ivl_imp_existence_ivl[OF wd, of _ "x", simplified], simp)
   subgoal
     by (rule existence_ivl_imp_var_existence_ivl[OF wd, of _ "fst x" "snd x", unfolded prod.collapse])
   done
 
 theorem var_flow_eq_flow_Dflow:
   fixes x::"'n::enum vec1"
   assumes wd: "wd TYPE('n rvec)"
   assumes t: "t \<in> var.existence_ivl0 x"
   shows "var.flow0 x t = vec1_of_flow1 (flow0 (fst x) t, Dflow (fst x) t o\<^sub>L blinfun_of_vmatrix (snd x)) "
 proof -
   have x: "x \<in> var.Csafe"
     by (rule var.mem_existence_ivl_iv_defined[OF t])
   then have "fst x \<in> Csafe"
     by (subst (asm) safe_eq[OF wd]) auto
   then have sx[simp]: "(fst x) \<in> Csafe" by simp
   show ?thesis
   proof (rule var.flow_unique_on[OF t])
     show "vec1_of_flow1 (flow0 (fst x) 0, Dflow (fst x) 0 o\<^sub>L blinfun_of_vmatrix (snd x)) = x"
       by (auto simp: vec1_of_flow1_def x)
     show "((\<lambda>a. vec1_of_flow1 (flow0 (fst x) a, Dflow (fst x) a o\<^sub>L blinfun_of_vmatrix (snd x))) has_vderiv_on
      (\<lambda>t. var.ode (vec1_of_flow1 (flow0 (fst x) t, Dflow (fst x) t o\<^sub>L blinfun_of_vmatrix (snd x)))))
      (var.existence_ivl0 x)"
       apply (auto simp: has_vderiv_on_def has_vector_derivative_def vec1_of_flow1_def
           at_within_open[OF _ var.open_existence_ivl] flowderiv_def
           intro!: derivative_eq_intros var_existence_ivl_imp_existence_ivl[OF wd]
           Dflow_has_derivative ext)
       apply (subst var_ode_eq[OF wd(1)])
        apply (auto simp: blinfun.bilinear_simps)
       subgoal for t
         using flow_in_domain[of t "fst x"]
         by (simp add: var_existence_ivl_imp_existence_ivl[OF wd])
       subgoal for t h
         by (simp add: matrix_blinfun_compose matrix_scaleR matrix_mul_assoc matrix_scaleR_right)
       done
     fix t
     assume "t \<in> var.existence_ivl0 x"
     then show "vec1_of_flow1 (flow0 (fst x) t, Dflow (fst x) t o\<^sub>L blinfun_of_vmatrix (snd x)) \<in> var.Csafe"
       by (subst safe_eq[OF wd])
         (auto simp: vec1_of_flow1_def dest!: var_existence_ivl_imp_existence_ivl[OF wd]
           flow_in_domain)
   qed
 qed
 
 theorem flow_Dflow_eq_var_flow:
   fixes x::"'n::enum rvec"
   assumes wd: "wd TYPE('n rvec)"
   assumes t: "t \<in> existence_ivl0 x"
   shows "(flow0 x t, Dflow x t o\<^sub>L W) = flow1_of_vec1 (var.flow0 (x, matrix W) t::'n vec1)"
   using var_flow_eq_flow_Dflow[OF wd existence_ivl_imp_var_existence_ivl[OF wd t]]
   unfolding var_flow_eq_flow_Dflow[OF wd existence_ivl_imp_var_existence_ivl[OF wd t]]
   by (auto simp: flow1_of_vec1_def vec1_of_flow1_def)
 
 context includes blinfun.lifting begin
 lemma flow1_of_vec1_vec1_of_flow1[simp]:
   "flow1_of_vec1 (vec1_of_flow1 X) = X"
   unfolding vec1_of_flow1_def flow1_of_vec1_def
   by (transfer) auto
 end
 
 lemma
   var_flowpipe0_flowpipe:
   assumes wd: "wd TYPE('n::enum rvec)"
   assumes "var.flowpipe0 X0 hl hu (CX) X1"
   assumes "fst ` X0 \<subseteq> Csafe"
   assumes "fst ` CX \<subseteq> Csafe"
   assumes "fst ` X1 \<subseteq> Csafe"
   shows "flowpipe (flow1_of_vec1 ` X0) hl hu (flow1_of_vec1 ` (CX::'n vec1 set)) (flow1_of_vec1 ` X1)"
   using assms
   unfolding flowpipe_def var.flowpipe0_def
   apply safe
   subgoal by (auto simp add: flow1_of_vec1_def vec1_of_flow1_def safe_eq[OF wd])
   subgoal by (auto simp add: flow1_of_vec1_def vec1_of_flow1_def safe_eq[OF wd])
   subgoal by (auto simp add: flow1_of_vec1_def vec1_of_flow1_def safe_eq[OF wd])
   subgoal for x W y V h
     apply (drule bspec[where x="(y, V)"], force)
     apply (drule bspec, assumption)
     by (simp add: var_existence_ivl0_eq_existence_ivl0[OF wd] flow1_of_vec1_def)
   subgoal for x W y V h
     apply (drule bspec[where x="(y, V)"], force)
     apply (drule bspec, assumption)
     apply (subst flow_Dflow_eq_var_flow[OF wd],
         force simp: var_existence_ivl0_eq_existence_ivl0[OF wd] flow1_of_vec1_def)
     apply (rule imageI)
     by (simp add: vec1_of_flow1_def flow1_of_vec1_def)
   subgoal for x W y V h h'
     apply (drule bspec[where x="vec1_of_flow1 (x, W)"], force)
     apply (drule bspec, assumption)
     apply (subst flow_Dflow_eq_var_flow[OF wd])
      apply (subst (asm) var_existence_ivl0_eq_existence_ivl0[OF wd])
      apply (simp add: flow1_of_vec1_def)
     subgoal
       by (meson local.existence_ivl_initial_time local.mem_existence_ivl_iv_defined(1)
           local.mem_existence_ivl_iv_defined(2) mem_is_interval_1_I mvar.interval)
     subgoal
       apply (rule imageI)
       by (simp add: vec1_of_flow1_def flow1_of_vec1_def)
     done
   done
 
 theorem einterpret_solve_poincare_fas:
   assumes wd: "wd TYPE('n rvec)"
   assumes "length CXs = D + D*D" "n < D"
   assumes nz: "ode (fst (eucl_of_list CXs::'n vec1)) \<bullet> Basis_list ! n \<noteq> 0"
   shows
   "flow1_of_vec1 (einterpret (solve_poincare_fas n) CXs::'n::enum vec1) =
   (let (x, d) = flow1_of_vec1 (eucl_of_list CXs::'n vec1) in (x,
      d - (blinfun_scaleR_left (ode (x)) o\<^sub>L
     (blinfun_scaleR_left (inverse (ode x \<bullet> Basis_list ! n)) o\<^sub>L (blinfun_inner_left (Basis_list ! n) o\<^sub>L d)))))"
   using assms
   apply (auto intro!: simp: flow1_of_vec1_def solve_poincare_fas_def)
   subgoal
     apply (auto intro!: euclidean_eqI[where 'a="'n rvec"])
     apply (subst eucl_of_list_prod)
     by (auto simp: eucl_of_list_prod length_concat o_def sum_list_distinct_conv_sum_set D_def Let_def
         wdD[OF wd] take_eq_map_nth)
   subgoal premises prems
   proof -
     have ode_e_eq: "interpret_floatarith (ode_e ! i) (map ((!) CXs) [0..<CARD('n)]) = interpret_floatarith (ode_e ! i) CXs"
       if "i < D"
       for i
       apply (rule interpret_floatarith_max_Var_cong)
       apply (drule max_Var_floatariths_lessI)
       using that apply (simp add: wdD[OF wd])
       apply (subst nth_map)
        apply auto
       using wdD[OF wd]
       apply (simp add: )
       using wdD[OF wd]
       apply (simp add: )
       done
     define z where "z = (0::float)"
     show ?thesis
       supply [simp] = snd_eucl_of_list_prod fst_eucl_of_list_prod
       supply [simp del] = eucl_of_list_take_DIM
       using prems unfolding z_def[symmetric] D_def Let_def
       including blinfun.lifting
       apply (transfer fixing: CXs n z)
       unfolding z_def
       apply (auto simp: o_def ode_def intro!: ext)
       apply (vector matrix_vector_mult_def )
       apply (auto intro!: blinfun_euclidean_eqI simp: inner_Basis_eq_vec_nth wdD[OF wd])
       apply (auto simp: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF wd] take_eq_map_nth)
       apply (auto simp: concat_map_map_index)
       apply (vector )
       apply (subst vec_nth_eq_list_of_eucl2 vec_nth_eq_list_of_eucl1)+
       apply (subst (asm) vec_nth_eq_list_of_eucl2 vec_nth_eq_list_of_eucl1)+
       apply (simp add: less_imp_le wdD[OF wd] index_nth_id )
       apply (auto simp: algebra_simps ode_e_eq wdD[OF wd] divide_simps)
       done
   qed
   done
 
 lemma choose_step'_flowpipe:
   assumes wd[refine_vcg]: "wd TYPE('n::enum rvec)"
   assumes safe: "fst ` X0 \<subseteq> Csafe"
   shows "var.choose_step (X0::'n vec1 set) h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'n vec1 set).
       0 < h' \<and> h' \<le> h \<and> flowpipe (flow1_of_vec1 ` X0) h' h' (flow1_of_vec1 ` RES_ivl) (flow1_of_vec1 ` RES))"
   apply refine_vcg
   apply (auto simp: )
   apply (frule var.flowpipe0_safeD)
   apply (drule var_flowpipe0_flowpipe[rotated])
   by (auto simp: safe_eq wd)
 
 lemma max_Var_floatariths_solve_poincare_fas[le]:
   assumes wd: "wd (TYPE('n::enum rvec))"
   shows "i < D \<Longrightarrow> max_Var_floatariths (solve_poincare_fas i) \<le> D + D * D"
   by (auto simp: solve_poincare_fas_def concat_map_map_index Let_def
       intro!: max_Var_floatariths_leI Suc_leI)
    (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nthI max_Var_floatariths_ode_e_wd[OF wd]
       simp: wdD[OF wd])
 
 lemma length_solve_poincare_fas[simp]: "length (solve_poincare_fas n) = D + D * D"
   by (auto simp: solve_poincare_fas_def length_concat o_def sum_list_distinct_conv_sum_set D_def Let_def)
 
 theorem interpret_floatariths_solve_poincare_fas:
   assumes wd: "wd TYPE('n::enum rvec)"
   assumes "length CXs = D + D*D" "n < D"
   assumes nz: "ode (fst (eucl_of_list CXs::'n vec1)) \<bullet> Basis_list ! n \<noteq> 0"
   shows
   "interpret_floatariths (solve_poincare_fas n) CXs =
     list_of_eucl (vec1_of_flow1 (let (x, d) = flow1_of_vec1 (eucl_of_list CXs::'n vec1) in (x,
        d - (blinfun_scaleR_left (ode (x)) o\<^sub>L
       (blinfun_scaleR_left (inverse (ode x \<bullet> Basis_list ! n)) o\<^sub>L (blinfun_inner_left (Basis_list ! n) o\<^sub>L d))))))"
   using arg_cong[where f="list_of_eucl::'n vec1 \<Rightarrow> _", OF arg_cong[where f=vec1_of_flow1, OF einterpret_solve_poincare_fas[OF assms]]]
   apply (auto simp: )
   apply (subst (asm) list_of_eucl_eucl_of_list)
    apply (auto simp: )
   apply (auto simp: wdD[OF wd])
   done
 
 lemma length_solve_poincare_slp[simp]: "length solve_poincare_slp = D"
   by (auto simp: solve_poincare_slp_def)
 
 lemma ne_zero_lemma:
   assumes
     "ode ` fst ` CX \<subseteq> FC"
    "\<forall>b\<in>FC. b \<bullet> n \<noteq> 0"
    "(a, b) \<in> CX"
    "ode a \<bullet> n = 0"
  shows "False"
 proof -
   have "(a, b) \<in> CX" by fact
   then have "ode (fst (a, b)) \<in> ode ` fst ` CX" by blast
   also have "\<dots> \<subseteq> FC"
     by fact
   finally have "ode a \<in> FC" by simp
   with assms show False
     by auto
 qed
 
 lemma ne_zero_lemma2:
   assumes
    "ode ` fst ` flow1_of_vec1 ` env \<subseteq> F"
    "\<forall>x\<in>F. x \<bullet> n \<noteq> 0"
    "(a, b) \<in> env"
    "flow1_of_vec1 (a, b) = (a', b')"
    "ode a' \<bullet> n = 0"
  shows False
 proof -
   have "(a', b') \<in> flow1_of_vec1 ` env"
     apply (rule image_eqI)
     using assms by auto
   then have "ode (fst (a', b')) \<in> ode ` fst ` \<dots>" by blast
   also from assms have "\<dots> \<subseteq> F" by simp
   finally have "ode a' \<in> F" by simp
   with assms have "ode a' \<bullet> n \<noteq> 0" by auto
   with assms show False by simp
 qed
 
 lemma solve_poincare_plane[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   assumes "n \<in> Basis"
   shows "solve_poincare_plane (n::'n::enum rvec) CX \<le> SPEC (\<lambda>PDP.
     fst ` PDP \<subseteq> Csafe \<and>
     (\<forall>(x, d) \<in> CX. (x, d - (blinfun_scaleR_left (ode x) o\<^sub>L
       (blinfun_scaleR_left (inverse (ode x \<bullet> n)) o\<^sub>L (blinfun_inner_left n o\<^sub>L d)))) \<in> PDP) \<and>
     (\<forall>(x, d) \<in> PDP. ode x \<bullet> n \<noteq> 0))"
   unfolding solve_poincare_plane_def
   apply (refine_vcg)
   subgoal using assms by auto
   subgoal using assms by auto
   subgoal using assms by auto
   subgoal using assms by (auto simp: solve_poincare_slp_def)
   subgoal using assms by auto
   subgoal for C1 FC _ CX' CX'' P P1 FP _
     apply auto
     apply (drule bspec, assumption)
     apply (rule image_eqI)
      prefer 2 apply assumption
     apply (subst einterpret_solve_poincare_fas)
     subgoal using wd by auto
     subgoal using wd by auto
     subgoal using wd by auto
     subgoal using wd assms by (auto elim!: ne_zero_lemma)
     subgoal using wd assms by (auto simp: )
     done
   subgoal by (auto elim!: ne_zero_lemma2)
   done
 
 lemma choose_step1_flowpipe[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd TYPE('n::enum rvec)"
   shows "choose_step1 (X0::'n eucl1 set) h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'n eucl1 set).
       0 < h' \<and> h' \<le> h \<and> flowpipe X0 h' h' RES_ivl RES)"
   using assms
   unfolding choose_step1_def
   by (refine_vcg choose_step'_flowpipe[le] wd)
     (auto simp: image_image,
       auto simp: safe_eq vec1_of_flow1_def flowpipe0_imp_flowpipe env_len_def)
 
 lemma image_flow1_of_vec1I:
   "vec1_of_flow1 x \<in> X \<Longrightarrow> x \<in> flow1_of_vec1 ` X"
   by (rule image_eqI) (rule flow1_of_vec1_vec1_of_flow1[symmetric])
 
 lemma inter_sctn1_spec[le, refine_vcg]:
   "inter_sctn1_spec X sctn \<le> SPEC (\<lambda>(R, S). X \<inter> plane_of sctn \<times> UNIV \<subseteq> R \<and> fst ` R \<subseteq> plane_of sctn
   \<and> X \<inter> plane_of sctn \<times> UNIV \<subseteq> S \<and> fst ` S \<subseteq> plane_of sctn)"
   unfolding inter_sctn1_spec_def
   apply (refine_vcg, auto)
   subgoal by (rule image_flow1_of_vec1I) (auto simp: plane_of_def inner_prod_def)
   subgoal by (auto simp: plane_of_def inner_prod_def)
   subgoal by (rule image_flow1_of_vec1I)
          (force simp: set_plus_def plane_of_def inner_prod_def vec1_of_flow1_def)
   subgoal by (force simp: set_plus_def)
   done
 
 lemma fst_safe_coll[le, refine_vcg]:
   "wd TYPE('a) \<Longrightarrow>
       fst_safe_coll (X::('a::executable_euclidean_space*'c) set) \<le> SPEC (\<lambda>R. R = fst ` X \<and> fst ` X \<subseteq> Csafe)"
   unfolding fst_safe_coll_def
   by refine_vcg
 
 lemma vec1reps[THEN order_trans, refine_vcg]: "vec1reps CX \<le> SPEC (\<lambda>R. case R of None \<Rightarrow> True | Some X \<Rightarrow> X = vec1_of_flow1 ` CX)"
   unfolding vec1reps_def
   apply (refine_vcg FORWEAK_mono_rule[where
         I="\<lambda>XS R. case R of None \<Rightarrow> True | Some R \<Rightarrow> vec1_of_flow1 ` (\<Union>XS) \<subseteq> R \<and> R \<subseteq> vec1_of_flow1 ` CX"])
   by (auto simp:  split: option.splits) force+
 
 lemma nonzero_component_within[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "nonzero_component_within ivl sctn (PDP::'n eucl1 set) \<le> SPEC (\<lambda>b.
     (b \<longrightarrow> (\<forall>x\<in>PDP. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl))) \<and>
     fst ` PDP \<subseteq> Csafe \<and>
     (\<forall>x\<in>PDP. ode (fst x) \<bullet> normal sctn \<noteq> 0))"
   unfolding nonzero_component_within_def
   by refine_vcg auto
 
 lemma do_intersection_invar_inside:
   "do_intersection_invar guards b ivl sctn X (e, f, m, n, p, q, True) \<Longrightarrow>
   fst ` e \<subseteq> sabove_halfspace sctn \<Longrightarrow>
   fst ` mn \<subseteq> ivl \<Longrightarrow>
   mn = m \<or> mn = n \<Longrightarrow>
   do_intersection_spec UNIV guards ivl sctn X (mn, p)"
   subgoal premises prems
   proof -
     from prems have e: "e \<inter> sbelow_halfspace sctn \<times> UNIV = {}"
       by (auto simp: halfspace_simps plane_of_def)
     with prems(1) have
       "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} X UNIV p m"
       "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} X UNIV p n"
       "e \<inter> sbelow_halfspace sctn \<times> UNIV = {}"
       "fst ` X \<inter> b = {}"
       "fst ` X \<subseteq> sbelow_halfspace sctn"
       "ivl \<subseteq> plane (normal sctn) (pstn sctn)"
       "fst ` X \<subseteq> p"
       "fst ` m \<subseteq> Csafe"
       "fst ` n \<subseteq> Csafe"
       "p \<subseteq> Csafe"
       "fst ` e \<subseteq> Csafe"
       "f \<subseteq> {0..}"
       "p \<subseteq> sbelow_halfspace sctn - guards"
       "e \<subseteq> (- guards) \<times> UNIV"
       "fst ` (m \<union> n) \<inter> guards = {}"
       "0 \<notin> (\<lambda>x. ode x \<bullet> normal sctn) ` fst ` (m \<union> n)"
       "\<forall>x\<in>m \<union> n. \<forall>\<^sub>F x in at (fst x) within plane (normal sctn) (pstn sctn). x \<in> ivl"
       by (auto simp: do_intersection_invar_def do_intersection_spec_def plane_of_def)
     then show ?thesis
       using prems(2-)
       by (auto simp: do_intersection_spec_def plane_of_def halfspace_simps)
   qed
   done
 
 lemma do_intersection_body_lemma:
   assumes "flowsto A T (i \<times> UNIV) (X' \<inter> sbelow_halfspace sctn \<times> UNIV)"
     "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS "
     "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS2"
     "T \<subseteq> {0..}"
     "i \<subseteq> sbelow_halfspace sctn - guards"
     "fst ` (A \<union> B) \<subseteq> sbelow_halfspace sctn"
     "fst ` PS \<subseteq> Csafe "
     "fst ` PS2 \<subseteq> Csafe "
     \<open>X = A \<union> B\<close>
   assumes ivl: "closed ivl" "ivl \<subseteq> plane_of sctn"
   assumes normal_Basis: "\<bar>normal sctn\<bar> \<in> Basis"
     and inter_empties: "fst ` Y \<inter> GUARDS = {}" "fst ` CX' \<inter> GUARDS = {}"
     "fst ` PDP' \<inter> GUARDS = {}" "fst ` PDP'' \<inter> GUARDS = {}"
     and h': "0 < h'" "h' \<le> h"
     and safe: "fst ` PDP \<subseteq> Csafe" "fst ` CX' \<subseteq> Csafe"
     "fst ` PDP' \<subseteq> Csafe"
     "fst ` PDP'' \<subseteq> Csafe"
     and PDP:
     "\<forall>(x,d)\<in>CX'. (x,
             d - (blinfun_scaleR_left (ode x) o\<^sub>L
                   (blinfun_scaleR_left (inverse (ode x \<bullet> \<bar>normal sctn\<bar>)) o\<^sub>L
                   (blinfun_inner_left \<bar>normal sctn\<bar> o\<^sub>L d))))
                \<in> PDP"
     and PDP': "PDP \<inter> plane_of sctn \<times> UNIV \<subseteq> PDP'"
     and PDP'': "PDP \<inter> plane_of sctn \<times> UNIV \<subseteq> PDP''"
     and evin:
     "\<forall>x\<in>PDP'. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)"
     "\<forall>x\<in>PDP''. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)"
     and through: "\<forall>(x, d)\<in>PDP. ode x \<bullet> \<bar>normal sctn\<bar> \<noteq> 0"
     "\<forall>x\<in>PDP'. ode (fst x) \<bullet> normal sctn \<noteq> 0"
     "\<forall>x\<in>PDP''. ode (fst x) \<bullet> normal sctn \<noteq> 0"
     and plane:
     "fst ` PDP' \<subseteq> plane_of sctn"
     "fst ` PDP'' \<subseteq> plane_of sctn"
     and flowpipe: "flowpipe X' h' h' CX' Y"
   shows "\<exists>A B. X = A \<union> B \<and>
         flowsto A {0<..} ((fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) \<times> UNIV) (Y \<inter> sbelow_halfspace sctn \<times> UNIV) \<and>
         poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP' \<union> PS) \<and>
         poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP'' \<union> PS2)"
 proof -
   from flowpipe
   have 1: "flowpipe (X' \<inter> (sbelow_halfspace sctn) \<times> UNIV) h' h' CX' Y"
     by (rule flowpipe_subset) (use flowpipe in \<open>auto dest!: flowpipe_safeD\<close>)
   have 2: "fst ` (X' \<inter> (sbelow_halfspace sctn) \<times> UNIV) \<inter> {x. pstn sctn \<le> x \<bullet> normal sctn} = {}"
     by (auto simp: halfspace_simps plane_of_def)
   from normal_Basis have 3: "normal sctn \<noteq> 0"
     by (auto simp: )
   note 4 = \<open>closed ivl\<close>
   from \<open>ivl \<subseteq> plane_of sctn\<close> have 5: "ivl \<subseteq> plane (normal sctn) (pstn sctn)"
     by (auto simp: plane_of_def)
   have 6: "(x, d) \<in> CX' \<Longrightarrow> x \<in> plane (normal sctn) (pstn sctn) \<Longrightarrow>
           (x, d - (blinfun_scaleR_left (ode x) o\<^sub>L
                    (blinfun_scaleR_left (inverse (ode x \<bullet> normal sctn)) o\<^sub>L (blinfun_inner_left (normal sctn) o\<^sub>L d))))
           \<in> PDP' \<inter> PDP''" for x d
     unfolding PDP_abs_lemma[OF normal_Basis]
     apply (drule PDP[rule_format, of "(x, d)", unfolded split_beta' fst_conv snd_conv])
     using PDP' PDP''
     by (auto simp: plane_of_def)
   from normal_Basis through
   have 7: "(x, d) \<in> PDP' \<Longrightarrow> ode x \<bullet> normal sctn \<noteq> 0" for x d
     by (auto elim!: abs_in_BasisE)
   have 8: "(x, d) \<in> PDP' \<Longrightarrow> x \<in> ivl" for x d
     using evin by auto
   have 9: "(x, d) \<in> PDP' \<Longrightarrow> \<forall>\<^sub>F x in at x within plane (normal sctn) (pstn sctn). x \<in> ivl" for x d
     using evin by (auto simp add: plane_of_def)
   obtain X1 X2
     where X1X2: "X' \<inter> sbelow_halfspace sctn \<times> UNIV = X1 \<union> X2"
       and X1: "flowsto X1 {0<..h'} (CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV)
                       (CX' \<inter> {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV)"
       and X2: "flowsto X2 {h'..h'} (CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV)
                       (Y \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV)"
       and P: "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} X1 UNIV
                       (fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) (PDP' \<inter> PDP'')"
     by (rule flowpipe_split_at_above_halfspace[OF 1 2 3 4 5 6 7 8 9]) (auto simp: Ball_def)
   from \<open>flowsto A _ _ _\<close>[unfolded X1X2]
   obtain p1 p2 where p1p2: "A = p1 \<union> p2" and p1: "flowsto p1 T (i \<times> UNIV) X1" and p2: "flowsto p2 T (i \<times> UNIV) X2"
     by (rule flowsto_unionE)
   have "A \<union> B = p2 \<union> (p1 \<union> B)" using \<open>A = p1 \<union> p2\<close>
     by auto
   moreover
   from flowsto_trans[OF p2 X2]
   have "flowsto p2 {0<..} ((fst ` CX' \<inter> (sbelow_halfspace sctn) \<union> i) \<times> UNIV)
            (Y \<inter> (sbelow_halfspace sctn) \<times> UNIV)"
     apply (rule flowsto_subset)
     subgoal by (auto simp: halfspace_simps)
     subgoal using h' \<open>T \<subseteq> _\<close> by (auto simp: halfspace_simps intro!: add_nonneg_pos)
     subgoal
       using flowpipe_source_subset[OF 1, unfolded X1X2] X1X2
       apply auto
       by (auto simp: halfspace_simps)
     subgoal by (auto simp: halfspace_simps)
     done
   moreover
   have cls: "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
     by (rule closed_levelset_within continuous_intros \<open>closed ivl\<close>)+
   from flowsto_trans[OF p1 X1]
   have ftt: "flowsto p1 ({s + t |s t. s \<in> T \<and> t \<in> {0<..h'}})
        (i \<times> UNIV \<union> CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV \<union> X1 \<inter> X1)
        (X1 - X1 \<union> CX' \<inter> {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV)"
     by auto
   from X1X2 have X1_sb: "X1 \<subseteq> sbelow_halfspace sctn \<times> UNIV" by auto
   have "{x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV \<inter> (i \<times> UNIV \<union> CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV \<union> X1) = {}"
     apply (intro Int_Un_eq_emptyI)
     subgoal using \<open>i \<subseteq> sbelow_halfspace sctn - guards\<close> by (auto simp: halfspace_simps)
     subgoal by (auto simp: halfspace_simps)
     subgoal using X1_sb by (auto simp: halfspace_simps)
     done
   then have inter_empty:
     "{x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV \<inter> (i \<times> UNIV \<union> CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV \<union> X1 \<inter> X1) = {}"
     by auto
   have p1ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x"
     and p1pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` (PDP' \<inter> PDP'')"
     if "(x, d) \<in> p1" for x d
      apply (rule flowsto_poincareD[OF ftt _ inter_empty _ _ _ order_refl])
     subgoal by auto
     subgoal by fact
     subgoal using \<open>T \<subseteq> _\<close> by auto
     subgoal using that by auto
     subgoal
       apply (rule flowsto_poincareD[OF ftt _ inter_empty])
       subgoal by auto
       subgoal by fact
       subgoal using \<open>T \<subseteq> _\<close> by auto
       subgoal using that by auto
       subgoal using 6 by force
       done
     done
   have crt: "isCont (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0}) x" if "(x, d) \<in> p1" for x d
     apply (rule return_time_isCont_outside[where Ds="\<lambda>_. blinfun_inner_left (normal sctn)"])
     subgoal by (simp add: p1ret[OF that])
     subgoal by fact
     subgoal by (auto intro!: derivative_eq_intros)
     subgoal by simp
     subgoal apply simp
       using p1pm[OF that]
       by (auto dest!: 7)
     subgoal
       using p1pm[OF that]
       by (auto dest!: 9 simp: eventually_at_filter)
     subgoal
       using \<open>fst ` (A \<union> B) \<subseteq> sbelow_halfspace sctn\<close> that p1p2
       by (auto simp: halfspace_simps)
     done
   have pmij: "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} p1 UNIV
         (fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) (PDP' \<inter> PDP'')"
     apply (rule flowsto_poincare_trans[OF \<open>flowsto _ _ _ X1\<close> P])
     subgoal using \<open>T \<subseteq> {0..}\<close> by auto
     subgoal by auto
     subgoal
       using \<open>i \<subseteq> sbelow_halfspace sctn - guards\<close> X1X2
       by (force simp: halfspace_simps)
     subgoal by fact
     subgoal for x d using crt by simp
     subgoal by auto
     done
   from pmij have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} p1 UNIV (fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) PDP'"
     apply (rule poincare_mapsto_subset)
     using \<open>fst ` PDP' \<subseteq> Csafe\<close>
     by auto
   from this \<open>poincare_mapsto _ _ _ i PS\<close>
   have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV
       ((fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) \<union> i) (PDP' \<union> PS)"
     by (intro poincare_mapsto_unionI) (auto simp: plane_of_def)
   then have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP' \<union> PS)"
     apply (rule poincare_mapsto_subset)
     subgoal by auto
     subgoal by auto
     subgoal
       using flowpipe_source_subset[OF 1, unfolded X1X2] X1X2 
       apply (auto simp: halfspace_simps subset_iff)
       done
     subgoal using safe \<open>fst ` PS \<subseteq> Csafe\<close> by auto
     done
   moreover
   from pmij have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} p1 UNIV (fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) PDP''"
     apply (rule poincare_mapsto_subset)
     using \<open>fst ` PDP'' \<subseteq> Csafe\<close>
     by auto
   from this \<open>poincare_mapsto _ _ _ i PS2\<close>
   have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV
       ((fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) \<union> i) (PDP'' \<union> PS2)"
     by (intro poincare_mapsto_unionI) (auto simp: plane_of_def)
   then have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP'' \<union> PS2)"
     apply (rule poincare_mapsto_subset)
     subgoal by auto
     subgoal by auto
     subgoal
       using flowpipe_source_subset[OF 1, unfolded X1X2] X1X2
       apply (auto simp: halfspace_simps subset_iff)
       done
     subgoal using safe \<open>fst ` PS2 \<subseteq> Csafe\<close> by auto
     done
   ultimately
   show ?thesis
     unfolding \<open>X = A \<union> B\<close> by blast
 qed
 
 lemma do_intersection_body_spec:
   fixes guards::"'n::enum rvec set"
   assumes invar: "do_intersection_invar guards GUARDS ivl sctn X (X', T, PS, PS2, i, True, True)"
     and wdp[refine_vcg]: "wd TYPE('n rvec)"
     and X: "fst ` X \<subseteq> Csafe"
     and ivl: "closed ivl" and GUARDS: "guards \<subseteq> GUARDS"
   shows "do_intersection_body GUARDS ivl sctn h (X', T, PS, PS2, i, True, True) \<le>
     SPEC (do_intersection_invar guards GUARDS ivl sctn X)"
 proof -
   from invar
   obtain A B where AB: "fst ` (A \<union> B) \<inter> GUARDS = {} "
     "fst ` (A \<union> B) \<subseteq> sbelow_halfspace sctn "
     "ivl \<subseteq> plane_of sctn "
     "fst ` (A \<union> B) \<subseteq> i "
     "fst ` PS \<subseteq> Csafe "
     "fst ` PS2 \<subseteq> Csafe "
     "i \<subseteq> Csafe "
     "fst ` X' \<subseteq> Csafe "
     "T \<subseteq> {0..}"
     "i \<subseteq> sbelow_halfspace sctn - guards "
     "X' \<subseteq> (- guards) \<times> UNIV "
     "fst ` (PS \<union> PS2) \<inter> guards = {} "
     "0 \<notin> (\<lambda>x. ode x \<bullet> normal sctn) ` fst ` (PS \<union> PS2) "
     "\<forall>x\<in>PS \<union> PS2. \<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl "
     "X = A \<union> B "
     "flowsto A T (i \<times> UNIV) (X' \<inter> sbelow_halfspace sctn \<times> UNIV)"
     "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS "
     "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS2"
     by (auto simp: do_intersection_invar_def)
 
   have ev_in_ivl: "\<forall>\<^sub>F x in at p within plane_of sctn. x \<in> ivl" if
     \<open>\<forall>x\<in>d. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)\<close>
     \<open>\<forall>x\<in>e. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)\<close>
     \<open>(p, q) \<in> d \<or> (p, q) \<in> PS \<or> (p, q) \<in> e \<or> (p, q) \<in> PS2\<close>
     for p q d e
       using \<open>\<forall>x\<in>PS \<union> PS2. \<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl\<close>
       using that
       by (auto dest!: bspec[where x="(p, q)"])
 
   show ?thesis
     unfolding do_intersection_body_def do_intersection_invar_def
     apply simp
     apply (refine_vcg, clarsimp_all)
     subgoal using AB by (auto simp: )
     subgoal using AB by (auto simp: )
     subgoal using AB by (auto simp: )
     subgoal
       apply (rule conjI)
       subgoal using AB by auto\<comment> \<open>unnecessarily slow\<close>
       subgoal using AB by fastforce
       done
     subgoal using AB by (auto simp: )
     subgoal using AB by (auto simp: )
     subgoal using AB by (auto simp: )
     subgoal by (auto dest!: flowpipe_safeD)
     subgoal
       apply safe
       subgoal using AB GUARDS by auto
       subgoal using AB by auto
       subgoal using AB by auto
       subgoal using AB GUARDS by auto
       subgoal using AB by auto
       subgoal using AB by auto
       done
     subgoal using AB GUARDS by auto
     subgoal using AB GUARDS by auto\<comment> \<open>unnecessarily slow\<close>
     subgoal using AB GUARDS by auto
     subgoal using AB assms by (auto intro: ev_in_ivl)
     subgoal using AB assms apply - by (rule do_intersection_body_lemma)
     done
 qed
 
 lemma
   do_intersection_spec[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "do_intersection guards ivl sctn (X::'n eucl1 set) h \<le>
     SPEC (\<lambda>(inside, P, P2, CX). (inside \<longrightarrow>
       (do_intersection_spec UNIV guards ivl sctn X (P, CX) \<and>
        do_intersection_spec UNIV guards ivl sctn X (P2, CX)) \<and> fst ` X \<subseteq> CX))"
   using assms
   unfolding do_intersection_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all)
   subgoal
     unfolding do_intersection_invar_def
     apply clarsimp
     apply (intro conjI)
        apply force
       apply force
      apply force
     apply (rule exI[where x=X])
     apply (rule exI[where x="{}"])
     by (auto intro!: flowsto_self)
   subgoal by (rule do_intersection_body_spec)
   subgoal by (rule do_intersection_invar_inside, assumption) auto
   subgoal by (rule do_intersection_invar_inside, assumption) auto
   subgoal by (auto simp: plane_of_def halfspace_simps do_intersection_invar_def)
   done
 
 lemma mem_flow1_of_vec1_image_iff[simp]:
   "(c, d) \<in> flow1_of_vec1 ` a \<longleftrightarrow> vec1_of_flow1 (c, d) \<in> a"
   by force
 
 lemma mem_vec1_of_flow1_image_iff[simp]:
   "(c, d) \<in> vec1_of_flow1 ` a \<longleftrightarrow> flow1_of_vec1 (c, d) \<in> a"
   by force
 
 lemma split_spec_param1[le, refine_vcg]: "split_spec_param1 X \<le> SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"
   unfolding split_spec_param1_def
   apply (refine_vcg)
   apply (auto simp add: subset_iff split: option.splits)
   by (metis flow1_of_vec1_vec1_of_flow1 surjective_pairing)
 
 lemma do_intersection_spec_empty:
   "X = {} \<Longrightarrow> Y = {} \<Longrightarrow> do_intersection_spec S sctns ivl sctn X ({}, Y)"
   by (auto simp: do_intersection_spec_def halfspaces_union)
 
 lemma do_intersection_spec_subset:
   "do_intersection_spec S osctns ivl csctns Y (a, b) \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> do_intersection_spec S osctns ivl csctns X (a, b)"
   by (auto simp: do_intersection_spec_def halfspaces_union intro: flowsto_subset poincare_mapsto_subset)
 
 lemma do_intersection_spec_union:
   "do_intersection_spec S osctns ivl csctns a (b, c) \<Longrightarrow>
    do_intersection_spec S osctns ivl csctns f (g, h) \<Longrightarrow>
    do_intersection_spec S osctns ivl csctns (a \<union> f) (b \<union> g, c \<union> h)"
   by (auto simp: do_intersection_spec_def intro!: poincare_mapsto_unionI)
 
 lemma scaleR2_rep_of_coll[le, refine_vcg]:
   "scaleR2_rep_coll X \<le> SPEC (\<lambda>((l, u), Y). X \<subseteq> scaleR2 l u Y)"
   unfolding scaleR2_rep_coll_def
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs ((l, u), Y). \<Union>Xs \<subseteq> scaleR2 l u Y"])
   subgoal by (auto intro: scaleR2_subset)
   subgoal
     apply clarsimp
     apply safe
     subgoal by (auto elim: scaleR2_subset)
     subgoal
       apply (rule set_rev_mp, assumption)
       apply (rule order_trans)
        apply (rule Union_upper, assumption)
       apply (rule order_trans, assumption)
       apply (rule subsetI)
       apply (erule scaleR2_subset)
       by (auto )
     done
   done
 
 lemma split_spec_param1e[le, refine_vcg]: "split_spec_param1e X \<le> SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"
   unfolding split_spec_param1e_def
   apply (refine_vcg)
   apply clarsimp
     apply (thin_tac "_ \<noteq> {}")
   apply (auto simp: scaleR2_def vimage_def image_def)
   apply (rule exI, rule conjI, assumption, rule conjI, assumption)
   apply (auto simp: split_beta')
   apply (drule_tac x = x in spec)
   apply auto
   by (metis (no_types, lifting) UnE prod.sel(1) prod.sel(2) subset_eq)
 
 lemma reduce_spec1[le, refine_vcg]: "reduce_spec1 ro X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
   unfolding reduce_spec1_def
   by refine_vcg auto
 
 lemma reduce_spec1e[le, refine_vcg]: "reduce_spec1e ro X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
   unfolding reduce_spec1e_def
   by refine_vcg (auto simp: scaleR2_def image_def vimage_def, force)
 
 lemma split_under_threshold[le, refine_vcg]:
   "split_under_threshold ro th X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
   unfolding split_under_threshold_def autoref_tag_defs
   by (refine_vcg) auto
 
 lemma step_split[le, refine_vcg]:
   "wd TYPE((real, 'n::enum) vec) \<Longrightarrow> step_split ro (X::'n eucl1 set) \<le> SPEC (\<lambda>Y. X \<subseteq> Y \<and> fst ` Y \<subseteq> Csafe)"
   unfolding step_split_def
   by (refine_vcg refine_vcg) auto
 
 lemma tolerate_error_SPEC[THEN order_trans, refine_vcg]:
   "tolerate_error Y E \<le> SPEC (\<lambda>b. True)"
   unfolding tolerate_error_def
   by refine_vcg
 
 lemma flowpipe_scaleR2I: "flowpipe (scaleR2 x1 x2 bc) x1a x1a (fst ` aca \<times> UNIV) (scaleR2 x1 x2 bca)"
   if "flowpipe (bc) x1a x1a (fst ` aca \<times> UNIV) (bca)"
   using that
   apply (auto simp: flowpipe_def scaleR2_def)
   apply (drule bspec, assumption)
   apply (auto simp: image_def vimage_def )
   apply (rule exI, rule conjI, assumption, rule conjI, assumption)
   apply (rule bexI) prefer 2 apply assumption
   by (auto simp: scaleR_blinfun_compose_right)
 
 lemma choose_step1e_flowpipe[le, refine_vcg]:
   assumes vwd[refine_vcg]: "wd TYPE('n::enum rvec)"
   shows "choose_step1e (X0::'n eucl1 set) h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'n eucl1 set).
       0 < h' \<and> h' \<le> h \<and> flowpipe X0 h' h' (RES_ivl \<times> UNIV) RES)"
   unfolding choose_step1e_def
   apply (refine_vcg)
     apply (auto intro: flowpipe_scaleR2I)
   apply (erule contrapos_np)
   apply (auto intro!: flowpipe_scaleR2I)
   apply (rule flowpipe_subset)
          apply assumption
         apply (auto dest!: flowpipe_safeD)
   done
 
 lemma width_spec_appr1[THEN order_trans, refine_vcg]: "width_spec_appr1 X \<le> SPEC (\<lambda>_. True)"
   unfolding width_spec_appr1_def
   by refine_vcg
 
 lemma tolerate_error1_SPEC[THEN order_trans, refine_vcg]:
   "tolerate_error1 Y E \<le> SPEC (\<lambda>b. True)"
   unfolding tolerate_error1_def
   by refine_vcg
 
 lemma
   step_adapt_time[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "step_adapt_time (X::'n eucl1 set) h \<le> SPEC (\<lambda>(t, CX, X1, h). flowpipe X t t (CX \<times> UNIV) X1)"
   unfolding step_adapt_time_def  autoref_tag_defs
   apply (refine_vcg refine_vcg, clarsimp)
   apply (auto simp: flowpipe_def)
   apply force
   done
 
 lemma
   resolve_step[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "resolve_step roptns (X::'n::enum eucl1 set) h \<le> SPEC (\<lambda>(_, CX, X1, _).
     flowsto X {0..} (CX \<times> UNIV) X1 \<and> X \<union> X1 \<subseteq> CX \<times> UNIV \<and> X1 \<union> CX \<times> UNIV \<subseteq> Csafe \<times> UNIV)"
   unfolding resolve_step_def  autoref_tag_defs
   apply (refine_vcg refine_vcg)
   subgoal by (rule flowsto_self) auto
   subgoal by auto
   subgoal by auto
   subgoal
     apply clarsimp
     apply (frule flowpipe_imp_flowsto_nonneg)
     apply (rule flowsto_subset, assumption)
     by auto
   subgoal
     by (auto dest: flowpipe_source_subset)
   subgoal
     by (auto dest!: flowpipe_safeD)
   done
 
 lemma pre_intersection_step[THEN order_trans, refine_vcg]:
   "pre_intersection_step ro (X::'n eucl1 set) h \<le> SPEC (\<lambda>(X', CX, G). X \<subseteq> X' \<union> G \<and> X \<union> X' \<union> G \<subseteq> CX \<times> UNIV)"
   if [refine_vcg]: "wd TYPE('n::enum rvec)"
   unfolding pre_intersection_step_def autoref_tag_defs
   by (refine_vcg) auto
 
 lemma [THEN order_trans, refine_vcg]: "select_with_inter ci a \<le> SPEC (\<lambda>_. True)"
   unfolding select_with_inter_def
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>_ _. True"])
 
 lemmas [refine_vcg del] = scaleR2_rep_of_coll
 
 lemma fst_scaleR2_image[simp]: "ad \<le> ereal r \<Longrightarrow> ereal r \<le> bd \<Longrightarrow> fst ` scaleR2 ad bd be = fst ` be"
   by (cases ad; cases bd; force simp: scaleR2_def image_image split_beta' vimage_def)
 
 lemma scaleR2_rep_of_coll2[le, refine_vcg]:
   "scaleR2_rep_coll X \<le> SPEC (\<lambda>((l, u), Y). X \<subseteq> scaleR2 l u Y \<and> fst ` X = fst ` Y)"
   unfolding scaleR2_rep_coll_def
   supply [simp del] = mem_scaleR2_union
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs ((l, u), Y).
       \<Union>Xs \<subseteq> scaleR2 l u Y \<and> fst ` \<Union>Xs \<subseteq> fst ` Y \<and> fst ` Y \<subseteq> fst ` X"])
         apply (auto intro: scaleR2_subset)
   subgoal by (auto simp: scaleR2_def)
   subgoal by (auto simp: scaleR2_def image_def vimage_def, fastforce)
   subgoal
     apply (rule scaleR2_subset)
        apply (rule subsetD)
         apply assumption
        apply auto
     done
   subgoal by force
   subgoal for a b c d e f g h i j k l
     apply (rule scaleR2_subset)
        apply (rule subsetD)
         apply assumption
     by auto
   subgoal by (auto simp: scaleR2_def)
   subgoal by (auto simp: scaleR2_def)
   subgoal by (auto simp: scaleR2_def image_def vimage_def, fastforce)
   done
 
 lemma reach_cont[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "reach_cont roptns guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, G).
     G \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
     X \<union> G \<subseteq> CX \<times> UNIV \<and>
     flowsto X {0..} (CX \<times> UNIV) G)"
   using [[simproc del: defined_all]]
   unfolding reach_cont_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all simp add: cancel_times_UNIV_subset)
   subgoal by (rule flowsto_self) (auto simp: )
   subgoal by (force simp: scaleR2_def)
   subgoal by (fastforce simp: scaleR2_def vimage_def image_def)
   subgoal premises prems for _ _ _ _ _ _ _ g
     using \<open>flowsto X _ _ (g \<union> _ \<union> _)\<close>  \<open>flowsto g _ _ _\<close>
     apply (rule flowsto_stepI)
     using prems
     by auto
   subgoal
     apply safe
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     done
   subgoal by auto
   subgoal
     by (rule flowsto_subset, assumption) auto
   subgoal
     apply safe
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by fastforce
     subgoal by auto
     subgoal by auto
     subgoal
       by (metis (mono_tags, lifting) Diff_eq_empty_iff Diff_iff IntI)
     done
   subgoal
     apply safe
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     subgoal by auto
     done
   subgoal by auto
   done
 
 lemma reach_cont_par[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "reach_cont_par roptns guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, G).
     G \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
     X \<union> G \<subseteq> CX \<times> UNIV \<and>
     flowsto X {0..} (CX \<times> UNIV) G)"
   unfolding reach_cont_par_def
   apply refine_vcg
     apply auto
     apply force
     apply force
     apply force
      apply force
   subgoal
     apply (rule bexI)
      prefer 2 apply assumption
     by auto
   subgoal
     apply (rule bexI)
      prefer 2 apply assumption
     by auto
   subgoal for R
     apply (rule flowsto_source_Union)
     apply (drule bspec, assumption)
     apply auto
     apply (rule flowsto_subset, assumption)
        apply auto
     done
   done
 
 lemma subset_iplane_coll[THEN order_trans, refine_vcg]:
   "subset_iplane_coll x ics \<le> SPEC (\<lambda>b. b \<longrightarrow> x \<subseteq> ics)"
   unfolding subset_iplane_coll_def
   apply refine_vcg
   subgoal for X icss
     by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>ic b. b \<longrightarrow> X \<subseteq> \<Union>(icss)"]) auto
   done
 
 lemma subsets_iplane_coll[THEN order_trans, refine_vcg]:
   "subsets_iplane_coll x ics \<le> SPEC (\<lambda>b. b \<longrightarrow> \<Union>x \<subseteq> ics)"
   unfolding subsets_iplane_coll_def
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>x b. (b \<longrightarrow> \<Union>x \<subseteq> ics)"]) auto
 
 lemma symstart_coll[THEN order_trans, refine_vcg]:
   assumes [refine_vcg]: "wd (TYPE('n::enum rvec))"
   assumes [le, refine_vcg]:
     "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
   shows "symstart_coll symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto ((X0::'n eucl1 set) - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
   unfolding symstart_coll_def autoref_tag_defs
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X (CY, Y). flowsto (\<Union>X - trap \<times> UNIV) {0..} (CY \<times> UNIV) Y"], clarsimp_all)
   subgoal by force
   subgoal for a b c d e by (rule flowsto_subset, assumption) auto
   subgoal by force
   subgoal for a b c d e f g
     unfolding Un_Diff
     apply (rule flowsto_source_unionI)
     subgoal by (rule flowsto_subset, assumption) auto
     subgoal by (rule flowsto_subset, assumption) auto
     done
   done
 
 lemma reach_cont_symstart[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   assumes [le, refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
   shows "reach_cont_symstart roptns symstart guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, G).
     G \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
     X \<subseteq> CX \<times> UNIV \<and>
     G \<subseteq> CX \<times> UNIV \<and>
     flowsto (X - trap \<times> UNIV) {0..} (CX \<times> UNIV) (G))"
   unfolding reach_cont_symstart_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all)
   subgoal by (auto simp: times_subset_iff)
   subgoal by auto
   subgoal by auto
   subgoal for a b c d e f g
     apply (rule flowsto_stepI[OF _ _ order_refl])
          apply assumption
     by assumption auto
   done
 
 lemma reach_conts[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
   shows "reach_conts roptns symstart trap guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, IGs, X0).
     \<Union>(snd ` IGs) \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
     X \<subseteq> CX \<times> UNIV \<and>
     \<Union>(snd ` IGs) \<subseteq> CX \<times> UNIV \<and>
     \<Union>(fst ` IGs) \<subseteq> guards \<and>
     X = \<Union>(X0 ` (snd ` IGs)) \<and>
     (\<forall>(I, G) \<in> IGs. flowsto (X0 G - trap \<times> UNIV) {0..} (CX \<times> UNIV) G))"
   unfolding reach_conts_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all)
   subgoal for a b
     apply (erule flowsto_Diff_to_Union_funE)
     apply (force simp: split_beta')
     subgoal for f
       apply (rule exI[where x=f])
       by (auto simp: split_beta')
     done
   subgoal by (auto)
   subgoal by (auto)
   subgoal by (auto)
   done
 
 lemma leaves_halfspace[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "leaves_halfspace S (X::'n::enum rvec set) \<le>
     SPEC (\<lambda>b. case b of None \<Rightarrow> S = UNIV
       | Some sctn \<Rightarrow>
         (S = below_halfspace sctn \<and> X \<subseteq> plane_of sctn \<and> (\<forall>x \<in> X. ode x \<bullet> normal sctn < 0)))"
   unfolding leaves_halfspace_def autoref_tag_defs op_set_to_list_def
   apply (refine_vcg, clarsimp_all)
   subgoal by (force simp add: halfspace_simps plane_of_def)
   done
 
 lemma poincare_start_on[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "poincare_start_on guards sctn (X0::'n eucl1 set) \<le> SPEC (\<lambda>(X1S, CX1S).
     fst ` (X1S \<union> (CX1S \<times> UNIV)) \<subseteq> Csafe \<and>
     fst ` X1S \<subseteq> sbelow_halfspace sctn \<and>
     fst ` (X1S \<union> (CX1S \<times> UNIV)) \<inter> guards = {} \<and>
     (X0 \<subseteq> (CX1S \<times> UNIV)) \<and>
     (\<forall>(x, d) \<in> CX1S \<times> UNIV. ode x \<bullet> normal sctn < 0) \<and>
     flowsto X0 pos_reals ((CX1S \<times> UNIV) \<inter> (sbelow_halfspace sctn \<times> UNIV)) X1S)"
   unfolding poincare_start_on_def autoref_tag_defs
   apply refine_vcg
   apply (rule FORWEAK_mono_rule[where I="\<lambda>X0S (X1S, CX1S).
       flowsto (\<Union>X0S) pos_reals ((CX1S \<times> UNIV) \<inter> sbelow_halfspace sctn \<times> UNIV) X1S \<and>
         fst ` (X1S \<union> (CX1S \<times> UNIV)) \<subseteq> Csafe \<and>
         (\<Union>X0S) \<subseteq> X0 \<and>
         (\<Union>X0S) \<subseteq> (CX1S \<times> UNIV) \<and>
         fst ` (X1S \<union> (CX1S \<times> UNIV)) \<inter> guards = {} \<and>
         (\<forall>(x, d) \<in> (CX1S \<times> UNIV). ode x \<bullet> normal sctn < 0) \<and>
         fst ` X1S  \<subseteq> sbelow_halfspace sctn"])
   subgoal by (refine_vcg)
   subgoal for A B
     apply (refine_vcg)
     subgoal
       apply (auto simp: dest!: flowpipe_imp_flowsto)
       apply (rule flowsto_subset)
           apply (rule flowsto_stays_sbelow[where sctn=sctn])
             apply (rule flowsto_subset) apply assumption
                apply (rule order_refl)
               apply force
              apply (rule order_refl)
             apply (rule order_refl)
            apply (auto simp: halfspace_simps)
       apply (rule le_less_trans)
        prefer 2 apply assumption
       apply (drule bspec)
        apply (rule subsetD, assumption)
        prefer 2 apply assumption
       apply auto
       done
     subgoal by auto
     subgoal by force
     subgoal by (auto simp: dest!: flowpipe_source_subset)
     subgoal by auto
     subgoal
       apply (auto simp: halfspace_simps subset_iff)
       apply (rule le_less_trans[rotated], assumption)
       by fastforce
     done
   subgoal by (auto intro: flowsto_subset) force
   subgoal for a b c d
     using assms
     apply (refine_vcg, clarsimp_all)
     subgoal for e f g h i j k l m n
       apply (rule flowsto_source_unionI)
       subgoal
         apply (drule flowpipe_imp_flowsto, assumption)
         apply (rule flowsto_subset[OF flowsto_stays_sbelow[where sctn=sctn] order_refl])
              apply (rule flowsto_subset[OF _ order_refl], assumption)
                apply force
               apply (rule order_refl)
              apply (rule order_refl)
             apply (auto simp: halfspace_simps)
         apply (rule le_less_trans)
          prefer 2 apply assumption
         apply (drule bspec)
          apply (rule subsetD, assumption)
          prefer 2 apply assumption
         apply auto
         done
       by (auto intro!: flowsto_source_unionI dest!: flowpipe_imp_flowsto intro: flowsto_subset[OF _ order_refl])
     subgoal
       apply (auto simp: subset_iff)
       apply (auto simp: image_Un)
       done
     subgoal by auto
     subgoal by (auto dest!: flowpipe_source_subset)
     subgoal by auto
     subgoal
       apply (auto simp: halfspace_simps subset_iff)
       apply (rule le_less_trans[rotated], assumption)
       by fastforce
     subgoal by auto
     done
   subgoal by auto
   done
 
 lemma op_inter_fst_coll[le, refine_vcg]: "op_inter_fst_coll X Y \<le> SPEC (\<lambda>R. R = X \<inter> Y \<times> UNIV)"
   unfolding op_inter_fst_coll_def
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. \<Union>Xs \<inter> Y \<times> UNIV \<subseteq> R \<and> R \<subseteq> X \<inter> Y \<times> UNIV"])
     auto
 
 lemma scaleRe_ivl_coll_spec[le, refine_vcg]: "scaleRe_ivl_coll_spec l u X \<le> SPEC (\<lambda>Y. Y = scaleR2 l u X)"
   unfolding scaleRe_ivl_coll_spec_def
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. scaleR2 l u (\<Union>Xs) \<subseteq> R \<and> R \<subseteq> scaleR2 l u X"])
       apply (auto simp: intro: scaleR2_subset)
   subgoal
     by (force simp: intro: scaleR2_subset)
   done
 
 lemma do_intersection_spec_scaleR2I:
   "do_intersection_spec UNIV sctns ivl sctn (scaleR2 x1 x2 baa) (scaleR2 x1 x2 aca, x1b)"
   if "do_intersection_spec UNIV sctns ivl sctn (baa) (aca, x1b)"
   using that
   by (auto simp: do_intersection_spec_def intro!: poincare_mapsto_scaleR2I)
      (auto simp: scaleR2_def image_def vimage_def)
 
 lemma do_intersection_core[refine_vcg, le]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "do_intersection_core sctns ivl sctn (X::'n eucl1 set) \<le>
     SPEC (\<lambda>(P1, P2, CX, X0s).
       do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P1, CX) \<and>
       do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P2, CX)
       \<and> fst ` (X - X0s) \<subseteq> CX
       \<and> X0s \<subseteq> X)"
   unfolding do_intersection_core_def autoref_tag_defs
   apply (refine_vcg assms, clarsimp_all)
   subgoal by (rule do_intersection_spec_scaleR2I) (auto simp: do_intersection_spec_def intro!: )
   subgoal by (rule do_intersection_spec_scaleR2I) (auto simp: do_intersection_spec_def intro!: )
   subgoal by (fastforce simp: scaleR2_def)
   subgoal by (auto simp: do_intersection_spec_def)
   subgoal by (auto simp: do_intersection_spec_def)
   done
 
 lemma do_intersection_spec_Union:
   "do_intersection_spec S sctns ivl sctn (\<Union>X) A"
   if "\<And>x. x \<in> X \<Longrightarrow> do_intersection_spec S sctns ivl sctn x A"
     "X \<noteq> {}"
   using that(2)
   unfolding do_intersection_spec_def
   apply clarsimp
   apply safe
   subgoal by (rule poincare_mapsto_Union) (auto simp: do_intersection_spec_def dest!: that(1))
   subgoal by (auto simp: do_intersection_spec_def dest!: that(1))
   subgoal by (auto simp: do_intersection_spec_def dest!: that(1))
   subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
   subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
   subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
   subgoal by (force simp: do_intersection_spec_def dest!: that(1))
   subgoal by (auto simp: do_intersection_spec_def dest!: that(1))
   subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
   subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
   done
 
 lemma do_intersection_spec_subset2:
   "do_intersection_spec S p ivl sctn X1 (ab, CY) \<Longrightarrow> CY \<subseteq> CX \<Longrightarrow> CX \<subseteq> Csafe \<Longrightarrow>
     CX \<inter> p = {} \<Longrightarrow> CX \<inter> ivl \<inter> plane_of sctn = {} \<Longrightarrow> X0 \<subseteq> X1 \<Longrightarrow>
   do_intersection_spec S p ivl sctn X0 (ab, CX)"
   by (auto simp: do_intersection_spec_def intro: poincare_mapsto_subset)
 
 lemma do_intersection_spec_Union3:
   "do_intersection_spec S osctns ivl csctns (\<Union>x\<in>X. a x) ((\<Union>x\<in>X. b x), (\<Union>x\<in>X. c x))"
   if  "finite X" "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> do_intersection_spec S osctns ivl csctns (a x) (b x, c x)"
   using that
 proof induction
   case empty
   then show ?case by (auto simp: )
 next
   case (insert x F)
   show ?case
     apply (cases "F = {}")
     subgoal using insert by simp
     subgoal
       apply simp
       apply (rule do_intersection_spec_union)
        apply (rule insert.prems) apply simp
       apply (rule insert.IH)
        apply (assumption)
       apply (rule insert.prems) apply simp
       done
     done
 qed
 
 lemma do_intersection_coll[le]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "do_intersection_coll sctns ivl sctn (X::'n eucl1 set) \<le>
     SPEC (\<lambda>(P1, P2, CX, X0s).
       do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P1, CX) \<and>
       do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P2, CX)
       \<and> fst ` (X - X0s) \<subseteq> CX
       \<and> X0s \<subseteq> X)"
   unfolding do_intersection_coll_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all)
   subgoal
     apply (rule do_intersection_spec_subset[OF _ diff_subset])
     apply (rule do_intersection_spec_Union3)
     subgoal by auto
     subgoal by auto
     subgoal by auto
     done
   subgoal
     apply (rule do_intersection_spec_subset[OF _ diff_subset])
     apply (rule do_intersection_spec_Union3)
     subgoal by auto
     subgoal by auto
     subgoal by auto
     done
   subgoal by fastforce
   subgoal by fastforce
   done
 
 lemma
   do_intersection_flowsto_trans_outside:
   assumes "flowsto XS0 {0..} (CX \<times> UNIV) X1"
   assumes "do_intersection_spec UNIV guards ivl sctn X1 (P, CP)"
   assumes "fst ` X1 \<subseteq> CP"
   assumes "{x \<in> ivl. x \<in> plane_of sctn} \<inter> CX = {}"
   assumes "guards \<inter> (CX \<union> CP) = {}"
   assumes "XS0 \<subseteq> CX \<times> UNIV"
   assumes "closed ivl"
   assumes "CX \<subseteq> Csafe"
   shows "do_intersection_spec UNIV guards ivl sctn XS0 (P, CX \<union> CP)"
   using assms
   apply (auto simp: do_intersection_spec_def)
   subgoal
     apply (rule flowsto_poincare_trans, assumption, assumption)
     subgoal by simp
     subgoal by auto
     subgoal using assms(3) by auto
     subgoal by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def)
     subgoal premises prems for x d
     proof -
       have [intro, simp]: "closed {x \<in> ivl. x \<in> plane_of sctn} " "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
         by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def assms)
       from flowsto_poincare_mapsto_trans_flowsto[OF \<open>flowsto _ _ _ _\<close> \<open>poincare_mapsto _ _ _ _ _\<close> _ _ order_refl]
       have ft: "flowsto XS0 {0<..} (X1 \<union> CX \<times> UNIV \<union> CP \<times> UNIV) (fst ` P \<times> UNIV)"
         by (auto simp: )
       then have ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} x"
         apply (rule returns_to_flowstoI[OF _ _ _ _ _ _ order_refl])
         using prems by (auto simp: plane_of_def)
       have pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` P"
         apply (rule poincare_map_mem_flowstoI[OF ft])
         using prems by (auto simp: plane_of_def)
       from pm prems have "\<forall>\<^sub>F x in at (poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x) within
         plane_of sctn. x \<in> ivl"
         by auto
       from ret have "isCont (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0}) x"
         apply (rule return_time_isCont_outside)
         using prems pm
         by (auto simp: eventually_at_filter plane_of_def intro!: assms derivative_eq_intros)
       then show "isCont (return_time {x \<in> ivl. x \<in> plane_of sctn}) x" by (simp add: plane_of_def)
     qed
     subgoal by simp
     done
   done
 
 lemma do_intersection_coll_flowsto[le]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   assumes ft: "flowsto X0 {0..} (CX0 \<times> UNIV) X"
   assumes X_subset: "X \<subseteq> CX0 \<times> UNIV"
   assumes X0_subset: "X0 \<subseteq> CX0 \<times> UNIV" and CX0_safe: "CX0 \<subseteq> Csafe"
   assumes ci: "closed ivl"
   assumes disj: "ivl \<inter> plane_of sctn \<inter> CX0 = {}" "sctns \<inter> CX0 = {}"
   shows "do_intersection_coll sctns ivl sctn (X::'n eucl1 set) \<le>
     SPEC (\<lambda>(P1, P2, CX, X0s).
       \<exists>A.
         do_intersection_spec UNIV sctns ivl sctn A (P1, CX0 \<union> CX) \<and>
         do_intersection_spec UNIV sctns ivl sctn A (P2, CX0 \<union> CX) \<and>
         flowsto (X0 - A) {0..} (CX0 \<times> UNIV) X0s \<and>
         A \<subseteq> X0 \<and>
         P1 \<inter> X0s = {} \<and>
         P2 \<inter> X0s = {})"
   apply (rule do_intersection_coll)
    apply (rule wd)
 proof (clarsimp, goal_cases)
   case (1 P1 P2 CX R)
   from ft have "flowsto X0 {0..} (CX0 \<times> UNIV) (X - R \<union> R)"
     by (rule flowsto_subset) auto
   from flowsto_union_DiffE[OF this]
   obtain A where AB: "A \<subseteq> X0"
     and A: "flowsto A {0..} (CX0 \<times> UNIV) (X - R)"
     and B: "flowsto (X0 - A) {0..} (CX0 \<times> UNIV) (R)"
     by auto
   have di: "do_intersection_spec UNIV sctns ivl sctn A (P1, CX0 \<union> CX)"
     apply (rule do_intersection_flowsto_trans_outside[OF A 1(1)])
     subgoal using 1 by simp
     subgoal using disj by auto
     subgoal using 1 disj by (auto simp: do_intersection_spec_def)
     subgoal using X0_subset AB by (auto simp: do_intersection_spec_def)
     subgoal using ci by simp
     subgoal using CX0_safe .
     done
   then have "P1 \<subseteq> (ivl \<inter> plane_of sctn) \<times> UNIV"
     by (auto simp: do_intersection_spec_def)
   then have disjoint: "P1 \<inter> R = {}"
     using \<open>R \<subseteq> X\<close> disj X_subset
       apply (auto simp: subset_iff)
     by (metis (no_types, lifting) Int_iff disjoint_iff_not_equal)
 
   have di2: "do_intersection_spec UNIV sctns ivl sctn A (P2, CX0 \<union> CX)"
     apply (rule do_intersection_flowsto_trans_outside[OF A 1(2)])
     subgoal using 1 by simp
     subgoal using disj by auto
     subgoal using 1 disj by (auto simp: do_intersection_spec_def)
     subgoal using X0_subset AB by (auto simp: do_intersection_spec_def)
     subgoal using ci by simp
     subgoal using CX0_safe .
     done
   then have "P2 \<subseteq> (ivl \<inter> plane_of sctn) \<times> UNIV"
     by (auto simp: do_intersection_spec_def)
   then have "P2 \<inter> R = {}"
     using \<open>R \<subseteq> X\<close> disj X_subset
       apply (auto simp: subset_iff)
     by (metis (no_types, lifting) Int_iff disjoint_iff_not_equal)
   from AB this disjoint di di2 B show ?case
     by (auto simp:)
 qed
 
 lemma op_enlarge_ivl_sctn[le, refine_vcg]:
   "op_enlarge_ivl_sctn ivl sctn d \<le> SPEC (\<lambda>ivl'. ivl \<subseteq> ivl')"
   unfolding op_enlarge_ivl_sctn_def
   apply refine_vcg
   unfolding plane_of_def
   apply (safe intro!: eventually_in_planerectI)
   apply (auto  intro!: simp: eucl_le[where 'a='a] inner_sum_left inner_Basis if_distrib
      algebra_simps cong: if_cong)
   done
 
 lemma resolve_ivlplanes[le]:
   assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
   assumes
     "\<forall>x\<in>Xg. case x of (I, G) \<Rightarrow> flowsto (XSf G) {0..} (CXS \<times> UNIV) G"
     "(\<Union>x\<in>Xg. snd x) \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV"
     "CXS \<times> UNIV \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV"
     "(\<Union>a\<in>Xg. XSf (snd a)) \<subseteq> (CXS::'a rvec set) \<times> UNIV"
     "(\<Union>x\<in>Xg. snd x) \<subseteq> CXS \<times> UNIV"
     "(\<Union>x\<in>Xg. fst x) \<subseteq> ivlplanes \<union> guards"
   shows "resolve_ivlplanes guards ivlplanes Xg \<le> SPEC (\<lambda>PS.
     CXS \<inter> (guards \<union> ivlplanes) = {} \<and>
     CXS \<subseteq> Csafe \<and>
     (\<exists>R0 P0. (\<Union>x\<in>PS. P0 x) \<union> (\<Union>x\<in>PS. R0 x) = (\<Union>a\<in>Xg. XSf (snd a))\<and>
        (\<forall>x\<in>PS. case x of (X, P1, P2, R, ivl, sctn, CX) \<Rightarrow>
           ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl \<and>
           P0 (X, P1, P2, R, ivl, sctn, CX) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX) = {} \<and>
           R0 (X, P1, P2, R, ivl, sctn, CX) \<subseteq> (CXS \<times> UNIV) \<and>
           flowsto (R0 (X, P1, P2, R, ivl, sctn, CX)) {0..} (CXS \<times> UNIV) R \<and>
           do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P1, CXS \<union> CX) \<and>
           do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P2, CXS \<union> CX))))"
   using assms
   unfolding resolve_ivlplanes_def
   apply clarsimp_all
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xgs PS.
       (\<exists>R0 P0.
         snd ` Xgs \<subseteq> fst ` PS \<and> fst ` PS \<subseteq> snd ` Xg \<and>
         (\<forall>(X, P1, P2, R, ivl, sctn, CX) \<in> PS.
             P0 (X, P1, P2, R, ivl, sctn, CX) \<union> R0 (X, P1, P2, R, ivl, sctn, CX) = XSf X
           \<and> ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl
           \<and> P0 (X, P1, P2, R, ivl, sctn, CX) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX) = {}
           \<and> R0 (X, P1, P2, R, ivl, sctn, CX) \<subseteq> (CXS \<times> UNIV)
           \<and> flowsto (R0 (X, P1, P2, R, ivl, sctn, CX)) {0..} (CXS \<times> UNIV) R
           \<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P1, CXS \<union> CX)
           \<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P2, CXS \<union> CX)))"],
         clarsimp_all)
     using [[goals_limit=1]]
     subgoal by auto
     subgoal by auto
     subgoal for a b c
       apply (frule bspec, assumption, clarsimp)
       apply (rule do_intersection_coll_flowsto)
               apply (rule wd)
              apply assumption
             apply force
            apply force
           apply blast
          apply assumption
       subgoal premises prems
       proof -
         have "(b \<inter> plane_of c, a) \<in> Xg" using prems by simp
         with \<open>(\<Union>x\<in>Xg. fst x) \<subseteq> ivlplanes \<union> guards\<close>
         have "b \<inter> plane_of c \<subseteq> ivlplanes \<union> guards"
           by (force simp: subset_iff)
         then show ?thesis
           using \<open>CXS \<times> UNIV \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV\<close>
           by auto
       qed
       subgoal by (auto simp: subset_iff)
       subgoal apply (refine_vcg, clarsimp_all) apply force
         apply (intro exI conjI)defer defer defer apply assumption+
          apply simp
          apply force
         apply force
         apply force
         done
       done
     subgoal by (auto simp: subset_iff) blast
     subgoal for a b c d e f R0 P0
       apply (frule bspec, assumption, clarsimp)
       apply (rule do_intersection_coll_flowsto)
               apply (rule wd)
              apply assumption
       subgoal
         apply (rule order_trans[where y="(\<Union>x\<in>Xg. snd x)"]) 
         by auto
       subgoal
         apply (rule order_trans) defer apply assumption
         by auto
       subgoal by blast
       subgoal by simp
       subgoal premises prems
       proof -
         have "(d \<inter> plane_of e, c) \<in> Xg" using prems by simp
         with \<open>(\<Union>x\<in>Xg. fst x) \<subseteq> ivlplanes \<union> guards\<close>
         have "d \<inter> plane_of e \<subseteq> ivlplanes \<union> guards"
           by (force simp: subset_iff)
         then show ?thesis
           using \<open>CXS \<times> UNIV \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV\<close>
           by auto
       qed
       subgoal by (auto simp: subset_iff)
       subgoal
         apply (refine_vcg, clarsimp_all)
         subgoal by (auto simp: subset_iff)
         subgoal by (auto simp: )
         subgoal for x1 x1' x2 x3 A
           apply (rule exI[where x="R0((c, x1, x1', x3, d, e, x2):=(XSf c - A))"])
           apply (rule exI[where x="P0((c, x1, x1', x3, d, e, x2):=A)"])
           apply clarsimp
           apply (rule conjI)
           subgoal by auto
           apply (rule conjI)
           subgoal premises prems
             using prems
             apply (auto simp: subset_iff)
             by fastforce
           apply clarsimp
           subgoal
             apply (drule bspec, assumption)
             apply (drule bspec, assumption)
             by force
           done
         done
       done
     subgoal by (auto simp: subset_iff)
     subgoal by (auto simp: subset_iff)
     subgoal for a R0 P0
       apply (rule exI[where x=R0])
       apply (rule exI[where x=P0])
       apply (rule conjI)
       subgoal premises prems
       proof -
         note prems
         show ?thesis
           using prems(9,8)
           by fastforce
       qed
       by auto
     done
 
 
 lemma poincare_onto[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le>
     SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
   assumes CXS0: "CXS0 \<inter> (guards \<union> ivlplanes) = {}"
   shows "poincare_onto ro symstart trap guards ivlplanes (XS0::'a eucl1 set) CXS0 \<le>
     SPEC (\<lambda>PS.
       (\<exists>R0 P0.
         \<Union>(P0 ` PS \<union> R0 ` PS) = XS0 - trap \<times> UNIV \<and>
         (\<forall>(X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS.
             ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl
           \<and> XS0 \<subseteq> CXS \<times> UNIV \<and> CXS0 \<subseteq> CXS \<and> CXS \<inter> (guards \<union> ivlplanes) = {}
           \<and> P0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) = {}
           \<and> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> CXS \<times> UNIV
           \<and> flowsto (R0 (X, P1, P2, R, ivl, sctn, CX, CXS)) {0..} (CXS \<times> UNIV) R
           \<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX)
           \<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX))
         ))"
   unfolding poincare_onto_def autoref_tag_defs
   using [[goals_limit=1]]
   apply (refine_vcg, clarsimp_all)
   apply (refine_vcg resolve_ivlplanes[OF wd])
   subgoal by force
   apply clarsimp
   subgoal for a b c d R0 P0
     apply (rule exI[where x="\<lambda>(X, P1, P2, R, ivl, sctn, CX, CXS). R0 (X, P1, P2, R, ivl, sctn, CX)"])
     apply (rule exI[where x="\<lambda>(X, P1, P2, R, ivl, sctn, CX, CXS). P0 (X, P1, P2, R, ivl, sctn, CX)"])
     apply (rule conjI)
     subgoal premises prems
       using \<open>(\<Union>x\<in>d. P0 x) \<union> (\<Union>x\<in>d. R0 x) = (\<Union>x\<in>b. c (snd x)) - trap \<times> UNIV\<close>
       by auto
     subgoal
       apply clarsimp
       apply (drule bspec, assumption)+
       apply (rule conjI, force)
       apply (rule conjI, force)
       apply (rule conjI, force)
       apply (rule conjI)
       subgoal using CXS0 by (auto simp: )
       apply (rule conjI, force)
       apply (rule conjI, force)
       apply (rule conjI)
       subgoal by (auto intro: flowsto_subset)
       subgoal
         apply clarsimp
         apply (rule conjI)
         subgoal
           apply (rule do_intersection_spec_subset2, assumption)
           subgoal by force
           subgoal by (force simp: do_intersection_spec_def)
           subgoal using CXS0 by (auto simp: do_intersection_spec_def)
           subgoal using CXS0 by (auto simp: do_intersection_spec_def)
           subgoal by auto
           done
         subgoal
           apply (rule do_intersection_spec_subset2, assumption)
           subgoal by force
           subgoal by (force simp: do_intersection_spec_def)
           subgoal using CXS0 by (auto simp: do_intersection_spec_def)
           subgoal using CXS0 by (auto simp: do_intersection_spec_def)
           subgoal by auto
           done
         done
       done
     done
   done
 
 lemma empty_remainders[le, refine_vcg]:
   "empty_remainders PS \<le> SPEC (\<lambda>b. b \<longrightarrow> (\<forall>(X, P1, P2, R, ivl, sctn, CX) \<in> PS. R = {}))"
   unfolding empty_remainders_def
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs b. b \<longrightarrow> (\<forall>(X, P1, P2, R, ivl, sctn, CX) \<in> Xs. R = {})"])
      auto
 
 lemma poincare_onto_empty[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
   assumes CXS0: "CXS0 \<inter> (guards \<union> ivlplanes) = {}"
   shows "poincare_onto_empty ro guards ivlplanes (XS0::'a eucl1 set) CXS0 \<le>
     SPEC (\<lambda>(PS).
       (\<exists>R0 P0.
         \<Union>(P0 ` PS \<union> R0 ` PS) = XS0 \<and>
         (\<forall>(X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS.
             ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl
           \<and> XS0 \<subseteq> CXS \<times> UNIV \<and> CXS0 \<subseteq> CXS \<and> CXS \<inter> (guards \<union> ivlplanes) = {}
           \<and> P0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) = {}
           \<and> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> CXS \<times> UNIV
           \<and> flowsto (R0 (X, P1, P2, R, ivl, sctn, CX, CXS)) {0..} (CXS \<times> UNIV) R
           \<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX)
           \<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX))
         ))"
   using CXS0
   unfolding poincare_onto_empty_def autoref_tag_defs
   by (refine_vcg) (auto intro!: flowsto_self)
 
 lemma do_intersection_spec_union2:
   assumes "do_intersection_spec S osctns ivl csctns a (b, c)"
     "do_intersection_spec S osctns ivl csctns f (b, c)"
   shows "do_intersection_spec S osctns ivl csctns (a \<union> f) (b, c)"
   using do_intersection_spec_union[OF assms]
   by auto
 
 lemma poincare_onto2[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le>
     SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
   notes [refine_vcg_def] = op_set_ndelete_spec
   shows "poincare_onto2 ro symstart trap guards ivlplanes (XS0::'a eucl1 set) \<le>
     SPEC (\<lambda>(PS).
       (\<exists>P0. \<Union>(P0 ` PS) = XS0 - trap \<times> UNIV \<and>
         (\<forall>(s, X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS.
           XS0 \<subseteq> CXS \<times> UNIV \<and>
           do_intersection_spec UNIV guards ivl sctn (P0 (s, X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX) \<and>
           do_intersection_spec UNIV guards ivl sctn (P0 (s, X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX))))"
   unfolding poincare_onto2_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all)
   subgoal for PS R0 P0
     apply (rule FORWEAK_mono_rule_empty[where I="\<lambda>PS1 PS2.
       (\<exists>X0.
         \<Union>(R0 ` PS1) \<subseteq> \<Union>(X0 ` PS2) \<and>
         (\<forall>(X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS2.
           XS0 \<subseteq> CXS \<times> UNIV \<and>
           do_intersection_spec UNIV guards ivl sctn (X0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX) \<and>
           do_intersection_spec UNIV guards ivl sctn (X0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX)))"])
     subgoal by refine_vcg
     subgoal by auto
     subgoal by auto
     subgoal
       apply clarsimp
       subgoal for c
         apply (rule exI[where x=c])
         apply (rule conjI)
          apply (rule order_trans) prefer 2 apply assumption
          apply (rule UN_mono) apply assumption apply (rule order_refl) apply assumption
         done
       done
     subgoal for \<sigma>
       apply (clarsimp)
       subgoal for X0
         apply (rule exI[where x="\<lambda>(b, x). (if b then X0 x else P0 x) \<inter> XS0 - trap \<times> UNIV "])
         apply (rule conjI)
         subgoal premises prems
           using \<open>(\<Union>x\<in>PS. P0 x) \<union> (\<Union>x\<in>PS. R0 x) = XS0 - trap \<times> UNIV\<close>
             \<open>(\<Union>x\<in>PS. R0 x) \<subseteq> (\<Union>x\<in>\<sigma>. X0 x)\<close>
           by auto
         subgoal by (auto intro: do_intersection_spec_subset)
         done
       done
     apply clarsimp
     subgoal for a b b' c d e f g h i j
       apply (cases "c = {}")
       subgoal by (auto intro!: exI[where x="j"])
       subgoal
         using [[goals_limit=1]]
         apply clarsimp
         apply refine_vcg
         subgoal premises prems for k l
         proof -
           note prems
           then show ?thesis
             apply -
             apply (drule bspec, assumption)+
             apply clarsimp
             subgoal premises prems
               using \<open>g \<inter> (guards \<union> \<Union>k) = {}\<close> \<open>l = k - {d \<inter> plane_of e} \<or> l = k\<close> \<open>d \<inter> plane_of e \<subseteq> \<Union>k\<close>
               by auto
             done
         qed
         apply simp
         apply (drule bspec, assumption)
         apply simp
         apply (erule exE conjE)+
         subgoal for k l m n p q
           apply (subgoal_tac "\<And>x. x \<in> m \<Longrightarrow> p x = {}")
            defer
           subgoal for x
           proof goal_cases
             case 1
             from 1(10,15,24)
             show ?case
               by (auto dest!: bspec[where x=x])
           qed
           apply simp
           subgoal premises prems
           proof -
             note prems
             from prems have "finite (q ` m)" "flowsto (R0 (a, b, b', c, d, e, f, g)) {0..} (g \<times> UNIV) (\<Union>(q ` m))"
               by auto
             from flowsto_Union_funE[OF this]
             obtain XGs where
               XGs: "\<And>G. G \<in> q ` m \<Longrightarrow> flowsto (XGs G) {0..} (g \<times> UNIV) G"
               "R0 (a, b, b', c, d, e, f, g) = \<Union>(XGs ` (q ` m))"
               by metis
             define q0 where "q0 = XGs o q"
             have "case x of (X, P1, P2, R, ivl, sctn, CX, CXS) \<Rightarrow>
                 do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX) \<and>
                 do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX)"
               if "x \<in> m"
               for x
             proof (clarsimp, goal_cases)
               case (1 X P1 P2 R ivl sctn CX CXS)
               with prems(10)[rule_format, OF \<open>x \<in> m\<close>] prems(15)[rule_format, OF \<open>x \<in> m\<close>] \<open>_ = c\<close>
               have *: "R = {}"
                 "x = (X, P1, P2, {}, ivl, sctn, CX, CXS)"
                 "ivl \<inter> plane_of sctn \<subseteq> \<Union>l"
                 "closed ivl"
                 "c \<subseteq> CXS \<times> UNIV"
                 "g \<subseteq> CXS"
                 "\<Union>(q ` m) \<subseteq> CXS \<times> UNIV"
                 "CXS \<inter> (guards \<union> \<Union>l) = {}"
                 "p (X, P1, P2, {}, ivl, sctn, CX, CXS) = {}"
                 "p (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> CXS \<times> UNIV"
                 "do_intersection_spec UNIV guards ivl sctn (q (X, P1, P2, {}, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX)"
                 "do_intersection_spec UNIV guards ivl sctn (q (X, P1, P2, {}, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX)"
                 by auto
               have "do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, (CXS \<union> CX) \<union> (CXS \<union> CX))"
                 apply (rule do_intersection_flowsto_trans_outside)
                        apply (simp add: q0_def)
                        apply (rule flowsto_subset)
                            apply (rule XGs)
                 using \<open>x \<in> m\<close> apply (rule imageI)
                 using 1 apply force
                          apply force
                 using * apply force
                        apply (rule order_refl)
                 using * apply (auto intro!: *)[]
                 subgoal
                   using * \<open>x \<in> m\<close>
                   by (auto simp add: )
                 subgoal using * by (auto simp: do_intersection_spec_def)
                 subgoal using * by (auto simp: do_intersection_spec_def)
                 subgoal
                 proof -
                   have "q0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> XGs (q x)"
                     by (auto simp: q0_def 1)
                   also have "\<dots> \<subseteq> R0 (a, b, b', c, d, e, f, g)" using \<open>x \<in>m\<close> XGs by auto
                   also have "\<dots> \<subseteq> (CXS \<union> CX) \<times> UNIV"
                     using prems(20) \<open>g \<subseteq> CXS\<close> by auto
                   finally show ?thesis by simp
                 qed
                 subgoal by fact
                 subgoal using * by (auto simp: do_intersection_spec_def)
                 done
               moreover have "do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, (CXS \<union> CX) \<union> (CXS \<union> CX))"
                 apply (rule do_intersection_flowsto_trans_outside)
                        apply (simp add: q0_def)
                        apply (rule flowsto_subset)
                            apply (rule XGs)
                 using \<open>x \<in> m\<close> apply (rule imageI)
                 using 1 apply force
                          apply force
                 using * apply force
                        apply (rule order_refl)
                 using * apply (auto intro!: *)[]
                 subgoal
                   using * \<open>x \<in> m\<close>
                   by (auto simp add: )
                 subgoal using * by (auto simp: do_intersection_spec_def)
                 subgoal using * by (auto simp: do_intersection_spec_def)
                 subgoal
                 proof -
                   have "q0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> XGs (q x)"
                     by (auto simp: q0_def 1)
                   also have "\<dots> \<subseteq> R0 (a, b, b', c, d, e, f, g)" using \<open>x \<in>m\<close> XGs by auto
                   also have "\<dots> \<subseteq> (CXS \<union> CX) \<times> UNIV"
                     using prems(20) \<open>g \<subseteq> CXS\<close> by auto
                   finally show ?thesis by simp
                 qed
                 subgoal by fact
                 subgoal using * by (auto simp: do_intersection_spec_def)
                 done
               ultimately show ?case
                 by (simp add: )
             qed note q0 = this
             have q0': "(a, aa, aa', ab, ac, ad, ae, b) \<in> m \<Longrightarrow> XS0 \<subseteq> b \<times> UNIV" for a aa aa' ab ac ad ae b
               apply (drule prems(15)[rule_format])
               using \<open>XS0 \<subseteq> g \<times> UNIV\<close>
               by auto
             from prems
             show ?thesis
               apply (intro exI[where x="\<lambda>x. if x \<in> i \<inter> m then j x \<union> q0 x else if x \<in> i then j x else q0 x"] conjI)
               subgoal 1 premises prems
                 unfolding XGs
                 apply simp
                 by (auto simp: q0_def)
               subgoal premises _
                 by (rule order_trans[OF \<open>(\<Union>x\<in>h. R0 x) \<subseteq> (\<Union>x\<in>i. j x)\<close>]) auto
               subgoal premises _ using prems(6)[rule_format] q0
                 apply auto
                 subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
                 subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
                 subgoal by (auto intro!: do_intersection_spec_union2)
                 subgoal by (auto dest!: prems(6)[rule_format] q0' intro!: do_intersection_spec_union2)
                 subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
                 subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
                 subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
                 subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
                 done
               done
           qed
           done
         done
       done
     done
   done
 
 lemma width_spec_ivl[THEN order_trans, refine_vcg]: "width_spec_ivl M X \<le> SPEC (\<lambda>x. True)"
   unfolding width_spec_ivl_def
   by (refine_vcg)
 
 lemma partition_ivl_spec[le, refine_vcg]:
   shows "partition_ivl cg XS \<le> SPEC (\<lambda>YS. XS \<subseteq> YS)"
   using [[simproc del: defined_all]]
   unfolding partition_ivl_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all)
   subgoal by fastforce
   subgoal by fastforce
   subgoal by fastforce
   subgoal by fastforce
   subgoal premises prems for a b c d e f ws g h i j k l m n
   proof -
     note prems
     have disj: "\<And>A Aa. n \<notin> A \<or> \<not> XS \<inter> A \<subseteq> Aa \<or> n \<in> Aa"
       using prems by blast
     then have "n \<in> g"
       using prems by (metis (no_types) Un_iff atLeastAtMost_iff subset_iff)
     then show ?thesis
       using disj prems by (meson atLeastAtMost_iff)
   qed
   done
 
 lemma op_inter_fst_ivl_scaleR2[le,refine_vcg]:
   "op_inter_fst_ivl_scaleR2 X Y \<le> SPEC (\<lambda>R. X \<inter> (Y \<times> UNIV) = R)"
   unfolding op_inter_fst_ivl_scaleR2_def
   apply refine_vcg
   apply (auto simp: scaleR2_def)
   subgoal for a b c d e f g h i j k
     by (rule image_eqI[where x="(i, (j, k))"]; fastforce)
   subgoal for a b c d e f g h i j k
     by (rule image_eqI[where x="(i, (j, k))"]; fastforce)
   done
 
 lemma op_inter_fst_ivl_coll_scaleR2[le,refine_vcg]:
   "op_inter_fst_ivl_coll_scaleR2 X Y \<le> SPEC (\<lambda>R. X \<inter> (Y \<times> UNIV) = R)"
   unfolding op_inter_fst_ivl_coll_scaleR2_def
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. (\<Union>Xs) \<inter> (Y \<times> UNIV) \<subseteq> R \<and> R \<subseteq> X \<inter> (Y \<times> UNIV)"])
     auto
 
 lemma op_inter_ivl_co[le, refine_vcg]: "op_ivl_of_ivl_coll X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
   unfolding op_ivl_of_ivl_coll_def
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>R (l, u). \<Union>R \<subseteq> {l .. u}"])
    apply auto
    apply (metis Set.basic_monos(7) Sup_le_iff atLeastAtMost_iff inf.coboundedI2 inf_sup_aci(1))
   by (meson Set.basic_monos(7) UnionI atLeastAtMost_iff le_supI1)
 
 lemma op_inter_ivl_coll_scaleR2[le,refine_vcg]:
   "op_inter_ivl_coll_scaleR2 X Y \<le> SPEC (\<lambda>R. X \<inter> (Y \<times> UNIV) \<subseteq> R)"
   unfolding op_inter_ivl_coll_scaleR2_def
   apply refine_vcg
   subgoal for _ _ _ A l u
     by (auto, rule scaleR2_subset[where i'=l and j'=u and k'=A], auto)
   done
 
 lemma [le, refine_vcg]: "op_image_fst_ivl_coll X \<le> SPEC (\<lambda>R. R = fst ` X)"
   unfolding op_image_fst_ivl_coll_def
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. fst ` (\<Union>Xs) \<subseteq> R \<and> R \<subseteq> fst ` X"])
      apply auto
   apply force+
   done
 
 lemma op_single_inter_ivl[le, refine_vcg]: "op_single_inter_ivl a fxs \<le> SPEC (\<lambda>R. a \<inter> fxs \<subseteq> R)"
   unfolding op_single_inter_ivl_def
   by refine_vcg auto
 
 lemma partition_ivle_spec[le, refine_vcg]:
   shows "partition_ivle cg XS \<le> SPEC (\<lambda>YS. XS \<subseteq> YS)"
   unfolding partition_ivle_def autoref_tag_defs
   supply [refine_vcg del] = scaleR2_rep_of_coll2
     and [refine_vcg] = scaleR2_rep_of_coll
   apply (refine_vcg)
   subgoal by (fastforce simp: scaleR2_def)
   subgoal by auto
   apply clarsimp
   subgoal by (fastforce simp: scaleR2_def)
   done
 
 
 lemma vec1repse[THEN order_trans, refine_vcg]:
   "vec1repse CX \<le> SPEC (\<lambda>R. case R of None \<Rightarrow> True | Some X \<Rightarrow> X = vec1_of_flow1 ` CX)"
   unfolding vec1repse_def
   apply (refine_vcg FORWEAK_mono_rule[where
         I="\<lambda>XS R. case R of None \<Rightarrow> True | Some R \<Rightarrow> vec1_of_flow1 ` (\<Union>XS) \<subseteq> R \<and> R \<subseteq> vec1_of_flow1 ` CX"])
   apply (auto simp: scaleR2_def split: option.splits)
   subgoal for a b c d e f g h i j
     apply (auto simp: vimage_def image_def)
     apply (rule exI[where x="h"])
     apply auto
     apply (rule exI[where x=f])
     apply (rule exI[where x="matrix j"])
     apply auto
      apply (rule bexI)
     by (auto simp: vec1_of_flow1_def matrix_scaleR)
   subgoal for a b c d e f g h i j
     apply (rule bexI)
      defer apply assumption
     apply (rule image_eqI[where x="(f, g, j)"])
     by (auto simp: flow1_of_vec1_def vec1_of_flow1_def matrix_scaleR[symmetric])
   subgoal by fastforce
   subgoal for a b c d e f g h i j k l
     apply (auto simp: vimage_def image_def)
     apply (rule exI[where x="j"])
     apply auto
     apply (rule exI[where x=h])
     apply (rule exI[where x="matrix l"])
     apply auto
      apply (rule bexI)
     by (auto simp: vec1_of_flow1_def matrix_scaleR)
   subgoal by fastforce
   subgoal for a b c d e f g h i j k l
     apply (rule bexI)
      defer apply assumption
     apply (rule image_eqI[where x="(h, i, l)"])
     by (auto simp: flow1_of_vec1_def vec1_of_flow1_def matrix_scaleR[symmetric])
   done
 
 lemma scaleR2_rep1[le, refine_vcg]: "scaleR2_rep1 Y \<le> SPEC (\<lambda>R. Y \<subseteq> R)"
   unfolding scaleR2_rep1_def
   apply refine_vcg
   subgoal by (auto simp: norm2_slp_def)
   subgoal for a b c d e y z f g h i j prec k l m n p q r s
     apply (auto simp: scaleR2_def image_def vimage_def)
     subgoal premises prems for B C D E
     proof -
       define ij where "ij = (i + j) / 2"
       from prems
       have "ij > 0"
         by (auto simp: ij_def)
       show ?thesis
         unfolding ij_def[symmetric]
         apply (rule exI[where x="1 / ij * B"])
         apply (intro conjI) prefer 3
           apply (rule bexI[where x="(D, ij *\<^sub>R E)"])
         subgoal using \<open>ij > 0\<close> by auto
         subgoal
           using prems
           using \<open>(D, E) \<in> c\<close> \<open>c \<subseteq> {(n, p)..(q, r)}\<close> \<open>ij > 0\<close>
           by (auto simp: ij_def[symmetric] intro!: scaleR_left_mono)
         subgoal
           using \<open>d \<le> ereal B\<close> \<open>0 < ij\<close> \<open>0 < d\<close>
           apply (cases d)
             apply (simp only: times_ereal.simps ereal_less_eq)
             apply (rule mult_mono)
                apply (rule real_divl)
           by auto
         subgoal
           using \<open>0 < d\<close> \<open>d \<le> ereal B\<close> \<open>ereal B \<le> e\<close> \<open>0 < ij\<close> \<open>0 < e\<close>
             \<open>0 < real_divr prec 1 ((i + j) / 2)\<close>
           unfolding ij_def[symmetric]
           apply (cases e; cases d)
                   apply (simp only: times_ereal.simps ereal_less_eq)
                   apply (rule mult_mono)
                      apply (rule real_divr)
           by auto
         done
     qed
     done
   done
 
 lemma reduce_ivl[le, refine_vcg]: "reduce_ivl Y b \<le> SPEC (\<lambda>R. Y \<subseteq> R)"
   unfolding reduce_ivl_def
   apply refine_vcg
      apply (auto simp add: scaleR2_def image_def vimage_def plane_of_def )
-     prefer 2
-  subgoal using basic_trans_rules(23) by blast
-    prefer 3
-  subgoal using basic_trans_rules(23) by blast
 proof goal_cases
   case (1 i0 i1 s0 s1 y0 y1)
   from 1 have le: "1 \<le> (y1 \<bullet> b) / (i1 \<bullet> b)"
     by (auto simp: min_def dest!: inner_Basis_mono[OF _ \<open>b \<in> Basis\<close>])
   show ?case
     apply (rule exI[where x="(y1 \<bullet> b) / (i1 \<bullet> b)"])
     apply (rule conjI) apply fact
     apply (rule bexI[where x="(y0, ((i1 \<bullet> b) / (y1 \<bullet> b)) *\<^sub>R y1)"])
     subgoal using 1 le by simp
     subgoal using 1 le apply simp
       apply (rule conjI)
       subgoal
         apply (auto simp: eucl_le[where 'a="'c"])
         apply (auto simp: divide_simps)
         apply (subst mult.commute)
         subgoal for i
           apply (cases " y1 \<bullet> b \<le> i1 \<bullet> b")
            apply (rule order_trans)
             apply (rule mult_left_mono[where b="y1 \<bullet> i"])
              apply (auto simp: mult_le_cancel_right)
           apply (cases "i1 \<bullet> i \<le> 0")
            apply (rule order_trans)
             apply (rule mult_right_mono_neg[where b="i1 \<bullet> b"])
              apply auto
           by (auto simp: not_le inner_Basis split: if_splits dest!: bspec[where x=i])
         done
       subgoal
         apply (auto simp: eucl_le[where 'a="'c"])
         subgoal for i
           apply (cases "i = b")
            apply (auto simp: divide_simps)
           subgoal by (auto simp: divide_simps algebra_simps)
           subgoal apply (auto simp: divide_simps algebra_simps inner_Basis)
             apply (subst mult.commute)
             apply (rule order_trans)
              apply (rule mult_right_mono[where b="s1 \<bullet> i"]) apply simp
              apply simp
             apply (rule mult_left_mono)
             by auto
           done
         done
       done
     done
 next
   case (2 i0 i1 s0 s1 y0 y1)
   from 2 have le: "1 \<le> (y1 \<bullet> b) / (s1 \<bullet> b)"
     by (auto simp: min_def abs_real_def divide_simps dest!: inner_Basis_mono[OF _ \<open>b \<in> Basis\<close>])
   show ?case
     apply (rule exI[where x="(y1 \<bullet> b) / (s1 \<bullet> b)"])
     apply (rule conjI) apply fact
     apply (rule bexI[where x="(y0, ((s1 \<bullet> b) / (y1 \<bullet> b)) *\<^sub>R y1)"])
     subgoal using 2 le by simp
     subgoal using 2 le apply simp
       apply (rule conjI)
       subgoal
         apply (auto simp: eucl_le[where 'a="'c"])
         subgoal for i
           apply (cases "i = b")
            apply (auto simp: divide_simps)
           subgoal by (auto simp: divide_simps algebra_simps)
           subgoal apply (auto simp: divide_simps algebra_simps inner_Basis)
             apply (subst mult.commute)
             apply (cases "y1 \<bullet> i \<le> 0")
              apply (rule order_trans)
               apply (rule mult_left_mono_neg[where b="y1 \<bullet> b"])
                apply (auto simp: mult_le_cancel_right not_le)
             apply (rule order_trans)
              apply (rule mult_right_mono_neg[where b="i1 \<bullet> i"])
               apply (auto intro!: mult_left_mono_neg)
             done
           done
         done
       subgoal
         apply (auto simp: eucl_le[where 'a="'c"])
         subgoal for i
           apply (cases "i = b")
           subgoal by (auto simp: divide_simps algebra_simps)
           subgoal apply (auto simp: divide_simps algebra_simps inner_Basis)
             apply (subst mult.commute)
             apply (cases "y1 \<bullet> i \<ge> 0")
              apply (rule order_trans)
               apply (rule mult_left_mono_neg[where b="y1 \<bullet> i"]) apply simp
               apply simp
              apply (rule mult_right_mono) apply force
              apply force
           proof -
             assume a1: "\<forall>i\<in>Basis. s1 \<bullet> b * (if b = i then 1 else 0) \<le> s1 \<bullet> i"
             assume a2: "i \<in> Basis"
             assume a3: "i \<noteq> b"
             assume a4: "y1 \<bullet> b < 0"
             assume a5: "s1 \<bullet> b < 0"
             assume a6: "\<not> 0 \<le> y1 \<bullet> i"
             have "s1 \<bullet> b * (if b = i then 1 else 0) \<le> s1 \<bullet> i"
               using a2 a1 by metis
             then have f7: "0 \<le> s1 \<bullet> i"
               using a3 by (metis (full_types) mult_zero_right)
             have f8: "y1 \<bullet> b \<le> 0"
               using a4 by (metis eucl_less_le_not_le)
             have "s1 \<bullet> b \<le> 0"
               using a5 by (metis eucl_less_le_not_le)
             then show "y1 \<bullet> b * (s1 \<bullet> i) \<le> s1 \<bullet> b * (y1 \<bullet> i)"
               using f8 f7 a6 by (metis mult_right_mono_le mult_zero_left zero_le_mult_iff zero_le_square)
           qed
           done
         done
       done
     done
 qed
 
 lemma reduce_ivle[le, refine_vcg]:
   "reduce_ivle Y b \<le> SPEC (\<lambda>R. Y \<subseteq> R)"
   using [[simproc del: defined_all]]
   unfolding reduce_ivle_def
   apply refine_vcg
   apply (auto simp: scaleR2_def image_def vimage_def)
   subgoal for a b c d e f g h i j k
     apply (drule subsetD, assumption)
     apply auto
     subgoal for l m
     apply (rule exI[where x="l * g"])
       apply (intro conjI)
     subgoal
       unfolding times_ereal.simps[symmetric]
       apply (rule ereal_mult_mono)
       subgoal by (cases e) auto
       subgoal by (cases b) auto
       subgoal by (cases b) auto
       subgoal by (cases e) auto
       done
     subgoal
       unfolding times_ereal.simps[symmetric]
       apply (rule ereal_mult_mono)
       subgoal by (cases b) auto
       subgoal by (cases b) auto
       subgoal by (cases b) auto
       subgoal by (cases e) auto
       done
     subgoal by force
     done
   done
   done
 
 
 lemma reduces_ivle[le, refine_vcg]:
   "reduces_ivle X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
   unfolding reduces_ivle_def
   by refine_vcg auto
 
 lemma ivlse_of_setse[le, refine_vcg]: "ivlse_of_setse X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
   unfolding ivlse_of_setse_def
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. \<Union>Xs \<subseteq> R"])
     (auto simp: scaleR2_def image_def vimage_def)
 
 lemma setse_of_ivlse[le, refine_vcg]:
   "setse_of_ivlse X \<le> SPEC (\<lambda>R. R = X)"
   unfolding setse_of_ivlse_def
   apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. \<Union>Xs \<subseteq> R \<and> R \<subseteq> X"])
        apply clarsimp_all
   subgoal by (rule bexI)
   subgoal by auto
   subgoal by auto
   subgoal by auto
   done
 
 lemma partition_set_spec[le, refine_vcg]:
   shows "partition_set ro XS \<le> SPEC (\<lambda>YS. XS \<subseteq> YS)"
   unfolding partition_set_def autoref_tag_defs
   apply (refine_vcg)
   subgoal by (fastforce simp: scaleR2_def vimage_def image_def)
   subgoal by fastforce
   done
 
 lemma partition_sets_spec[le, refine_vcg]:
   shows "partition_sets ro XS \<le> SPEC (\<lambda>YS. (\<Union>(_, _, PS, _, _, _, _, _) \<in> XS. PS) \<subseteq> YS)"
   unfolding partition_sets_def autoref_tag_defs
   by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X Y. (\<Union>(_, _, PS, _, _, _, _, _) \<in> X. PS) \<subseteq> Y"]) auto
 
 lemma
   do_intersection_poincare_mapstos_trans:
   assumes pm: "\<And>i. i \<in> I \<Longrightarrow> poincare_mapsto (p i) (X0 i) UNIV (CX i) (X1 i)"
   assumes di: "do_intersection_spec UNIV guards ivl sctn (\<Union>i\<in>I. X1 i) (P, CP)"
   assumes "\<And>i. i \<in> I \<Longrightarrow> fst ` (X1 i) \<subseteq> CP"
   assumes "\<And>i. i \<in> I \<Longrightarrow> {x \<in> ivl. x \<in> plane_of sctn} \<inter> CX i = {}"
   assumes "\<And>i. i \<in> I \<Longrightarrow> guards \<inter> (CX i \<union> CP) = {}"
   assumes "\<And>i. i \<in> I \<Longrightarrow> X0 i \<subseteq> CX i \<times> UNIV"
   assumes "\<And>i. i \<in> I \<Longrightarrow> closed (p i)"
   assumes "closed ivl"
   assumes "\<And>i. i \<in> I \<Longrightarrow> CX i \<subseteq> Csafe"
   shows "do_intersection_spec UNIV guards ivl sctn (\<Union>i\<in>I. X0 i) (P, (\<Union>i\<in>I. CX i) \<union> CP)"
   apply (auto simp: do_intersection_spec_def)
   subgoal
     apply (simp del: UN_simps add: UN_extend_simps)
     apply (rule impI)
     apply (thin_tac "I \<noteq> {}")
     subgoal
     proof -
       from di have pmi: "poincare_mapsto {x \<in> ivl. x \<in> plane_of sctn} (X1 i) UNIV CP P" if "i \<in> I" for i
         by (auto simp: do_intersection_spec_def intro: poincare_mapsto_subset that)
       show ?thesis
         apply (rule poincare_mapsto_UnionI)
          apply (rule poincare_mapsto_trans[OF pm pmi])
                apply clarsimp_all
         subgoal s1 using assms by (auto simp: do_intersection_spec_def)
         subgoal using assms apply (auto simp: do_intersection_spec_def)
            apply blast
           by (metis (mono_tags, lifting) s1 mem_Collect_eq mem_simps(2) mem_simps(4))
         subgoal using assms by auto
         subgoal using assms by auto
         subgoal premises prems for i x d
         proof -
           note prems
           have [intro, simp]: "closed {x \<in> ivl. x \<in> plane_of sctn} " "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
             by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def assms)
           have set_eq: "(CX i \<union> CP) \<times> UNIV = (fst ` X1 i \<times> UNIV \<union> CX i \<times> UNIV \<union> CP \<times> UNIV)"
             using assms prems
             by auto
           have empty_inter: "{x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} \<times> UNIV \<inter> (CX i \<union> CP) \<times> UNIV = {}"
             apply safe
             subgoal
               using assms(4)[of i] \<open>i \<in> I\<close>
               by (auto simp: plane_of_def )
             subgoal
               using assms(4)[of i]
               using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             done
           have ft: "flowsto (X0 i) {0<..} ((CX i \<union> CP) \<times> UNIV) (fst ` P \<times> UNIV)"
             unfolding set_eq
             apply (rule flowsto_poincare_mapsto_trans_flowsto[OF poincare_mapsto_imp_flowsto[OF pm[OF \<open>i \<in> I\<close>]]
                   pmi[OF \<open>i \<in> I\<close>] _ _ order_refl])
             using assms prems by (auto)
           then have ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} x"
             apply (rule returns_to_flowstoI[OF _ _ _ _ _ _ order_refl])
             subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             subgoal by (rule empty_inter)
             subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             done
           have pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` P"
             apply (rule poincare_map_mem_flowstoI[OF ft])
             subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             subgoal using empty_inter by simp
             subgoal by auto
             subgoal by auto
             subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
             subgoal by auto
             done
           from ret have "isCont (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0}) x"
             apply (rule return_time_isCont_outside)
             subgoal by fact
                 apply (force intro!: derivative_eq_intros)
             subgoal by (auto intro!: continuous_intros)
             subgoal using prems pm assms by (auto simp: do_intersection_spec_def)
             subgoal using prems pm assms
               by (auto simp: eventually_at_filter plane_of_def do_intersection_spec_def)
             subgoal
             proof -
               have "x \<in> CX i" using \<open>_ \<in> I \<Longrightarrow> X0 _ \<subseteq> CX _ \<times> UNIV\<close>[OF \<open>i \<in> I\<close>] \<open>(x, _) \<in> _\<close>
                 by auto
               with assms(4)[OF \<open>i \<in> I\<close>] show ?thesis
                 by (auto simp: plane_of_def)
             qed
             done
           then show "isCont (return_time {x \<in> ivl. x \<in> plane_of sctn}) x" by (simp add: plane_of_def)
         qed
         done
     qed
     done
   subgoal using assms by (fastforce simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (fastforce simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms(9) by (fastforce simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
   done
 
 lemma flow_in_stable_setD:
   "flow0 x0 t \<in> stable_set trap \<Longrightarrow> t \<in> existence_ivl0 x0 \<Longrightarrow> x0 \<in> stable_set trap"
   apply (auto simp: stable_set_def)
 proof goal_cases
   case (1 s)
   then show ?case
     apply (cases "s \<le> t")
     apply (meson atLeastAtMost_iff contra_subsetD local.ivl_subset_existence_ivl)
     using contra_subsetD local.existence_ivl_reverse local.existence_ivl_trans' local.flows_reverse by fastforce
 next
   case (2)
   have "((\<lambda>s. flow0 x0 (t + s)) \<longlongrightarrow> trap) (at_top)"
   proof (rule Lim_transform_eventually)
     have "\<forall>\<^sub>F x in at_top. x > max t 0"
       by (simp add: max_def)
     then show "\<forall>\<^sub>F x in at_top. flow0 (flow0 x0 t) x = flow0 x0 (t + x)"
       apply eventually_elim
       apply (subst flow_trans)
       using 2
       by auto
   qed (use 2 in auto)
   then show ?case by (simp add: tendsto_at_top_translate_iff ac_simps)
 qed
 
 lemma
   poincare_mapsto_avoid_trap:
   assumes "poincare_mapsto p (X0 - trap \<times> UNIV) S CX P"
   assumes "closed p"
   assumes trapprop[THEN stable_onD]: "stable_on (CX \<union> fst ` P) trap"
   shows "poincare_mapsto p (X0 - trap \<times> UNIV) S CX (P - trap \<times> UNIV)"
   using assms(1,2)
   apply (auto simp: poincare_mapsto_def)
   apply (drule bspec, force)
   apply auto
   subgoal for x0 d0 D
     apply (rule exI[where x=D])
     apply (auto dest!: trapprop simp: poincare_map_def intro!: return_time_exivl assms(1,2) return_time_pos)
     subgoal for s
       by (cases "s = return_time p x0") (auto simp: )
     done
   done
 
 lemma poincare_onto_series[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
   assumes trapprop: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
   shows "poincare_onto_series symstart trap guards (X0::'a eucl1 set) ivl sctn ro \<le>
        SPEC (\<lambda>XS. do_intersection_spec UNIV {} ivl sctn (X0 - trap \<times> UNIV)
           (XS, Csafe - (ivl \<inter> plane_of sctn)) \<and>
           fst ` X0 - trap \<subseteq> Csafe - (ivl \<inter> plane_of sctn))"
 proof (induction guards arbitrary: X0)
   case Nil
   then show ?case
     apply (simp add:)
     apply refine_vcg
     apply (clarsimp simp add: ivlsctn_to_set_def)
      apply (rule do_intersection_spec_subset2, assumption)
     subgoal by (auto simp: do_intersection_spec_def)
     subgoal by (auto simp: do_intersection_spec_def)
     subgoal by (auto simp: do_intersection_spec_def)
     subgoal by (auto simp: do_intersection_spec_def)
     subgoal by (auto simp: do_intersection_spec_def)
     subgoal by (auto simp: do_intersection_spec_def)
     done
 next
   case (Cons a guards)
   note Cons.IH[simplified, le, refine_vcg]
   show ?case
     supply [[simproc del: defined_all]]
     apply auto
     apply refine_vcg
      apply clarsimp_all
      defer
     subgoal premises prems for b c d e f g h
     proof -
       from prems have "(f, g) \<in> (\<Union>x\<in>c. h x)"
         by auto
       then obtain x where "x \<in> c" "(f, g) \<in> (h x)"
         by auto
       then show ?thesis
         using prems(14)[rule_format, OF \<open>x \<in> c\<close>] prems(5-7)
         by (cases x) (auto simp: do_intersection_spec_def)
     qed
     subgoal premises prems for c ro d e f
     proof -
       let ?s = "trap \<times> UNIV"
       note prems
       from \<open>do_intersection_spec _ _ _ _ _ _ \<close>
       have disro: "do_intersection_spec UNIV {} ivl sctn ((\<Union>i\<in>ro. case i of (_, _, PS, _, _, _, _, _, _) \<Rightarrow> PS - ?s))
           (e, Csafe - ivl \<inter> plane_of sctn)"
         apply (rule do_intersection_spec_subset)
         using prems by auto
       have subset: "(Csafe - ivl \<inter> plane (normal sctn) (pstn sctn)) \<supseteq>
         (snd (snd (snd (snd (snd (snd (snd (snd i))))))) \<union>
         fst (snd (snd (snd (snd (snd (snd (snd i))))))) \<union> fst ` fst (snd (snd i)))" if "i \<in> ro" for i
         using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that]
         apply (clarsimp )
         subgoal for s X P1 P2 R ivla sctna CX CXS
           apply (rule conjI)
           subgoal by (auto simp: plane_of_def)
           subgoal by (auto simp: plane_of_def)
           done
         done
       have pmro: "poincare_mapsto
             (case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> {x \<in> ivla. x \<in> plane_of sctna})
             (f i - ?s) UNIV
             (case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> CXS \<union> CX)
             (case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> P1)"
         if "i \<in> ro"
         for i
         using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that]
         by (auto intro: poincare_mapsto_subset)
       then have pmro: "poincare_mapsto
             (case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> {x \<in> ivla. x \<in> plane_of sctna})
             (f i - ?s) UNIV
             (case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> CXS \<union> CX)
             (case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> P1 - ?s)"
         if "i \<in> ro"
         for i
         unfolding split_beta'
         apply (rule poincare_mapsto_avoid_trap)
         using that prems assms
         by (auto intro!: closed_levelset_within continuous_intros
             stable_on_mono[OF _ subset]
             simp: plane_of_def)
       have "do_intersection_spec UNIV {} ivl sctn (\<Union>i\<in>ro. f i - ?s)
         (e, (\<Union>i\<in>ro. case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> CXS \<union> CX) \<union>
         (Csafe - ivl \<inter> plane_of sctn))"
         apply (rule do_intersection_poincare_mapstos_trans[OF pmro disro])
         subgoal by auto
         subgoal premises that for i
           using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that] using [[simproc del: defined_all]]
           by (auto simp: do_intersection_spec_def)
         subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
         subgoal by auto
         subgoal premises that for i
           using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that]
             prems(11) that
           by (auto simp: do_intersection_spec_def)
         subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
         subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
         subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
         done
       then show ?thesis
         unfolding \<open>(\<Union>x\<in>ro. f x) = X0 - trap \<times> UNIV\<close>
         apply (rule do_intersection_spec_subset2)
         subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
         using prems
         by (auto simp: do_intersection_spec_def intro: poincare_mapsto_subset)
     qed
     done
 qed
 
 lemma
   do_intersection_flowsto_trans_return:
   assumes "flowsto XS0 {0<..} (CX \<times> UNIV) X1"
   assumes "do_intersection_spec UNIV guards ivl sctn X1 (P, CP)"
   assumes "fst ` X1 \<subseteq> CP"
   assumes "{x \<in> ivl. x \<in> plane_of sctn} \<inter> CX = {}"
   assumes "guards \<inter> (CX \<union> CP) = {}"
   assumes "closed ivl"
   assumes "CX \<subseteq> sbelow_halfspace sctn \<inter> Csafe"
   assumes subset_plane: "fst ` XS0 \<subseteq> plane_of sctn \<inter> ivl"
   assumes down: "\<And>x d. (x, d) \<in> XS0 \<Longrightarrow> ode x \<bullet> normal sctn < 0" "\<And>x. x \<in> CX \<Longrightarrow> ode x \<bullet> normal sctn < 0"
   shows "do_intersection_spec (below_halfspace sctn) guards ivl sctn XS0 (P, CX \<union> CP)"
   using assms
   apply (auto simp: do_intersection_spec_def)
   subgoal
     apply (rule flowsto_poincare_trans, assumption, assumption)
     subgoal by simp
     subgoal by auto
     subgoal using assms(3) by auto
     subgoal by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def)
      prefer 2
     subgoal by (auto simp add: plane_of_def halfspace_simps)
     subgoal premises prems for x d
     proof -
       have [intro, simp]: "closed {x \<in> ivl. x \<in> plane_of sctn} " "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
         by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def assms)
       from subset_plane have "fst ` XS0 \<subseteq> below_halfspace sctn" by (auto simp: )
       from flowsto_stays_sbelow[OF \<open>flowsto _ _ _ _\<close> this down(2)]
       have ft_below: "flowsto XS0 pos_reals (CX \<times> UNIV \<inter> sbelow_halfspace sctn \<times> UNIV) X1"
         by auto
       from flowsto_poincare_mapsto_trans_flowsto[OF ft_below \<open>poincare_mapsto _ _ _ _ _\<close> _ _ order_refl]
       have ft: "flowsto XS0 {0<..} (X1 \<union> CX \<times> UNIV \<inter> sbelow_halfspace sctn \<times> UNIV \<union> CP \<times> UNIV) (fst ` P \<times> UNIV)"
         by (auto simp: )
       have ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} x"
         apply (rule returns_to_flowstoI[OF ft])
         using prems by (auto simp: plane_of_def halfspace_simps)
       have pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` P"
         apply (rule poincare_map_mem_flowstoI[OF ft])
         using prems by (auto simp: plane_of_def halfspace_simps)
       from pm prems have evmem: "\<forall>\<^sub>F x in at (poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x) within
         plane_of sctn. x \<in> ivl"
         by auto
       from ret have "continuous (at x within {x. x \<bullet> normal sctn - pstn sctn \<le> 0})
         (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0})"
         apply (rule return_time_continuous_below)
                apply (rule derivative_eq_intros refl)+
                apply force
         subgoal using \<open>closed ivl\<close> by auto
         subgoal using prems pm by (auto simp: plane_of_def eventually_at_filter)
         subgoal by (auto intro!: )
         subgoal using prems pm by auto
         subgoal using prems by auto
         subgoal using prems pm by (auto intro!: assms simp: plane_of_def)
         subgoal using prems pm by auto
         done
       then show "continuous (at x within below_halfspace sctn) (return_time {x \<in> ivl. x \<in> plane_of sctn})"
         by (simp add: plane_of_def halfspace_simps)
     qed
     done
   done
 
 lemma do_intersection_spec_sctn_cong:
   assumes "sctn = sctn' \<or> (normal sctn = - normal sctn' \<and> pstn sctn = - pstn sctn')"
   shows "do_intersection_spec a b c sctn d e = do_intersection_spec a b c sctn' d e"
   using assms
   by (auto simp: do_intersection_spec_def plane_of_def set_eq_iff intro!: )
 
 lemma poincare_onto_from[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
   assumes trapprop: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
   shows "poincare_onto_from symstart trap S guards ivl sctn ro (XS0::'a eucl1 set) \<le>
     SPEC (poincare_mapsto (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe - ivl \<inter> plane_of sctn))"
   unfolding poincare_onto_from_def autoref_tag_defs
   apply (refine_vcg, clarsimp_all simp: trapprop)
   subgoal by (auto simp: do_intersection_spec_def Int_def intro: poincare_mapsto_subset)
   subgoal premises prems for a b c d e f
   proof -
     note prems
     from trapprop
     have stable: "stable_on (fst ` (e \<times> UNIV \<inter> sbelow_halfspace a \<times> UNIV \<union> d)) trap"
       apply (rule stable_on_mono)
       using \<open>fst ` (d \<union> e \<times> UNIV) \<subseteq> Csafe\<close> \<open>a = sctn \<or> normal a = - normal sctn \<and> pstn a = - pstn sctn\<close>
         \<open>fst ` d \<subseteq> sbelow_halfspace a\<close>
       by (auto simp: halfspace_simps plane_of_def image_Un)
     from prems(16) have "flowsto (XS0 - trap \<times> UNIV) {0<..} (e \<times> UNIV \<inter> sbelow_halfspace a \<times> UNIV) d"
       by (rule flowsto_subset) auto
     then have ft: "flowsto (XS0 - trap \<times> UNIV) {0<..} ((e \<inter> sbelow_halfspace a) \<times> UNIV) (d - trap \<times> UNIV)"
       by (auto intro!: flowsto_mapsto_avoid_trap stable simp: Times_Int_distrib1)
     from prems(8) have di: "do_intersection_spec UNIV {} ivl a (d - trap \<times> UNIV) (f, Csafe - ivl \<inter> plane_of sctn)"
       apply (subst do_intersection_spec_sctn_cong)
        defer apply assumption
       using prems(2)
       by auto
     have "do_intersection_spec (below_halfspace a) {} ivl a (XS0 - trap \<times> UNIV)
          (f, e \<inter> sbelow_halfspace a \<union> (Csafe - ivl \<inter> plane_of sctn))"
       apply (rule do_intersection_flowsto_trans_return[OF ft di])
       subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
       subgoal by (auto simp: halfspace_simps plane_of_def)
       subgoal using prems by (auto simp: halfspace_simps plane_of_def)
       subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
       subgoal using prems by (auto simp: image_Un)
       subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
       subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
       subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
       done
     moreover have "plane_of a = plane_of sctn"
       using prems(2) by (auto simp: plane_of_def)
     ultimately show ?thesis
       apply (auto simp add: do_intersection_spec_def Int_def)
       apply (rule poincare_mapsto_subset, assumption)
       by auto
   qed
   done
 
 lemma subset_spec1[refine_vcg]: "subset_spec1 R P dP \<le> SPEC (\<lambda>b. b \<longrightarrow> R \<subseteq> flow1_of_vec1 ` (P \<times> dP))"
   unfolding subset_spec1_def
   by refine_vcg (auto simp: vec1_of_flow1_def)
 
 
 lemma subset_spec1_coll[le, refine_vcg]:
   "subset_spec1_coll R P dP \<le> subset_spec R (flow1_of_vec1 ` (P \<times> dP))"
   unfolding autoref_tag_defs subset_spec_def subset_spec1_coll_def
   by (refine_vcg) (auto simp: subset_iff set_of_ivl_def)
 
 lemma one_step_until_time_spec[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "one_step_until_time (X0::'n eucl1 set) CX t1 \<le> SPEC (\<lambda>(R, CX).
     (\<forall>(x0, d0) \<in> X0. t1 \<in> existence_ivl0 x0 \<and>
       (flow0 x0 t1, Dflow x0 t1 o\<^sub>L d0) \<in> R \<and>
       (\<forall>t \<in> {0 .. t1}. flow0 x0 t \<in> CX)) \<and>
       fst ` R \<union> CX \<subseteq> Csafe)"
   using [[simproc del: defined_all]]
   unfolding one_step_until_time_def autoref_tag_defs
   apply (refine_vcg WHILE_rule[where I="\<lambda>(t, h, X, CX). fst ` X \<subseteq> Csafe \<and> CX \<subseteq> Csafe \<and> 0 \<le> h \<and> 0 \<le> t \<and> t \<le> t1 \<and>
         (\<forall>(x0, d0) \<in> X0. t \<in> existence_ivl0 x0 \<and>
           (flow0 x0 t, Dflow x0 t o\<^sub>L d0) \<in> X \<and>
           (\<forall>s \<in> {0 .. t}. flow0 x0 s \<in> CX))"])
   subgoal by auto
   subgoal by (force simp: flowpipe_def existence_ivl_trans flow_trans)
   subgoal by (auto simp: flowpipe_def existence_ivl_trans flow_trans)
   apply clarsimp subgoal for startstep rk2_param a b c d e f g h i j
     apply (safe)
     subgoal by (auto simp: flowpipe_def intro!: existence_ivl_trans flow_trans)
     subgoal
       apply (subst flow_trans, force)
       subgoal by (auto simp: flowpipe_def intro!: existence_ivl_trans flow_trans)
       apply (subst Dflow_trans, force)
       subgoal by (auto simp: flowpipe_def intro!: existence_ivl_trans flow_trans)
       by (auto simp: blinfun_compose_assoc flowpipe_def)
     subgoal for s
       apply (drule bspec[where x="(i, j)"], assumption)
       apply auto
       apply (cases "s \<le> a")
       subgoal by auto
       subgoal
         apply (auto simp: blinfun_compose_assoc flowpipe_def)
         apply (drule bspec, assumption)
         apply auto
       proof goal_cases
         case 1
         have a: "a \<in> existence_ivl0 i" using 1 by auto
         have sa: "s - a \<in> existence_ivl0 (flow0 i a)"
           using "1"(15) "1"(19) "1"(20) local.ivl_subset_existence_ivl by fastforce
         have "flow0 i s = flow0 (flow0 i a) (s - a)"
           by (auto simp: a sa flow_trans[symmetric])
         also have "\<dots> \<in> f"
           using 1 by auto
         finally show ?case
           using 1 by simp
       qed
       done
     done
   subgoal by auto
   done
 
 text \<open>solve ODE until the time interval \<open>{t1 .. t2}\<close>\<close>
 
 lemma ivl_of_eucl1_coll[THEN order_trans, refine_vcg]: "ivl_of_eucl_coll X \<le> SPEC (\<lambda>R. X \<times> UNIV \<subseteq> R)"
   unfolding ivl_of_eucl_coll_def
   by refine_vcg auto
 
 lemma one_step_until_time_ivl_spec[le, refine_vcg]:
   assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
   shows "one_step_until_time_ivl (X0::'n eucl1 set) CX t1 t2 \<le> SPEC (\<lambda>(R, CX).
     (\<forall>(x0, d0) \<in> X0. {t1 .. t2} \<subseteq> existence_ivl0 x0 \<and>
       (\<forall>t \<in> {t1 .. t2}. (flow0 x0 t, Dflow x0 t o\<^sub>L d0) \<in> R) \<and>
       (\<forall>t \<in> {0 .. t1}. (flow0 x0 t) \<in> CX)) \<and>
       fst ` R \<union> CX \<subseteq> Csafe)"
   unfolding one_step_until_time_ivl_def
   apply (refine_vcg, clarsimp_all)
   subgoal for X CX Y CY CY' x0 d0
     apply (drule bspec, assumption, clarsimp)
     apply (drule bspec, assumption, clarsimp simp add: nonneg_interval_mem_existence_ivlI)
     apply (rule subsetD, assumption)
     subgoal for t
       apply (drule bspec[where x=0], force)
       apply (drule bspec[where x="t - t1"], force)
       using interval_subset_existence_ivl[of t1 x0 t2]
       by (auto simp: flow_trans')
     done
   done
 
 lemma empty_symstart_flowsto:
   "X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow>
     RETURN ({}, X0) \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - {} \<times> UNIV) {0..} (CX \<times> UNIV) X)"
   by (auto intro!: flowsto_self)
 
 subsection \<open>Poincare map returning to\<close>
 
 lemma poincare_onto_from_ivla[le, refine_vcg]:
   assumes [refine_vcg]: "wd TYPE('n::enum rvec)"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
   assumes trapprop[refine_vcg]: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
   shows "poincare_onto_from symstart trap S guards ivl sctn ro (XS0::'n eucl1 set) \<le> SPEC
      (\<lambda>P.
         wd TYPE((real, 'n) vec) \<and>
         poincare_mapsto (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe - ivl \<inter> plane_of sctn) P)"
   by (refine_vcg)
 
 subsection \<open>Poincare map onto (from outside of target)\<close>
 
 subsection \<open>One step method (reachability in time)\<close>
 
 lemma c0_info_of_apprsI:
   assumes "(b, a) \<in> clw_rel appr_rel"
   assumes "x \<in> a"
   shows "x \<in> c0_info_of_apprs b"
   using assms
   by (auto simp: appr_rel_br clw_rel_br c0_info_of_apprs_def c0_info_of_appr_def dest!: brD)
 
 lemma c0_info_of_appr'I:
   assumes "(b, a) \<in> \<langle>clw_rel appr_rel\<rangle>phantom_rel"
   assumes "x \<in> a"
   shows "x \<in> c0_info_of_appr' b"
   using assms
   by (auto simp add: c0_info_of_appr'_def intro!: c0_info_of_apprsI split: option.splits)
 
 lemma poincare_onto_from_in_ivl[le, refine_vcg]:
   assumes [refine_vcg]: "wd TYPE('n::enum rvec)"
   assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
   assumes trapprop: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
   shows "poincare_onto_from_in_ivl symstart trap S guards ivl sctn ro (XS0::'n::enum eucl1 set) P dP \<le>
     SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe - ivl \<inter> plane_of sctn) (flow1_of_vec1 ` (P \<times> dP)))"
   unfolding poincare_onto_from_in_ivl_def
   apply (refine_vcg, clarsimp_all)
    apply (rule trapprop)
   apply (rule poincare_mapsto_subset)
       apply assumption
   by (auto simp: )
 
 lemma lvivl_default_relI:
   "(dRi, set_of_lvivl' dRi::'e::executable_euclidean_space set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
   if "lvivl'_invar DIM('e) dRi"
   using that
   by (auto simp: set_of_lvivl'_def set_of_lvivl_def set_of_ivl_def lvivl'_invar_def
       intro!: mem_default_relI lvivl_relI)
 
 lemma stable_on_empty[simp]: "stable_on A {}"
   by (auto simp: stable_on_def)
 
 lemma poincare_onto_in_ivl[le, refine_vcg]:
   assumes [simp]: "length (ode_e) = CARD('n::enum)"
   shows "poincare_onto_in_ivl guards ivl sctn ro (XS0::'n::enum eucl1 set) P dP \<le>
     SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto (ivl \<inter> plane_of sctn) (XS0) UNIV (Csafe - ivl \<inter> plane_of sctn) (flow1_of_vec1 ` (P \<times> dP)))"
 proof -
   have wd[refine_vcg]: "wd TYPE((real, 'n) vec)" by (simp add: wd_def)
   show ?thesis
     unfolding poincare_onto_in_ivl_def
     apply (refine_vcg)
     subgoal by (auto intro!: flowsto_self)
     subgoal
       apply (clarsimp simp add: do_intersection_spec_def Int_def[symmetric])
       apply (rule poincare_mapsto_subset)
           apply assumption
       by auto
     done
 qed
 
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Simplex/Simplex.thy b/thys/Simplex/Simplex.thy
--- a/thys/Simplex/Simplex.thy
+++ b/thys/Simplex/Simplex.thy
@@ -1,8324 +1,8326 @@
 (* Authors: F. Maric, M. Spasic, R. Thiemann *)
 section \<open>The Simplex Algorithm\<close>
 
 theory Simplex
   imports
     Linear_Poly_Maps
     QDelta
     Rel_Chain
     Simplex_Algebra
     "HOL-Library.Multiset"
     "HOL-Library.RBT_Mapping"
     "HOL-Library.Code_Target_Numeral"
 begin
 
 text\<open>Linear constraints are of the form \<open>p \<bowtie> c\<close> or \<open>p\<^sub>1 \<bowtie> p\<^sub>2\<close>, where \<open>p\<close>, \<open>p\<^sub>1\<close>, and \<open>p\<^sub>2\<close>, are
 linear polynomials, \<open>c\<close> is a rational constant and \<open>\<bowtie> \<in>
 {<, >, \<le>, \<ge>, =}\<close>. Their abstract syntax is given by the \<open>constraint\<close> type, and semantics is given by the relation \<open>\<Turnstile>\<^sub>c\<close>, defined straightforwardly by primitive recursion over the
 \<open>constraint\<close> type. A set of constraints is satisfied,
 denoted by \<open>\<Turnstile>\<^sub>c\<^sub>s\<close>, if all constraints are. There is also an indexed
 version \<open>\<Turnstile>\<^sub>i\<^sub>c\<^sub>s\<close> which takes an explicit set of indices and then only
 demands that these constraints are satisfied.\<close>
 
 datatype constraint = LT linear_poly rat
   | GT linear_poly rat
   | LEQ linear_poly rat
   | GEQ linear_poly rat
   | EQ linear_poly rat
   | LTPP linear_poly linear_poly
   | GTPP linear_poly linear_poly
   | LEQPP linear_poly linear_poly
   | GEQPP linear_poly linear_poly
   | EQPP linear_poly linear_poly
 
 text \<open>Indexed constraints are just pairs of indices and constraints. Indices will be used
   to identify constraints, e.g., to easily specify an unsatisfiable core by a list of indices.\<close>
 
 type_synonym 'i i_constraint = "'i \<times> constraint"
 
 abbreviation (input) restrict_to :: "'i set \<Rightarrow> ('i \<times> 'a) set \<Rightarrow> 'a set" where
   "restrict_to I xs \<equiv> snd ` (xs \<inter> (I \<times> UNIV))"
 
 text \<open>The operation @{const restrict_to} is used to select constraints for a given index set.\<close>
 
 abbreviation (input) flat :: "('i \<times> 'a) set \<Rightarrow> 'a set" where
   "flat xs \<equiv> snd ` xs"
 
 text \<open>The operation @{const flat} is used to drop indices from a set of indexed constraints.\<close>
 
 abbreviation (input) flat_list :: "('i \<times> 'a) list \<Rightarrow> 'a list" where
   "flat_list xs \<equiv> map snd xs"
 
 primrec
   satisfies_constraint :: "'a :: lrv valuation \<Rightarrow> constraint \<Rightarrow> bool"  (infixl "\<Turnstile>\<^sub>c" 100) where
   "v \<Turnstile>\<^sub>c (LT l r) \<longleftrightarrow> (l\<lbrace>v\<rbrace>) < r *R 1"
 | "v \<Turnstile>\<^sub>c GT l r \<longleftrightarrow> (l\<lbrace>v\<rbrace>) > r *R 1"
 | "v \<Turnstile>\<^sub>c LEQ l r \<longleftrightarrow> (l\<lbrace>v\<rbrace>) \<le> r *R 1"
 | "v \<Turnstile>\<^sub>c GEQ l r \<longleftrightarrow> (l\<lbrace>v\<rbrace>) \<ge>  r *R 1"
 | "v \<Turnstile>\<^sub>c EQ l r \<longleftrightarrow> (l\<lbrace>v\<rbrace>) = r *R 1"
 | "v \<Turnstile>\<^sub>c LTPP l1 l2 \<longleftrightarrow> (l1\<lbrace>v\<rbrace>) < (l2\<lbrace>v\<rbrace>)"
 | "v \<Turnstile>\<^sub>c GTPP l1 l2 \<longleftrightarrow> (l1\<lbrace>v\<rbrace>) > (l2\<lbrace>v\<rbrace>)"
 | "v \<Turnstile>\<^sub>c LEQPP l1 l2 \<longleftrightarrow> (l1\<lbrace>v\<rbrace>) \<le> (l2\<lbrace>v\<rbrace>)"
 | "v \<Turnstile>\<^sub>c GEQPP l1 l2 \<longleftrightarrow> (l1\<lbrace>v\<rbrace>) \<ge> (l2\<lbrace>v\<rbrace>)"
 | "v \<Turnstile>\<^sub>c EQPP l1 l2 \<longleftrightarrow> (l1\<lbrace>v\<rbrace>) = (l2\<lbrace>v\<rbrace>)"
 
 
 abbreviation satisfies_constraints :: "rat valuation \<Rightarrow> constraint set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>c\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>c\<^sub>s cs \<equiv> \<forall> c \<in> cs. v \<Turnstile>\<^sub>c c"
 
 lemma unsat_mono: assumes "\<not> (\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s cs)"
   and "cs \<subseteq> ds"
 shows "\<not> (\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s ds)"
   using assms by auto
 
 fun i_satisfies_cs (infixl "\<Turnstile>\<^sub>i\<^sub>c\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s cs \<longleftrightarrow> v \<Turnstile>\<^sub>c\<^sub>s restrict_to I cs"
 
 definition distinct_indices :: "('i \<times> 'c) list \<Rightarrow> bool" where
   "distinct_indices as = (distinct (map fst as))"
 
 lemma distinct_indicesD: "distinct_indices as \<Longrightarrow> (i,x) \<in> set as \<Longrightarrow> (i,y) \<in> set as \<Longrightarrow> x = y"
   unfolding distinct_indices_def by (rule eq_key_imp_eq_value)
 
 text \<open>For the unsat-core predicate we only demand minimality in case that the indices are distinct.
   Otherwise, minimality does in general not hold. For instance, consider the input
   constraints $c_1: x < 0$, $c_2: x > 2$ and $c_2: x < 1$ where the index $c_2$ occurs twice.
   If the simplex-method first encounters constraint $c_1$, then it will detect that there is a conflict
   between $c_1$ and the first $c_2$-constraint. Consequently, the index-set $\{c_1,c_2\}$ will be returned,
   but this set is not minimal since $\{c_2\}$ is already unsatisfiable.\<close>
 definition minimal_unsat_core :: "'i set \<Rightarrow> 'i i_constraint list \<Rightarrow> bool" where
   "minimal_unsat_core I ics  = ((I \<subseteq> fst ` set ics) \<and> (\<not> (\<exists> v. (I,v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set ics))
      \<and> (distinct_indices ics \<longrightarrow> (\<forall> J. J \<subset> I \<longrightarrow> (\<exists> v. (J,v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set ics))))"
 
 subsection \<open>Procedure Specification\<close>
 
 abbreviation (input) Unsat where "Unsat \<equiv> Inl"
 abbreviation (input) Sat where "Sat \<equiv> Inr"
 
 
 text\<open>The specification for the satisfiability check procedure is given by:\<close>
 locale Solve =
   \<comment> \<open>Decide if the given list of constraints is satisfiable. Return either
      an unsat core, or a satisfying valuation.\<close>
   fixes solve :: "'i i_constraint list \<Rightarrow> 'i list + rat valuation"
     \<comment> \<open>If the status @{const Sat} is returned, then returned valuation
       satisfies all constraints.\<close>
   assumes  simplex_sat:  "solve cs = Sat v \<Longrightarrow> v \<Turnstile>\<^sub>c\<^sub>s flat (set cs)"
     \<comment> \<open>If the status @{const Unsat} is returned, then constraints are
      unsatisfiable, i.e., an unsatisfiable core is returned.\<close>
   assumes  simplex_unsat:  "solve cs = Unsat I \<Longrightarrow> minimal_unsat_core (set I) cs"
 
 abbreviation (input) look where "look \<equiv> Mapping.lookup"
 abbreviation (input) upd where "upd \<equiv> Mapping.update"
 
 lemma look_upd: "look (upd k v m) = (look m)(k \<mapsto> v)"
   by (transfer, auto)
 
 lemmas look_upd_simps[simp] = look_upd Mapping.lookup_empty
 
 definition map2fun:: "(var, 'a :: zero) mapping \<Rightarrow> var \<Rightarrow> 'a" where
   "map2fun v \<equiv> \<lambda>x. case look v x of None \<Rightarrow> 0 | Some y \<Rightarrow> y"
 syntax
   "_map2fun" :: "(var, 'a) mapping \<Rightarrow> var \<Rightarrow> 'a"  ("\<langle>_\<rangle>")
 translations
   "\<langle>v\<rangle>" == "CONST map2fun v"
 
 lemma map2fun_def':
   "\<langle>v\<rangle> x \<equiv> case Mapping.lookup v x of None \<Rightarrow> 0 | Some y \<Rightarrow> y"
   by (auto simp add: map2fun_def)
 
 
 text\<open>Note that the above specification requires returning a
 valuation (defined as a HOL function), which is not efficiently
 executable. In order to enable more efficient data structures for
 representing valuations, a refinement of this specification is needed
 and the function \<open>solve\<close> is replaced by the function \<open>solve_exec\<close> returning optional \<open>(var, rat) mapping\<close> instead
 of \<open>var \<Rightarrow> rat\<close> function. This way, efficient data structures
 for representing mappings can be easily plugged-in during code
 generation \cite{florian-refinement}. A conversion from the \<open>mapping\<close> datatype to HOL function is denoted by \<open>\<langle>_\<rangle>\<close> and
 given by: @{thm map2fun_def'[no_vars]}.\<close>
 
 locale SolveExec =
   fixes solve_exec :: "'i i_constraint list \<Rightarrow> 'i list + (var, rat) mapping"
   assumes  simplex_sat0:  "solve_exec cs = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s flat (set cs)"
   assumes  simplex_unsat0:  "solve_exec cs = Unsat I \<Longrightarrow> minimal_unsat_core (set I) cs"
 begin
 definition solve where
   "solve cs \<equiv> case solve_exec cs of Sat v \<Rightarrow> Sat \<langle>v\<rangle> | Unsat c \<Rightarrow> Unsat c"
 end
 
 sublocale SolveExec < Solve solve
   by (unfold_locales, insert simplex_sat0 simplex_unsat0,
       auto simp: solve_def split: sum.splits)
 
 
 subsection \<open>Handling Strict Inequalities\<close>
 
 text\<open>The first step of the procedure is removing all equalities and
 strict inequalities. Equalities can be easily rewritten to non-strict
 inequalities. Removing strict inequalities can be done by replacing
 the list of constraints by a new one, formulated over an extension
 \<open>\<rat>'\<close> of the space of rationals \<open>\<rat>\<close>. \<open>\<rat>'\<close> must
 have a structure of a linearly ordered vector space over \<open>\<rat>\<close>
 (represented by the type class \<open>lrv\<close>) and must guarantee that
 if some non-strict constraints are satisfied in \<open>\<rat>'\<close>, then
 there is a satisfying valuation for the original constraints in \<open>\<rat>\<close>. Our final implementation uses the \<open>\<rat>\<^sub>\<delta>\<close> space, defined in
 \cite{simplex-rad} (basic idea is to replace \<open>p < c\<close> by \<open>p \<le> c - \<delta>\<close> and \<open>p > c\<close> by \<open>p \<ge> c + \<delta>\<close> for a symbolic
 parameter \<open>\<delta>\<close>). So, all constraints are reduced to the form
 \<open>p \<bowtie> b\<close>, where \<open>p\<close> is a linear polynomial (still over
 \<open>\<rat>\<close>), \<open>b\<close> is constant from \<open>\<rat>'\<close> and \<open>\<bowtie>
 \<in> {\<le>, \<ge>}\<close>. The non-strict constraints are represented by the type
 \<open>'a ns_constraint\<close>, and their semantics is denoted by \<open>\<Turnstile>\<^sub>n\<^sub>s\<close> and \<open>\<Turnstile>\<^sub>n\<^sub>s\<^sub>s\<close>. The indexed variant is \<open>\<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s\<close>.\<close>
 datatype 'a ns_constraint = LEQ_ns linear_poly 'a    |    GEQ_ns linear_poly 'a
 
 type_synonym ('i,'a) i_ns_constraint = "'i \<times> 'a ns_constraint"
 
 primrec satisfiable_ns_constraint :: "'a::lrv valuation \<Rightarrow> 'a ns_constraint \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>n\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>n\<^sub>s LEQ_ns l r \<longleftrightarrow> l\<lbrace>v\<rbrace> \<le> r"
 | "v \<Turnstile>\<^sub>n\<^sub>s GEQ_ns l r \<longleftrightarrow> l\<lbrace>v\<rbrace> \<ge> r"
 
 abbreviation satisfies_ns_constraints :: "'a::lrv valuation \<Rightarrow> 'a ns_constraint set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>n\<^sub>s\<^sub>s " 100) where
   "v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s cs \<equiv> \<forall> c \<in> cs. v \<Turnstile>\<^sub>n\<^sub>s c"
 
 fun i_satisfies_ns_constraints :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('i,'a) i_ns_constraint set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s " 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s cs \<longleftrightarrow> v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s restrict_to I cs"
 
 lemma i_satisfies_ns_constraints_mono:
   "(I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s cs \<Longrightarrow> J \<subseteq> I \<Longrightarrow> (J,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s cs"
   by auto
 
 primrec poly :: "'a ns_constraint \<Rightarrow> linear_poly" where
   "poly (LEQ_ns p a) = p"
 | "poly (GEQ_ns p a) = p"
 
 primrec ns_constraint_const :: "'a ns_constraint \<Rightarrow> 'a" where
   "ns_constraint_const (LEQ_ns p a) = a" 
 | "ns_constraint_const (GEQ_ns p a) = a" 
 
 definition distinct_indices_ns :: "('i,'a :: lrv) i_ns_constraint set \<Rightarrow> bool" where 
   "distinct_indices_ns ns = ((\<forall> n1 n2 i. (i,n1) \<in> ns \<longrightarrow> (i,n2) \<in> ns \<longrightarrow> 
      poly n1 = poly n2 \<and> ns_constraint_const n1 = ns_constraint_const n2))" 
 
 definition minimal_unsat_core_ns :: "'i set \<Rightarrow> ('i,'a :: lrv) i_ns_constraint set \<Rightarrow> bool" where
   "minimal_unsat_core_ns I cs = ((I \<subseteq> fst ` cs) \<and> (\<not> (\<exists> v. (I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s cs))
      \<and> (distinct_indices_ns cs \<longrightarrow> (\<forall> J \<subset> I. \<exists> v. (J,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s cs)))"
 
 
 text\<open>Specification of reduction of constraints to non-strict form is given by:\<close>
 locale To_ns =
   \<comment> \<open>Convert a constraint to an equisatisfiable non-strict constraint list.
       The conversion must work for arbitrary subsets of constraints -- selected by some index set I --
       in order to carry over unsat-cores and in order to support incremental simplex solving.\<close>
   fixes to_ns :: "'i i_constraint list \<Rightarrow> ('i,'a::lrv) i_ns_constraint list"
     \<comment> \<open>Convert the valuation that satisfies all non-strict constraints to the valuation that
    satisfies all initial constraints.\<close>
   fixes from_ns :: "(var, 'a) mapping \<Rightarrow> 'a ns_constraint list \<Rightarrow> (var, rat) mapping"
   assumes  to_ns_unsat:  "minimal_unsat_core_ns I (set (to_ns cs)) \<Longrightarrow> minimal_unsat_core I cs"
   assumes  i_to_ns_sat:  "(I,\<langle>v'\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set (to_ns cs) \<Longrightarrow> (I,\<langle>from_ns v' (flat_list (to_ns cs))\<rangle>) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs"
   assumes to_ns_indices: "fst ` set (to_ns cs) = fst ` set cs"
   assumes distinct_cond: "distinct_indices cs \<Longrightarrow> distinct_indices_ns (set (to_ns cs))" 
 begin
 lemma to_ns_sat: "\<langle>v'\<rangle>  \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set (to_ns cs)) \<Longrightarrow> \<langle>from_ns v' (flat_list (to_ns cs))\<rangle> \<Turnstile>\<^sub>c\<^sub>s flat (set cs)"
   using i_to_ns_sat[of UNIV v' cs] by auto
 end
 
 
 locale Solve_exec_ns =
   fixes solve_exec_ns :: "('i,'a::lrv) i_ns_constraint list \<Rightarrow> 'i list + (var, 'a) mapping"
   assumes simplex_ns_sat:  "solve_exec_ns cs = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set cs)"
   assumes simplex_ns_unsat:  "solve_exec_ns cs = Unsat I \<Longrightarrow> minimal_unsat_core_ns (set I) (set cs)"
 
 
 text\<open>After the transformation, the procedure is reduced to solving
 only the non-strict constraints, implemented in the \<open>solve_exec_ns\<close> function having an analogous specification to the
 \<open>solve\<close> function. If \<open>to_ns\<close>, \<open>from_ns\<close> and
 \<open>solve_exec_ns\<close> are available, the \<open>solve_exec\<close>
 function can be easily defined and it can be easily shown that this
 definition satisfies its specification (also analogous to \<open>solve\<close>).
 \<close>
 
 locale SolveExec' = To_ns to_ns from_ns + Solve_exec_ns solve_exec_ns for
   to_ns:: "'i i_constraint list \<Rightarrow> ('i,'a::lrv) i_ns_constraint list" and
   from_ns :: "(var, 'a) mapping \<Rightarrow> 'a ns_constraint list \<Rightarrow> (var, rat) mapping" and
   solve_exec_ns :: "('i,'a) i_ns_constraint list \<Rightarrow> 'i list + (var, 'a) mapping"
 begin
 
 definition solve_exec where
   "solve_exec cs \<equiv> let cs' = to_ns cs in case solve_exec_ns cs'
             of Sat v \<Rightarrow> Sat (from_ns v (flat_list cs'))
              | Unsat is \<Rightarrow> Unsat is"
 
 end
 
 
 sublocale SolveExec' < SolveExec solve_exec
   by (unfold_locales, insert simplex_ns_sat simplex_ns_unsat to_ns_sat to_ns_unsat,
       (force simp: solve_exec_def Let_def split: sum.splits)+)
 
 
 subsection \<open>Preprocessing\<close>
 
 text\<open>The next step in the procedure rewrites a list of non-strict
 constraints into an equisatisfiable form consisting of a list of
 linear equations (called the \emph{tableau}) and of a list of
 \emph{atoms} of the form \<open>x\<^sub>i \<bowtie> b\<^sub>i\<close> where \<open>x\<^sub>i\<close> is a
 variable and \<open>b\<^sub>i\<close> is a constant (from the extension field). The
 transformation is straightforward and introduces auxiliary variables
 for linear polynomials occurring in the initial formula. For example,
 \<open>[x\<^sub>1 + x\<^sub>2 \<le> b\<^sub>1, x\<^sub>1 + x\<^sub>2 \<ge> b\<^sub>2, x\<^sub>2 \<ge> b\<^sub>3]\<close> can be transformed to
 the tableau \<open>[x\<^sub>3 = x\<^sub>1 + x\<^sub>2]\<close> and atoms \<open>[x\<^sub>3 \<le> b\<^sub>1, x\<^sub>3 \<ge>
 b\<^sub>2, x\<^sub>2 \<ge> b\<^sub>3]\<close>.\<close>
 
 
 type_synonym eq = "var \<times> linear_poly"
 primrec lhs :: "eq \<Rightarrow> var" where "lhs (l, r) = l"
 primrec rhs :: "eq \<Rightarrow> linear_poly" where "rhs (l, r) = r"
 abbreviation rvars_eq :: "eq \<Rightarrow> var set" where
   "rvars_eq eq \<equiv> vars (rhs eq)"
 
 
 definition satisfies_eq :: "'a::rational_vector valuation \<Rightarrow> eq \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>e" 100) where
   "v \<Turnstile>\<^sub>e eq \<equiv> v (lhs eq) = (rhs eq)\<lbrace>v\<rbrace>"
 
 lemma satisfies_eq_iff: "v \<Turnstile>\<^sub>e (x, p) \<equiv> v x = p\<lbrace>v\<rbrace>"
   by (simp add: satisfies_eq_def)
 
 
 
 type_synonym tableau ="eq list"
 
 
 definition satisfies_tableau ::"'a::rational_vector valuation \<Rightarrow> tableau \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>t" 100) where
   "v \<Turnstile>\<^sub>t t \<equiv> \<forall> e \<in> set t. v \<Turnstile>\<^sub>e e"
 
 
 definition lvars :: "tableau \<Rightarrow> var set" where
   "lvars t = set (map lhs t)"
 definition rvars :: "tableau \<Rightarrow> var set" where
   "rvars t = \<Union> (set (map rvars_eq t))"
 abbreviation tvars where "tvars t \<equiv> lvars t \<union> rvars t"
 
 text \<open>The condition that the rhss are non-zero is required to obtain minimal unsatisfiable cores.
 To observe the problem with 0 as rhs, consider the tableau $x = 0$ in combination
 with atom $(A: x \leq 0)$ where then $(B: x \geq 1)$ is asserted.
 In this case, the unsat core would be computed as $\{A,B\}$, although already $\{B\}$ is unsatisfiable.\<close>
 
 definition normalized_tableau :: "tableau \<Rightarrow> bool" ("\<triangle>") where
   "normalized_tableau t \<equiv> distinct (map lhs t) \<and> lvars t \<inter> rvars t = {} \<and> 0 \<notin> rhs ` set t"
 
 text\<open>Equations are of the form \<open>x = p\<close>, where \<open>x\<close> is
 a variable and \<open>p\<close> is a polynomial, and are represented by the
 type \<open>eq = var \<times> linear_poly\<close>. Semantics of equations is given
 by @{thm satisfies_eq_iff[no_vars]}. Tableau is represented as a list
 of equations, by the type \<open>tableau = eq list\<close>. Semantics for a
 tableau is given by @{thm satisfies_tableau_def[no_vars]}. Functions
 \<open>lvars\<close> and \<open>rvars\<close> return sets of variables appearing on
 the left hand side (lhs) and the right hand side (rhs) of a
 tableau. Lhs variables are called \emph{basic} while rhs variables are
 called \emph{non-basic} variables. A tableau \<open>t\<close> is
 \emph{normalized} (denoted by @{term "\<triangle> t"}) iff no variable occurs on
 the lhs of two equations in a tableau and if sets of lhs and rhs
 variables are distinct.\<close>
 
 lemma normalized_tableau_unique_eq_for_lvar:
   assumes "\<triangle> t"
   shows "\<forall> x \<in> lvars t. \<exists>! p. (x, p) \<in> set t"
 proof (safe)
   fix x
   assume "x \<in> lvars t"
   then show "\<exists>p. (x, p) \<in> set t"
     unfolding lvars_def
     by auto
 next
   fix x p1 p2
   assume *: "(x, p1) \<in> set t" "(x, p2) \<in> set t"
   then show "p1 = p2"
     using \<open>\<triangle> t\<close>
     unfolding normalized_tableau_def
     by (force simp add: distinct_map inj_on_def)
 qed
 
 lemma recalc_tableau_lvars:
   assumes "\<triangle> t"
   shows "\<forall> v. \<exists> v'. (\<forall> x \<in> rvars t. v x = v' x) \<and> v' \<Turnstile>\<^sub>t t"
 proof
   fix v
   let ?v' = "\<lambda> x. if x \<in> lvars t then (THE p. (x, p) \<in> set t) \<lbrace> v \<rbrace> else v x"
   show "\<exists> v'. (\<forall> x \<in> rvars t. v x = v' x) \<and> v' \<Turnstile>\<^sub>t t"
   proof (rule_tac x="?v'" in exI, rule conjI)
     show "\<forall>x\<in>rvars t. v x = ?v' x"
       using \<open>\<triangle> t\<close>
       unfolding normalized_tableau_def
       by auto
     show "?v' \<Turnstile>\<^sub>t t"
       unfolding satisfies_tableau_def satisfies_eq_def
     proof
       fix e
       assume "e \<in> set t"
       obtain l r where e: "e = (l,r)" by force
       show "?v' (lhs e) = rhs e \<lbrace> ?v' \<rbrace>"
       proof-
         have "(lhs e, rhs e) \<in> set t"
           using \<open>e \<in> set t\<close> e by auto
         have "\<exists>!p. (lhs e, p) \<in> set t"
           using \<open>\<triangle> t\<close> normalized_tableau_unique_eq_for_lvar[of t]
           using \<open>e \<in> set t\<close>
           unfolding lvars_def
           by auto
 
         let ?p = "THE p. (lhs e, p) \<in> set t"
         have "(lhs e, ?p) \<in> set t"
           apply (rule theI')
           using \<open>\<exists>!p. (lhs e, p) \<in> set t\<close>
           by auto
         then have "?p = rhs e"
           using \<open>(lhs e, rhs e) \<in> set t\<close>
           using \<open>\<exists>!p. (lhs e, p) \<in> set t\<close>
           by auto
         moreover
         have "?v' (lhs e) = ?p \<lbrace> v \<rbrace>"
           using \<open>e \<in> set t\<close>
           unfolding lvars_def
           by simp
         moreover
         have "rhs e \<lbrace> ?v' \<rbrace> = rhs e \<lbrace> v \<rbrace>"
           apply (rule valuate_depend)
           using \<open>\<triangle> t\<close> \<open>e \<in> set t\<close>
           unfolding normalized_tableau_def
           by (auto simp add: lvars_def rvars_def)
         ultimately
         show ?thesis
           by auto
       qed
     qed
   qed
 qed
 
 lemma tableau_perm:
   assumes "lvars t1 = lvars t2" "rvars t1 = rvars t2"
     "\<triangle> t1" "\<triangle> t2" "\<And> v::'a::lrv valuation. v \<Turnstile>\<^sub>t t1 \<longleftrightarrow> v \<Turnstile>\<^sub>t t2"
   shows "mset t1 = mset t2"
 proof-
   {
     fix t1 t2
     assume "lvars t1 = lvars t2" "rvars t1 = rvars t2"
       "\<triangle> t1" "\<And> v::'a::lrv valuation. v \<Turnstile>\<^sub>t t1 \<longleftrightarrow> v \<Turnstile>\<^sub>t t2"
     have "set t1 \<subseteq> set t2"
     proof (safe)
       fix a b
       assume "(a, b) \<in> set t1"
       then have "a \<in> lvars t1"
         unfolding lvars_def
         by force
       then have "a \<in> lvars t2"
         using \<open>lvars t1 = lvars t2\<close>
         by simp
       then obtain b' where "(a, b') \<in> set t2"
         unfolding lvars_def
         by force
       have "\<forall>v::'a valuation. \<exists>v'. (\<forall>x\<in>vars (b - b'). v' x = v x) \<and> (b - b') \<lbrace> v' \<rbrace> = 0"
       proof
         fix v::"'a valuation"
         obtain v' where "v' \<Turnstile>\<^sub>t t1" "\<forall> x \<in> rvars t1. v x = v' x"
           using recalc_tableau_lvars[of t1] \<open>\<triangle> t1\<close>
           by auto
         have "v' \<Turnstile>\<^sub>t t2"
           using \<open>v' \<Turnstile>\<^sub>t t1\<close> \<open>\<And> v. v \<Turnstile>\<^sub>t t1 \<longleftrightarrow> v \<Turnstile>\<^sub>t t2\<close>
           by simp
         have "b \<lbrace>v'\<rbrace> = b' \<lbrace>v'\<rbrace>"
           using \<open>(a, b) \<in> set t1\<close> \<open>v' \<Turnstile>\<^sub>t t1\<close>
           using \<open>(a, b') \<in> set t2\<close> \<open>v' \<Turnstile>\<^sub>t t2\<close>
           unfolding satisfies_tableau_def satisfies_eq_def
           by force
         then have "(b - b') \<lbrace>v'\<rbrace> = 0"
           using valuate_minus[of b b' v']
           by auto
         moreover
         have "vars b \<subseteq> rvars t1" "vars b' \<subseteq> rvars t1"
           using \<open>(a, b) \<in> set t1\<close> \<open>(a, b') \<in> set t2\<close> \<open>rvars t1 = rvars t2\<close>
           unfolding rvars_def
           by force+
         then have "vars (b - b') \<subseteq> rvars t1"
           using vars_minus[of b b']
           by blast
         then have "\<forall>x\<in>vars (b - b'). v' x = v x"
           using \<open>\<forall> x \<in> rvars t1. v x = v' x\<close>
           by auto
         ultimately
         show "\<exists>v'. (\<forall>x\<in>vars (b - b'). v' x = v x) \<and> (b - b') \<lbrace> v' \<rbrace> = 0"
           by auto
       qed
       then have "b = b'"
         using all_val[of "b - b'"]
         by simp
       then show "(a, b) \<in> set t2"
         using \<open>(a, b') \<in> set t2\<close>
         by simp
     qed
   }
   note * = this
   have "set t1 = set t2"
     using *[of t1 t2] *[of t2 t1]
     using assms
     by auto
   moreover
   have "distinct t1" "distinct t2"
     using \<open>\<triangle> t1\<close> \<open>\<triangle> t2\<close>
     unfolding normalized_tableau_def
     by (auto simp add: distinct_map)
   ultimately
   show ?thesis
     by (auto simp add: set_eq_iff_mset_eq_distinct)
 qed
 
 
 text\<open>Elementary atoms are represented by the type \<open>'a atom\<close>
 and semantics for atoms and sets of atoms is denoted by \<open>\<Turnstile>\<^sub>a\<close> and
 \<open>\<Turnstile>\<^sub>a\<^sub>s\<close> and given by:
 \<close>
 
 datatype 'a atom  = Leq var 'a    |    Geq var 'a
 
 primrec atom_var::"'a atom \<Rightarrow> var" where
   "atom_var (Leq var a) = var"
 | "atom_var (Geq var a) = var"
 
 primrec atom_const::"'a atom \<Rightarrow> 'a" where
   "atom_const (Leq var a) = a"
 | "atom_const (Geq var a) = a"
 
 primrec satisfies_atom :: "'a::linorder valuation \<Rightarrow> 'a atom \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a" 100) where
   "v \<Turnstile>\<^sub>a Leq x c \<longleftrightarrow> v x \<le> c"    |    "v \<Turnstile>\<^sub>a Geq x c \<longleftrightarrow> v x \<ge> c"
 
 definition satisfies_atom_set :: "'a::linorder valuation \<Rightarrow> 'a atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>a\<^sub>s as \<equiv> \<forall> a \<in> as. v \<Turnstile>\<^sub>a a"
 
 definition satisfies_atom' :: "'a::linorder valuation \<Rightarrow> 'a atom \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a\<^sub>e" 100) where
   "v \<Turnstile>\<^sub>a\<^sub>e a \<longleftrightarrow> v (atom_var a) = atom_const a"
 
 lemma satisfies_atom'_stronger: "v \<Turnstile>\<^sub>a\<^sub>e a \<Longrightarrow> v \<Turnstile>\<^sub>a a" by (cases a, auto simp: satisfies_atom'_def)
 
 abbreviation satisfies_atom_set' :: "'a::linorder valuation \<Rightarrow> 'a atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a\<^sub>e\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>a\<^sub>e\<^sub>s as \<equiv> \<forall> a \<in> as. v \<Turnstile>\<^sub>a\<^sub>e a"
 
 lemma satisfies_atom_set'_stronger: "v \<Turnstile>\<^sub>a\<^sub>e\<^sub>s as \<Longrightarrow> v \<Turnstile>\<^sub>a\<^sub>s as" 
   using satisfies_atom'_stronger unfolding satisfies_atom_set_def by auto
 
 text \<open>There is also the indexed variant of an atom\<close>
 
 type_synonym ('i,'a) i_atom = "'i \<times> 'a atom"
 
 fun i_satisfies_atom_set :: "'i set \<times> 'a::linorder valuation \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>a\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>a\<^sub>s restrict_to I as"
 
 fun i_satisfies_atom_set' :: "'i set \<times> 'a::linorder valuation \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>a\<^sub>e\<^sub>s restrict_to I as"
 
 lemma i_satisfies_atom_set'_stronger: "Iv \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as \<Longrightarrow> Iv \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as" 
   using satisfies_atom_set'_stronger[of _ "snd Iv"] by (cases Iv, auto)
 
 lemma satisifies_atom_restrict_to_Cons: "v \<Turnstile>\<^sub>a\<^sub>s restrict_to I (set as) \<Longrightarrow> (i \<in> I \<Longrightarrow> v \<Turnstile>\<^sub>a a)
   \<Longrightarrow> v \<Turnstile>\<^sub>a\<^sub>s restrict_to I (set ((i,a) # as))"
   unfolding satisfies_atom_set_def by auto
 
 lemma satisfies_tableau_Cons: "v \<Turnstile>\<^sub>t t \<Longrightarrow> v \<Turnstile>\<^sub>e e \<Longrightarrow> v \<Turnstile>\<^sub>t (e # t)"
   unfolding satisfies_tableau_def by auto
 
 definition distinct_indices_atoms :: "('i,'a) i_atom set \<Rightarrow> bool" where
   "distinct_indices_atoms as = (\<forall> i a b. (i,a) \<in> as \<longrightarrow> (i,b) \<in> as \<longrightarrow> atom_var a = atom_var b \<and> atom_const a = atom_const b)" 
 
 text\<open>
 The specification of the preprocessing function is given by:\<close>
 locale Preprocess = fixes preprocess::"('i,'a::lrv) i_ns_constraint list \<Rightarrow> tableau\<times> ('i,'a) i_atom list
   \<times> ((var,'a) mapping \<Rightarrow> (var,'a) mapping) \<times> 'i list"
   assumes
     \<comment> \<open>The returned tableau is always normalized.\<close>
     preprocess_tableau_normalized: "preprocess cs = (t,as,trans_v,U) \<Longrightarrow> \<triangle> t" and
 
 \<comment> \<open>Tableau and atoms are equisatisfiable with starting non-strict constraints.\<close>
 i_preprocess_sat: "\<And> v. preprocess cs = (t,as,trans_v,U) \<Longrightarrow> I \<inter> set U = {} \<Longrightarrow> (I,\<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<Longrightarrow> (I,\<langle>trans_v v\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" and
 
 preprocess_unsat: "preprocess cs = (t, as,trans_v,U) \<Longrightarrow> (I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs \<Longrightarrow> \<exists> v'. (I,v') \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<and> v' \<Turnstile>\<^sub>t t" and
 
 \<comment> \<open>distinct indices on ns-constraints ensures distinct indices in atoms\<close>
 preprocess_distinct: "preprocess cs = (t, as,trans_v, U) \<Longrightarrow> distinct_indices_ns (set cs) \<Longrightarrow> distinct_indices_atoms (set as)" and
 
 \<comment> \<open>unsat indices\<close>
 preprocess_unsat_indices: "preprocess cs = (t, as,trans_v, U) \<Longrightarrow> i \<in> set U \<Longrightarrow> \<not> (\<exists> v. ({i},v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs)" and
 
 \<comment> \<open>preprocessing cannot introduce new indices\<close>
 preprocess_index: "preprocess cs = (t,as,trans_v, U) \<Longrightarrow> fst ` set as \<union> set U \<subseteq> fst ` set cs"
 begin
 lemma preprocess_sat: "preprocess cs = (t,as,trans_v,U) \<Longrightarrow> U = [] \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s flat (set as) \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<Longrightarrow> \<langle>trans_v v\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set cs)"
   using i_preprocess_sat[of cs t as trans_v U UNIV v] by auto
 
 end
 
 definition minimal_unsat_core_tabl_atoms :: "'i set \<Rightarrow> tableau \<Rightarrow> ('i,'a::lrv) i_atom set \<Rightarrow> bool" where
   "minimal_unsat_core_tabl_atoms I t as = ( I \<subseteq> fst ` as \<and> (\<not> (\<exists> v. v \<Turnstile>\<^sub>t t \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as)) \<and>
        (distinct_indices_atoms as \<longrightarrow> (\<forall> J \<subset> I. \<exists> v. v \<Turnstile>\<^sub>t t \<and> (J,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as)))" 
 
 lemma minimal_unsat_core_tabl_atomsD: assumes "minimal_unsat_core_tabl_atoms I t as"
   shows "I \<subseteq> fst ` as" 
     "\<not> (\<exists> v. v \<Turnstile>\<^sub>t t \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as)" 
     "distinct_indices_atoms as \<Longrightarrow> J \<subset> I \<Longrightarrow> \<exists> v. v \<Turnstile>\<^sub>t t \<and> (J,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" 
   using assms unfolding minimal_unsat_core_tabl_atoms_def by auto
 
 locale AssertAll =
   fixes assert_all :: "tableau \<Rightarrow> ('i,'a::lrv) i_atom list \<Rightarrow> 'i list + (var, 'a)mapping"
   assumes assert_all_sat:  "\<triangle> t \<Longrightarrow> assert_all t as = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s flat (set as)"
   assumes assert_all_unsat:  "\<triangle> t \<Longrightarrow> assert_all t as = Unsat I \<Longrightarrow> minimal_unsat_core_tabl_atoms (set I) t (set as)"
 
 
 text\<open>Once the preprocessing is done and tableau and atoms are
 obtained, their satisfiability is checked by the
 \<open>assert_all\<close> function. Its precondition is that the starting
 tableau is normalized, and its specification is analogue to the one for the
 \<open>solve\<close> function. If \<open>preprocess\<close> and \<open>assert_all\<close>
 are available, the  \<open>solve_exec_ns\<close> can be defined, and it
 can easily be shown that this definition satisfies the specification.\<close>
 
 locale Solve_exec_ns' = Preprocess preprocess + AssertAll assert_all for
   preprocess:: "('i,'a::lrv) i_ns_constraint list \<Rightarrow> tableau \<times> ('i,'a) i_atom list \<times> ((var,'a)mapping \<Rightarrow> (var,'a)mapping) \<times> 'i list" and
   assert_all :: "tableau \<Rightarrow> ('i,'a::lrv) i_atom list \<Rightarrow> 'i list + (var, 'a) mapping"
 begin
 definition solve_exec_ns where
 
 "solve_exec_ns s \<equiv>
     case preprocess s of (t,as,trans_v,ui) \<Rightarrow>
       (case ui of i # _ \<Rightarrow> Inl [i] | _ \<Rightarrow>
       (case assert_all t as of Inl I \<Rightarrow> Inl I | Inr v \<Rightarrow> Inr (trans_v v))) "
 end
 
 context Preprocess
 begin
 
 lemma preprocess_unsat_index: assumes prep: "preprocess cs = (t,as,trans_v,ui)" 
   and i: "i \<in> set ui" 
 shows "minimal_unsat_core_ns {i} (set cs)"
 proof -
   from preprocess_index[OF prep] have "set ui \<subseteq> fst ` set cs" by auto
   with i have i': "i \<in> fst ` set cs" by auto
   from preprocess_unsat_indices[OF prep i]
   show ?thesis unfolding minimal_unsat_core_ns_def using i' by auto
 qed
 
 lemma preprocess_minimal_unsat_core: assumes prep: "preprocess cs = (t,as,trans_v,ui)"
     and unsat: "minimal_unsat_core_tabl_atoms I t (set as)" 
     and inter: "I \<inter> set ui = {}" 
   shows "minimal_unsat_core_ns I (set cs)" 
 proof -
   from preprocess_tableau_normalized[OF prep]
   have t: "\<triangle> t" .
   from preprocess_index[OF prep] have index: "fst ` set as \<union> set ui \<subseteq> fst ` set cs" by auto
   from minimal_unsat_core_tabl_atomsD(1,2)[OF unsat] preprocess_unsat[OF prep, of I]
   have 1: "I \<subseteq> fst ` set as" "\<not> (\<exists> v. (I, v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs)" by force+
   show "minimal_unsat_core_ns I (set cs)" unfolding minimal_unsat_core_ns_def
   proof (intro conjI impI allI 1(2))
     show "I \<subseteq> fst ` set cs" using 1 index by auto
     fix J
     assume "distinct_indices_ns (set cs)" "J \<subset> I" 
     with preprocess_distinct[OF prep]
     have "distinct_indices_atoms (set as)" "J \<subset> I" by auto
     from minimal_unsat_core_tabl_atomsD(3)[OF unsat this]
     obtain v where model: "v \<Turnstile>\<^sub>t t" "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s set as" by auto
     from i_satisfies_atom_set'_stronger[OF model(2)] 
     have model': "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" . 
     define w where "w = Mapping.Mapping (\<lambda> x. Some (v x))"
     have "v = \<langle>w\<rangle>" unfolding w_def map2fun_def
       by (intro ext, transfer, auto)
     with model model' have "\<langle>w\<rangle> \<Turnstile>\<^sub>t t" "(J, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" by auto
     from i_preprocess_sat[OF prep _ this(2,1)] \<open>J \<subset> I\<close> inter
     have "(J, \<langle>trans_v w\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" by auto
     then show "\<exists> w. (J, w) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" by auto
   qed
 qed
 end
 
 sublocale Solve_exec_ns' < Solve_exec_ns solve_exec_ns
 proof
   fix cs
   obtain t as trans_v ui where prep: "preprocess cs = (t,as,trans_v,ui)" by (cases "preprocess cs")
   from preprocess_tableau_normalized[OF prep]
   have t: "\<triangle> t" .
   from preprocess_index[OF prep] have index: "fst ` set as \<union> set ui \<subseteq> fst ` set cs" by auto
   note solve = solve_exec_ns_def[of cs, unfolded prep split]
   {
     fix v
     assume "solve_exec_ns cs = Sat v"
     from this[unfolded solve] t assert_all_sat[OF t] preprocess_sat[OF prep]
     show " \<langle>v\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set cs)" by (auto split: sum.splits list.splits)
   }
   {
     fix I
     assume res: "solve_exec_ns cs = Unsat I"
     show "minimal_unsat_core_ns (set I) (set cs)" 
     proof (cases ui)
       case (Cons i uis)
       hence I: "I = [i]" using res[unfolded solve] by auto
       from preprocess_unsat_index[OF prep, of i] I Cons index show ?thesis by auto
     next
       case Nil
       from res[unfolded solve Nil] have assert: "assert_all t as = Unsat I"
         by (auto split: sum.splits)
       from assert_all_unsat[OF t assert]
       have "minimal_unsat_core_tabl_atoms (set I) t (set as)" .
       from preprocess_minimal_unsat_core[OF prep this] Nil
       show "minimal_unsat_core_ns (set I) (set cs)" by simp
     qed
   }
 qed
 
 subsection\<open>Incrementally Asserting Atoms\<close>
 
 text\<open>The function @{term assert_all} can be implemented by
 iteratively asserting one by one atom from the given list of atoms.
 \<close>
 
 type_synonym 'a bounds = "var \<rightharpoonup> 'a"
 
 text\<open>Asserted atoms will be stored in a form of \emph{bounds} for a
 given variable. Bounds are of the form \<open>l\<^sub>i \<le> x\<^sub>i \<le> u\<^sub>i\<close>, where
 \<open>l\<^sub>i\<close> and \<open>u\<^sub>i\<close> and are either scalars or $\pm
 \infty$. Each time a new atom is asserted, a bound for the
 corresponding variable is updated (checking for conflict with the
 previous bounds). Since bounds for a variable can be either finite or
 $\pm \infty$, they are represented by (partial) maps from variables to
 values (\<open>'a bounds = var \<rightharpoonup> 'a\<close>). Upper and lower bounds are
 represented separately. Infinite bounds map to @{term None} and this
 is reflected in the semantics:
 
 \begin{small}
 \<open>c \<ge>\<^sub>u\<^sub>b b \<longleftrightarrow> case b of None \<Rightarrow> False | Some b' \<Rightarrow> c \<ge> b'\<close>
 
 \<open>c \<le>\<^sub>u\<^sub>b b \<longleftrightarrow> case b of None \<Rightarrow> True | Some b' \<Rightarrow> c \<le> b'\<close>
 \end{small}
 
 \noindent Strict comparisons, and comparisons with lower bounds are performed similarly.
 \<close>
 
 abbreviation (input) le where
   "le lt x y \<equiv> lt x y \<or> x = y"
 definition geub ("\<unrhd>\<^sub>u\<^sub>b") where
   "\<unrhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> le lt b' c"
 definition gtub ("\<rhd>\<^sub>u\<^sub>b") where
   "\<rhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> lt b' c"
 definition leub ("\<unlhd>\<^sub>u\<^sub>b") where
   "\<unlhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> le lt c b'"
 definition ltub ("\<lhd>\<^sub>u\<^sub>b") where
   "\<lhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> lt c b'"
 definition lelb ("\<unlhd>\<^sub>l\<^sub>b") where
   "\<unlhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> le lt c b'"
 definition ltlb ("\<lhd>\<^sub>l\<^sub>b") where
   "\<lhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> lt c b'"
 definition gelb ("\<unrhd>\<^sub>l\<^sub>b") where
   "\<unrhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> le lt b' c"
 definition gtlb ("\<rhd>\<^sub>l\<^sub>b") where
   "\<rhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> lt b' c"
 
 
 definition ge_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<ge>\<^sub>u\<^sub>b" 100) where
   "c \<ge>\<^sub>u\<^sub>b b = \<unrhd>\<^sub>u\<^sub>b (<) c b"
 definition gt_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl ">\<^sub>u\<^sub>b" 100) where
   "c >\<^sub>u\<^sub>b b = \<rhd>\<^sub>u\<^sub>b (<) c b"
 definition le_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<le>\<^sub>u\<^sub>b" 100) where
   "c \<le>\<^sub>u\<^sub>b b = \<unlhd>\<^sub>u\<^sub>b (<) c b"
 definition lt_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "<\<^sub>u\<^sub>b" 100) where
   "c <\<^sub>u\<^sub>b b = \<lhd>\<^sub>u\<^sub>b (<) c b"
 definition le_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<le>\<^sub>l\<^sub>b" 100) where
   "c \<le>\<^sub>l\<^sub>b b = \<unlhd>\<^sub>l\<^sub>b (<) c b"
 definition lt_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "<\<^sub>l\<^sub>b" 100) where
   "c <\<^sub>l\<^sub>b b = \<lhd>\<^sub>l\<^sub>b (<) c b"
 definition ge_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<ge>\<^sub>l\<^sub>b" 100) where
   "c \<ge>\<^sub>l\<^sub>b b = \<unrhd>\<^sub>l\<^sub>b (<) c b"
 definition gt_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl ">\<^sub>l\<^sub>b" 100) where
   "c >\<^sub>l\<^sub>b b = \<rhd>\<^sub>l\<^sub>b (<) c b"
 
 
 lemmas bound_compare'_defs =
   geub_def gtub_def leub_def ltub_def
   gelb_def gtlb_def lelb_def ltlb_def
 
 lemmas bound_compare''_defs =
   ge_ubound_def gt_ubound_def le_ubound_def lt_ubound_def
   le_lbound_def lt_lbound_def ge_lbound_def gt_lbound_def
 
 lemmas bound_compare_defs = bound_compare'_defs bound_compare''_defs
 
 
 lemma opposite_dir [simp]:
   "\<unlhd>\<^sub>l\<^sub>b (>) a b = \<unrhd>\<^sub>u\<^sub>b (<) a b"
   "\<unlhd>\<^sub>u\<^sub>b (>) a b = \<unrhd>\<^sub>l\<^sub>b (<) a b"
   "\<unrhd>\<^sub>l\<^sub>b (>) a b = \<unlhd>\<^sub>u\<^sub>b (<) a b"
   "\<unrhd>\<^sub>u\<^sub>b (>) a b = \<unlhd>\<^sub>l\<^sub>b (<) a b"
   "\<lhd>\<^sub>l\<^sub>b (>) a b = \<rhd>\<^sub>u\<^sub>b (<) a b"
   "\<lhd>\<^sub>u\<^sub>b (>) a b = \<rhd>\<^sub>l\<^sub>b (<) a b"
   "\<rhd>\<^sub>l\<^sub>b (>) a b = \<lhd>\<^sub>u\<^sub>b (<) a b"
   "\<rhd>\<^sub>u\<^sub>b (>) a b = \<lhd>\<^sub>l\<^sub>b (<) a b"
   by (case_tac[!] b) (auto simp add: bound_compare'_defs)
 
 
 (* Auxiliary lemmas about bound comparison *)
 
 lemma [simp]: "\<not> c \<ge>\<^sub>u\<^sub>b None " "\<not> c \<le>\<^sub>l\<^sub>b None"
   by (auto simp add: bound_compare_defs)
 
 lemma neg_bounds_compare:
   "(\<not> (c \<ge>\<^sub>u\<^sub>b b)) \<Longrightarrow> c <\<^sub>u\<^sub>b b" "(\<not> (c \<le>\<^sub>u\<^sub>b b)) \<Longrightarrow> c >\<^sub>u\<^sub>b b"
   "(\<not> (c >\<^sub>u\<^sub>b b)) \<Longrightarrow> c \<le>\<^sub>u\<^sub>b b" "(\<not> (c <\<^sub>u\<^sub>b b)) \<Longrightarrow> c \<ge>\<^sub>u\<^sub>b b"
   "(\<not> (c \<le>\<^sub>l\<^sub>b b)) \<Longrightarrow> c >\<^sub>l\<^sub>b b" "(\<not> (c \<ge>\<^sub>l\<^sub>b b)) \<Longrightarrow> c <\<^sub>l\<^sub>b b"
   "(\<not> (c <\<^sub>l\<^sub>b b)) \<Longrightarrow> c \<ge>\<^sub>l\<^sub>b b" "(\<not> (c >\<^sub>l\<^sub>b b)) \<Longrightarrow> c \<le>\<^sub>l\<^sub>b b"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma bounds_compare_contradictory [simp]:
   "\<lbrakk>c \<ge>\<^sub>u\<^sub>b b; c <\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c \<le>\<^sub>u\<^sub>b b; c >\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   "\<lbrakk>c >\<^sub>u\<^sub>b b; c \<le>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c <\<^sub>u\<^sub>b b; c \<ge>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   "\<lbrakk>c \<le>\<^sub>l\<^sub>b b; c >\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c \<ge>\<^sub>l\<^sub>b b; c <\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   "\<lbrakk>c <\<^sub>l\<^sub>b b; c \<ge>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c >\<^sub>l\<^sub>b b; c \<le>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma compare_strict_nonstrict:
   "x <\<^sub>u\<^sub>b b \<Longrightarrow> x \<le>\<^sub>u\<^sub>b b"
   "x >\<^sub>u\<^sub>b b \<Longrightarrow> x \<ge>\<^sub>u\<^sub>b b"
   "x <\<^sub>l\<^sub>b b \<Longrightarrow> x \<le>\<^sub>l\<^sub>b b"
   "x >\<^sub>l\<^sub>b b \<Longrightarrow> x \<ge>\<^sub>l\<^sub>b b"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma [simp]:
   "\<lbrakk> x \<le> c; c <\<^sub>u\<^sub>b b \<rbrakk> \<Longrightarrow> x <\<^sub>u\<^sub>b b"
   "\<lbrakk> x < c; c \<le>\<^sub>u\<^sub>b b \<rbrakk> \<Longrightarrow> x <\<^sub>u\<^sub>b b"
   "\<lbrakk> x \<le> c; c \<le>\<^sub>u\<^sub>b b \<rbrakk> \<Longrightarrow> x \<le>\<^sub>u\<^sub>b b"
   "\<lbrakk> x \<ge> c; c >\<^sub>l\<^sub>b b \<rbrakk> \<Longrightarrow> x >\<^sub>l\<^sub>b b"
   "\<lbrakk> x > c; c \<ge>\<^sub>l\<^sub>b b \<rbrakk> \<Longrightarrow> x >\<^sub>l\<^sub>b b"
   "\<lbrakk> x \<ge> c; c \<ge>\<^sub>l\<^sub>b b \<rbrakk> \<Longrightarrow> x \<ge>\<^sub>l\<^sub>b b"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma bounds_lg [simp]:
   "\<lbrakk> c >\<^sub>u\<^sub>b b; x \<le>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> x < c"
   "\<lbrakk> c \<ge>\<^sub>u\<^sub>b b; x <\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> x < c"
   "\<lbrakk> c \<ge>\<^sub>u\<^sub>b b; x \<le>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> x \<le> c"
   "\<lbrakk> c <\<^sub>l\<^sub>b b; x \<ge>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> x > c"
   "\<lbrakk> c \<le>\<^sub>l\<^sub>b b; x >\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> x > c"
   "\<lbrakk> c \<le>\<^sub>l\<^sub>b b; x \<ge>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> x \<ge> c"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma bounds_compare_Some [simp]:
   "x \<le>\<^sub>u\<^sub>b Some c \<longleftrightarrow> x \<le> c" "x \<ge>\<^sub>u\<^sub>b Some c \<longleftrightarrow> x \<ge> c"
   "x <\<^sub>u\<^sub>b Some c \<longleftrightarrow> x < c" "x >\<^sub>u\<^sub>b Some c \<longleftrightarrow> x > c"
   "x \<ge>\<^sub>l\<^sub>b Some c \<longleftrightarrow> x \<ge> c" "x \<le>\<^sub>l\<^sub>b Some c \<longleftrightarrow> x \<le> c"
   "x >\<^sub>l\<^sub>b Some c \<longleftrightarrow> x > c" "x <\<^sub>l\<^sub>b Some c \<longleftrightarrow> x < c"
   by (auto simp add: bound_compare_defs)
 
 fun in_bounds where
   "in_bounds x v (lb, ub) = (v x \<ge>\<^sub>l\<^sub>b lb x \<and> v x \<le>\<^sub>u\<^sub>b ub x)"
 
 fun satisfies_bounds :: "'a::linorder valuation \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>b" 100) where
   "v \<Turnstile>\<^sub>b b \<longleftrightarrow> (\<forall> x. in_bounds x v b)"
 declare satisfies_bounds.simps [simp del]
 
 
 lemma satisfies_bounds_iff:
   "v \<Turnstile>\<^sub>b (lb, ub) \<longleftrightarrow> (\<forall> x. v x \<ge>\<^sub>l\<^sub>b lb x \<and> v x \<le>\<^sub>u\<^sub>b ub x)"
   by (auto simp add: satisfies_bounds.simps)
 
 lemma not_in_bounds:
   "\<not> (in_bounds x v (lb, ub)) = (v x <\<^sub>l\<^sub>b lb x \<or> v x >\<^sub>u\<^sub>b ub x)"
   using bounds_compare_contradictory(7)
   using bounds_compare_contradictory(2)
   using neg_bounds_compare(7)[of "v x" "lb x"]
   using neg_bounds_compare(2)[of "v x" "ub x"]
   by auto
 
 fun atoms_equiv_bounds :: "'a::linorder atom set \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> bool" (infixl "\<doteq>" 100) where
   "as \<doteq> (lb, ub) \<longleftrightarrow> (\<forall> v. v \<Turnstile>\<^sub>a\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>b (lb, ub))"
 declare atoms_equiv_bounds.simps [simp del]
 
 lemma atoms_equiv_bounds_simps:
   "as \<doteq> (lb, ub) \<equiv> \<forall> v. v \<Turnstile>\<^sub>a\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>b (lb, ub)"
   by (simp add: atoms_equiv_bounds.simps)
 
 text\<open>A valuation satisfies bounds iff the value of each variable
 respects both its lower and upper bound, i.e, @{thm
 satisfies_bounds_iff[no_vars]}. Asserted atoms are precisely encoded
 by the current bounds in a state (denoted by \<open>\<doteq>\<close>) if every
 valuation satisfies them iff it satisfies the bounds, i.e.,
 @{thm atoms_equiv_bounds_simps[no_vars, iff]}.\<close>
 
 text\<open>The procedure also keeps track of a valuation that is a
 candidate solution. Whenever a new atom is asserted, it is checked
 whether the valuation is still satisfying. If not, the procedure tries
 to fix that by changing it and changing the tableau if necessary (but
 so that it remains equivalent to the initial tableau).\<close>
 
 text\<open>Therefore, the state of the procedure stores the tableau
 (denoted by \<open>\<T>\<close>), lower and upper bounds (denoted by \<open>\<B>\<^sub>l\<close> and \<open>\<B>\<^sub>u\<close>, and ordered pair of lower and upper bounds
 denoted by \<open>\<B>\<close>), candidate solution (denoted by \<open>\<V>\<close>)
 and a flag (denoted by \<open>\<U>\<close>) indicating if unsatisfiability has
 been detected so far:\<close>
 
 text\<open>Since we also need to now about the indices of atoms, actually,
   the bounds are also indexed, and in addition to the flag for unsatisfiability,
   we also store an optional unsat core.\<close>
 
 type_synonym 'i bound_index = "var \<Rightarrow> 'i"
 
 type_synonym ('i,'a) bounds_index = "(var, ('i \<times> 'a))mapping"
 
 datatype ('i,'a) state = State
   (\<T>: "tableau")
   (\<B>\<^sub>i\<^sub>l: "('i,'a) bounds_index")
   (\<B>\<^sub>i\<^sub>u: "('i,'a) bounds_index")
   (\<V>: "(var, 'a) mapping")
   (\<U>: bool)
   (\<U>\<^sub>c: "'i list option")
 
 definition indexl :: "('i,'a) state \<Rightarrow> 'i bound_index" ("\<I>\<^sub>l") where
   "\<I>\<^sub>l s = (fst o the) o look (\<B>\<^sub>i\<^sub>l s)"
 
 definition boundsl :: "('i,'a) state \<Rightarrow> 'a bounds" ("\<B>\<^sub>l") where
   "\<B>\<^sub>l s = map_option snd o look (\<B>\<^sub>i\<^sub>l s)"
 
 definition indexu :: "('i,'a) state \<Rightarrow> 'i bound_index" ("\<I>\<^sub>u") where
   "\<I>\<^sub>u s = (fst o the) o look (\<B>\<^sub>i\<^sub>u s)"
 
 definition boundsu :: "('i,'a) state \<Rightarrow> 'a bounds" ("\<B>\<^sub>u") where
   "\<B>\<^sub>u s = map_option snd o look (\<B>\<^sub>i\<^sub>u s)"
 
 abbreviation BoundsIndicesMap ("\<B>\<^sub>i") where  "\<B>\<^sub>i s \<equiv> (\<B>\<^sub>i\<^sub>l s, \<B>\<^sub>i\<^sub>u s)"
 abbreviation Bounds :: "('i,'a) state \<Rightarrow> 'a bounds \<times> 'a bounds" ("\<B>") where  "\<B> s \<equiv> (\<B>\<^sub>l s, \<B>\<^sub>u s)"
 abbreviation Indices :: "('i,'a) state \<Rightarrow> 'i bound_index \<times> 'i bound_index" ("\<I>") where  "\<I> s \<equiv> (\<I>\<^sub>l s, \<I>\<^sub>u s)"
 abbreviation BoundsIndices :: "('i,'a) state \<Rightarrow> ('a bounds \<times> 'a bounds) \<times> ('i bound_index \<times> 'i bound_index)" ("\<B>\<I>")
   where  "\<B>\<I> s \<equiv> (\<B> s, \<I> s)"
 
 fun satisfies_bounds_index :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('a bounds \<times> 'a bounds) \<times>
   ('i bound_index \<times> 'i bound_index) \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>b" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>b ((BL,BU),(IL,IU)) \<longleftrightarrow> (
      (\<forall> x c. BL x = Some c \<longrightarrow> IL x \<in> I \<longrightarrow> v x \<ge> c)
    \<and> (\<forall> x c. BU x = Some c \<longrightarrow> IU x \<in> I \<longrightarrow> v x \<le> c))"
 declare satisfies_bounds_index.simps[simp del]
 
 fun satisfies_bounds_index' :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('a bounds \<times> 'a bounds) \<times>
   ('i bound_index \<times> 'i bound_index) \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>b\<^sub>e" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e ((BL,BU),(IL,IU)) \<longleftrightarrow> (
      (\<forall> x c. BL x = Some c \<longrightarrow> IL x \<in> I \<longrightarrow> v x = c)
    \<and> (\<forall> x c. BU x = Some c \<longrightarrow> IU x \<in> I \<longrightarrow> v x = c))"
 declare satisfies_bounds_index'.simps[simp del]
 
 fun atoms_imply_bounds_index :: "('i,'a::lrv) i_atom set \<Rightarrow> ('a bounds \<times> 'a bounds) \<times> ('i bound_index \<times> 'i bound_index)
   \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i" 100) where
   "as \<Turnstile>\<^sub>i bi \<longleftrightarrow> (\<forall> I v. (I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as \<longrightarrow> (I,v) \<Turnstile>\<^sub>i\<^sub>b bi)"
 declare atoms_imply_bounds_index.simps[simp del]
 
 lemma i_satisfies_atom_set_mono: "as \<subseteq> as' \<Longrightarrow> v \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as' \<Longrightarrow> v \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as"
   by (cases v, auto simp: satisfies_atom_set_def)
 
 lemma atoms_imply_bounds_index_mono: "as \<subseteq> as' \<Longrightarrow> as \<Turnstile>\<^sub>i bi \<Longrightarrow> as' \<Turnstile>\<^sub>i bi"
   unfolding atoms_imply_bounds_index.simps using i_satisfies_atom_set_mono by blast
 
 definition satisfies_state :: "'a::lrv valuation \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>s s \<equiv> v \<Turnstile>\<^sub>b \<B> s \<and> v \<Turnstile>\<^sub>t \<T> s"
 
 definition curr_val_satisfies_state :: "('i,'a::lrv) state \<Rightarrow> bool" ("\<Turnstile>") where
   "\<Turnstile> s \<equiv> \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>s s"
 
 fun satisfies_state_index :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>s s \<longleftrightarrow> (v \<Turnstile>\<^sub>t \<T> s \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>b \<B>\<I> s)"
 declare satisfies_state_index.simps[simp del]
 
 fun satisfies_state_index' :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>s\<^sub>e" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s \<longleftrightarrow> (v \<Turnstile>\<^sub>t \<T> s \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e \<B>\<I> s)"
 declare satisfies_state_index'.simps[simp del]
 
 definition indices_state :: "('i,'a)state \<Rightarrow> 'i set" where
   "indices_state s = { i. \<exists> x b. look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b)}"
 
 text \<open>distinctness requires that for each index $i$, there is at most one variable $x$ and bound
   $b$ such that $x \leq b$ or $x \geq b$ or both are enforced.\<close>
 definition distinct_indices_state :: "('i,'a)state \<Rightarrow> bool" where
   "distinct_indices_state s = (\<forall> i x b x' b'. 
     ((look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b)) \<longrightarrow>
     (look (\<B>\<^sub>i\<^sub>l s) x' = Some (i,b') \<or> look (\<B>\<^sub>i\<^sub>u s) x' = Some (i,b')) \<longrightarrow>
     (x = x' \<and> b = b')))" 
 
 lemma distinct_indices_stateD: assumes "distinct_indices_state s"
   shows "look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b) \<Longrightarrow> look (\<B>\<^sub>i\<^sub>l s) x' = Some (i,b') \<or> look (\<B>\<^sub>i\<^sub>u s) x' = Some (i,b')
     \<Longrightarrow> x = x' \<and> b = b'" 
   using assms unfolding distinct_indices_state_def by blast+
 
 definition unsat_state_core :: "('i,'a::lrv) state \<Rightarrow> bool" where
   "unsat_state_core s = (set (the (\<U>\<^sub>c s)) \<subseteq> indices_state s \<and> (\<not> (\<exists> v. (set (the (\<U>\<^sub>c s)),v) \<Turnstile>\<^sub>i\<^sub>s s)))"
 
 definition subsets_sat_core :: "('i,'a::lrv) state \<Rightarrow> bool" where
   "subsets_sat_core s = ((\<forall> I. I \<subset> set (the (\<U>\<^sub>c s)) \<longrightarrow> (\<exists> v. (I,v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s)))" 
 
 definition minimal_unsat_state_core :: "('i,'a::lrv) state \<Rightarrow> bool" where
   "minimal_unsat_state_core s = (unsat_state_core s \<and> (distinct_indices_state s \<longrightarrow> subsets_sat_core s))" 
 
 lemma minimal_unsat_core_tabl_atoms_mono: assumes sub: "as \<subseteq> bs" 
   and unsat: "minimal_unsat_core_tabl_atoms I t as" 
 shows "minimal_unsat_core_tabl_atoms I t bs" 
   unfolding minimal_unsat_core_tabl_atoms_def
 proof (intro conjI impI allI)
   note min = unsat[unfolded minimal_unsat_core_tabl_atoms_def]
   from min have I: "I \<subseteq> fst ` as" by blast
   with sub show "I \<subseteq> fst ` bs" by blast
   from min have "(\<nexists>v. v \<Turnstile>\<^sub>t t \<and> (I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as)" by blast
   with i_satisfies_atom_set_mono[OF sub]
   show "(\<nexists>v. v \<Turnstile>\<^sub>t t \<and> (I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s bs)" by blast
   fix J
   assume J: "J \<subset> I" and dist_bs: "distinct_indices_atoms bs" 
   hence dist: "distinct_indices_atoms as" 
     using sub unfolding distinct_indices_atoms_def by blast
   from min dist J obtain v where v: "v \<Turnstile>\<^sub>t t" "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" by blast
   have "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s bs"
     unfolding i_satisfies_atom_set'.simps
   proof (intro ballI)
     fix a
     assume "a \<in> snd ` (bs \<inter> J \<times> UNIV)" 
     then obtain i where ia: "(i,a) \<in> bs" and i: "i \<in> J" 
       by force
     with J have "i \<in> I" by auto 
     with I obtain b where ib: "(i,b) \<in> as" by force
     with sub have ib': "(i,b) \<in> bs" by auto
     from dist_bs[unfolded distinct_indices_atoms_def, rule_format, OF ia ib']
     have id: "atom_var a = atom_var b" "atom_const a = atom_const b" by auto
     from v(2)[unfolded i_satisfies_atom_set'.simps] i ib 
     have "v \<Turnstile>\<^sub>a\<^sub>e b" by force
     thus "v \<Turnstile>\<^sub>a\<^sub>e a" using id unfolding satisfies_atom'_def by auto
   qed
   with v show "\<exists>v. v \<Turnstile>\<^sub>t t \<and> (J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s bs" by blast
 qed
 
 lemma state_satisfies_index: assumes "v \<Turnstile>\<^sub>s s"
   shows "(I,v) \<Turnstile>\<^sub>i\<^sub>s s"
   unfolding satisfies_state_index.simps satisfies_bounds_index.simps
 proof (intro conjI impI allI)
   fix x c
   from assms[unfolded satisfies_state_def satisfies_bounds.simps, simplified]
   have "v \<Turnstile>\<^sub>t \<T> s" and bnd: "v x \<ge>\<^sub>l\<^sub>b \<B>\<^sub>l s x" "v x \<le>\<^sub>u\<^sub>b \<B>\<^sub>u s x" by auto
   show "v \<Turnstile>\<^sub>t \<T> s" by fact
   show "\<B>\<^sub>l s x = Some c \<Longrightarrow> \<I>\<^sub>l s x \<in> I \<Longrightarrow> c \<le> v x"
     using bnd(1) by auto
   show "\<B>\<^sub>u s x = Some c \<Longrightarrow> \<I>\<^sub>u s x \<in> I \<Longrightarrow> v x \<le> c"
     using bnd(2) by auto
 qed
 
 lemma unsat_state_core_unsat: "unsat_state_core s \<Longrightarrow> \<not> (\<exists> v. v \<Turnstile>\<^sub>s s)"
   unfolding unsat_state_core_def using state_satisfies_index by blast
 
 definition tableau_valuated ("\<nabla>") where
   "\<nabla> s \<equiv> \<forall> x \<in> tvars (\<T> s). Mapping.lookup (\<V> s) x \<noteq> None"
 
 definition index_valid where
   "index_valid as (s :: ('i,'a) state) = (\<forall> x b i.
       (look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<longrightarrow> ((i, Geq x b) \<in> as))
     \<and> (look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b) \<longrightarrow> ((i, Leq x b) \<in> as)))"
 
 lemma index_valid_indices_state: "index_valid as s \<Longrightarrow> indices_state s \<subseteq> fst ` as"
   unfolding index_valid_def indices_state_def by force
 
 lemma index_valid_mono: "as \<subseteq> bs \<Longrightarrow> index_valid as s \<Longrightarrow> index_valid bs s"
   unfolding index_valid_def by blast
 
 lemma index_valid_distinct_indices: assumes "index_valid as s" 
   and "distinct_indices_atoms as" 
 shows "distinct_indices_state s" 
   unfolding distinct_indices_state_def
 proof (intro allI impI, goal_cases)
   case (1 i x b y c)
   note valid = assms(1)[unfolded index_valid_def, rule_format]
   from 1(1) valid[of x i b] have "(i, Geq x b) \<in> as \<or> (i, Leq x b) \<in> as" by auto
   then obtain a where a: "(i,a) \<in> as" "atom_var a = x" "atom_const a = b" by auto
   from 1(2) valid[of y i c] have y: "(i, Geq y c) \<in> as \<or> (i, Leq y c) \<in> as" by auto
   then obtain a' where a': "(i,a') \<in> as" "atom_var a' = y" "atom_const a' = c" by auto
   from assms(2)[unfolded distinct_indices_atoms_def, rule_format, OF a(1) a'(1)]
   show ?case using a a' by auto
 qed
 
 text\<open>To be a solution of the initial problem, a valuation should
 satisfy the initial tableau and list of atoms. Since tableau is
 changed only by equivalency preserving transformations and asserted
 atoms are encoded in the bounds, a valuation is a solution if it
 satisfies both the tableau and the bounds in the final state (when all
 atoms have been asserted). So, a valuation \<open>v\<close> satisfies a state
 \<open>s\<close> (denoted by \<open>\<Turnstile>\<^sub>s\<close>) if it satisfies the tableau and
 the bounds, i.e., @{thm satisfies_state_def [no_vars]}. Since \<open>\<V>\<close> should be a candidate solution, it should satisfy the state
 (unless the \<open>\<U>\<close> flag is raised). This is denoted by \<open>\<Turnstile> s\<close>
 and defined by @{thm curr_val_satisfies_state_def[no_vars]}. \<open>\<nabla>
 s\<close> will denote that all variables of \<open>\<T> s\<close> are explicitly
 valuated in \<open>\<V> s\<close>.\<close>
 
 definition update\<B>\<I> where
   [simp]: "update\<B>\<I> field_update i x c s = field_update (upd x (i,c)) s"
 
 fun \<B>\<^sub>i\<^sub>u_update where
   "\<B>\<^sub>i\<^sub>u_update up (State T BIL BIU V U UC) = State T BIL (up BIU) V U UC"
 
 fun \<B>\<^sub>i\<^sub>l_update where
   "\<B>\<^sub>i\<^sub>l_update up (State T BIL BIU V U UC) = State T (up BIL) BIU V U UC"
 
 fun \<V>_update where
   "\<V>_update V (State T BIL BIU V_old U UC) = State T BIL BIU V U UC"
 
 fun \<T>_update where
   "\<T>_update T (State T_old BIL BIU V U UC) = State T BIL BIU V U UC"
 
 lemma update_simps[simp]:
   "\<B>\<^sub>i\<^sub>u (\<B>\<^sub>i\<^sub>u_update up s) = up (\<B>\<^sub>i\<^sub>u s)"
   "\<B>\<^sub>i\<^sub>l (\<B>\<^sub>i\<^sub>u_update up s) = \<B>\<^sub>i\<^sub>l s"
   "\<T> (\<B>\<^sub>i\<^sub>u_update up s) = \<T> s"
   "\<V> (\<B>\<^sub>i\<^sub>u_update up s) = \<V> s"
   "\<U> (\<B>\<^sub>i\<^sub>u_update up s) = \<U> s"
   "\<U>\<^sub>c (\<B>\<^sub>i\<^sub>u_update up s) = \<U>\<^sub>c s"
   "\<B>\<^sub>i\<^sub>l (\<B>\<^sub>i\<^sub>l_update up s) = up (\<B>\<^sub>i\<^sub>l s)"
   "\<B>\<^sub>i\<^sub>u (\<B>\<^sub>i\<^sub>l_update up s) = \<B>\<^sub>i\<^sub>u s"
   "\<T> (\<B>\<^sub>i\<^sub>l_update up s) = \<T> s"
   "\<V> (\<B>\<^sub>i\<^sub>l_update up s) = \<V> s"
   "\<U> (\<B>\<^sub>i\<^sub>l_update up s) = \<U> s"
   "\<U>\<^sub>c (\<B>\<^sub>i\<^sub>l_update up s) = \<U>\<^sub>c s"
   "\<V> (\<V>_update V s) = V"
   "\<B>\<^sub>i\<^sub>l (\<V>_update V s) = \<B>\<^sub>i\<^sub>l s"
   "\<B>\<^sub>i\<^sub>u (\<V>_update V s) = \<B>\<^sub>i\<^sub>u s"
   "\<T> (\<V>_update V s) = \<T> s"
   "\<U> (\<V>_update V s) = \<U> s"
   "\<U>\<^sub>c (\<V>_update V s) = \<U>\<^sub>c s"
   "\<T> (\<T>_update T s) = T"
   "\<B>\<^sub>i\<^sub>l (\<T>_update T s) = \<B>\<^sub>i\<^sub>l s"
   "\<B>\<^sub>i\<^sub>u (\<T>_update T s) = \<B>\<^sub>i\<^sub>u s"
   "\<V> (\<T>_update T s) = \<V> s"
   "\<U> (\<T>_update T s) = \<U> s"
   "\<U>\<^sub>c (\<T>_update T s) = \<U>\<^sub>c s"
   by (atomize(full), cases s, auto)
 
 declare
   \<B>\<^sub>i\<^sub>u_update.simps[simp del]
   \<B>\<^sub>i\<^sub>l_update.simps[simp del]
 
 fun set_unsat :: "'i list \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "set_unsat I (State T BIL BIU V U UC) = State T BIL BIU V True (Some (remdups I))"
 
 lemma set_unsat_simps[simp]: "\<B>\<^sub>i\<^sub>l (set_unsat I s) = \<B>\<^sub>i\<^sub>l s"
   "\<B>\<^sub>i\<^sub>u (set_unsat I s) = \<B>\<^sub>i\<^sub>u s"
   "\<T> (set_unsat I s) = \<T> s"
   "\<V> (set_unsat I s) = \<V> s"
   "\<U> (set_unsat I s) = True"
   "\<U>\<^sub>c (set_unsat I s) = Some (remdups I)"
   by (atomize(full), cases s, auto)
 
 datatype ('i,'a) Direction = Direction
   (lt: "'a::linorder \<Rightarrow> 'a \<Rightarrow> bool")
   (LBI: "('i,'a) state \<Rightarrow> ('i,'a) bounds_index")
   (UBI: "('i,'a) state \<Rightarrow> ('i,'a) bounds_index")
   (LB: "('i,'a) state \<Rightarrow> 'a bounds")
   (UB: "('i,'a) state \<Rightarrow> 'a bounds")
   (LI: "('i,'a) state \<Rightarrow> 'i bound_index")
   (UI: "('i,'a) state \<Rightarrow> 'i bound_index")
   (UBI_upd: "(('i,'a) bounds_index \<Rightarrow> ('i,'a) bounds_index) \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state")
   (LE: "var \<Rightarrow> 'a \<Rightarrow> 'a atom")
   (GE: "var \<Rightarrow> 'a \<Rightarrow> 'a atom")
   (le_rat: "rat \<Rightarrow> rat \<Rightarrow> bool")
 
 definition Positive where
   [simp]: "Positive \<equiv> Direction (<) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<I>\<^sub>l \<I>\<^sub>u \<B>\<^sub>i\<^sub>u_update Leq Geq (\<le>)"
 
 definition Negative where
   [simp]: "Negative \<equiv> Direction (>) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<I>\<^sub>u \<I>\<^sub>l \<B>\<^sub>i\<^sub>l_update Geq Leq (\<ge>)"
 
 
 text\<open>Assuming that the \<open>\<U>\<close> flag and the current valuation
 \<open>\<V>\<close> in the final state determine the solution of a problem, the
 \<open>assert_all\<close> function can be reduced to the \<open>assert_all_state\<close>
 function that operates on the states:
 @{text[display] "assert_all t as \<equiv> let s = assert_all_state t as in
    if (\<U> s) then (False, None) else (True, Some (\<V> s))" }
 \<close>
 text\<open>Specification for the \<open>assert_all_state\<close> can be directly
 obtained from the specification of \<open>assert_all\<close>, and it describes
 the connection between the valuation in the final state and the
 initial tableau and atoms. However, we will make an additional
 refinement step and give stronger assumptions about the \<open>assert_all_state\<close> function that describes the connection between
 the initial tableau and atoms with the tableau and bounds in the final
 state.\<close>
 
 locale AssertAllState = fixes assert_all_state::"tableau \<Rightarrow> ('i,'a::lrv) i_atom list \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>The final and the initial tableau are equivalent.\<close>
     assert_all_state_tableau_equiv: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> (v::'a valuation) \<Turnstile>\<^sub>t t \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s'" and
 
 \<comment> \<open>If @{term \<U>} is not raised, then the valuation in the
 final state satisfies its tableau and its bounds (that are, in this
 case, equivalent to the set of all asserted bounds).\<close>
 assert_all_state_sat: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<not> \<U> s' \<Longrightarrow> \<Turnstile> s'" and
 
 assert_all_state_sat_atoms_equiv_bounds: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<not> \<U> s' \<Longrightarrow> flat (set as) \<doteq> \<B> s'" and
 
 \<comment> \<open>If @{term \<U>} is raised, then there is no valuation
    satisfying the tableau and the bounds in the final state (that are,
    in this case, equivalent to a subset of asserted atoms).\<close>
 assert_all_state_unsat: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<U> s' \<Longrightarrow> minimal_unsat_state_core s'"  and
 
 assert_all_state_unsat_atoms_equiv_bounds: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<U> s' \<Longrightarrow> set as \<Turnstile>\<^sub>i \<B>\<I> s'" and
 
 \<comment> \<open>The set of indices is taken from the constraints\<close>
 assert_all_state_indices: "\<triangle> t \<Longrightarrow> assert_all_state t as = s \<Longrightarrow> indices_state s \<subseteq> fst ` set as" and
 
 assert_all_index_valid: "\<triangle> t \<Longrightarrow> assert_all_state t as = s \<Longrightarrow> index_valid (set as) s"
 begin
 definition assert_all where
   "assert_all t as \<equiv> let s = assert_all_state t as in
      if (\<U> s) then Unsat (the (\<U>\<^sub>c s)) else Sat (\<V> s)"
 end
 
 text\<open>The \<open>assert_all_state\<close> function can be implemented by first
 applying the \<open>init\<close> function that creates an initial state based
 on the starting tableau, and then by iteratively applying the \<open>assert\<close> function for each atom in the starting atoms list.\<close>
 
 text\<open>
 \begin{small}
   \<open>assert_loop as s \<equiv> foldl (\<lambda> s' a. if (\<U> s') then s' else assert a s') s as\<close>
 
   \<open>assert_all_state t as \<equiv> assert_loop ats (init t)\<close>
 \end{small}
 \<close>
 
 
 locale Init' =
   fixes init :: "tableau \<Rightarrow> ('i,'a::lrv) state"
   assumes init'_tableau_normalized: "\<triangle> t \<Longrightarrow> \<triangle> (\<T> (init t))"
   assumes init'_tableau_equiv: "\<triangle> t \<Longrightarrow> (v::'a valuation) \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> (init t)"
   assumes init'_sat: "\<triangle> t \<Longrightarrow> \<not> \<U> (init t) \<longrightarrow> \<Turnstile> (init t)"
   assumes init'_unsat: "\<triangle> t \<Longrightarrow> \<U> (init t) \<longrightarrow> minimal_unsat_state_core (init t)"
   assumes init'_atoms_equiv_bounds: "\<triangle> t \<Longrightarrow> {} \<doteq> \<B> (init t)"
   assumes init'_atoms_imply_bounds_index: "\<triangle> t \<Longrightarrow> {} \<Turnstile>\<^sub>i \<B>\<I> (init t)"
 
 
 text\<open>Specification for \<open>init\<close> can be obtained from the
 specification of \<open>asser_all_state\<close> since all its assumptions
 must also hold for \<open>init\<close> (when the list of atoms is
 empty). Also, since \<open>init\<close> is the first step in the \<open>assert_all_state\<close> implementation, the precondition for \<open>init\<close>
 the same as for the \<open>assert_all_state\<close>. However,
 unsatisfiability is never going to be detected during initialization
 and @{term \<U>} flag is never going to be raised. Also, the tableau in
 the initial state can just be initialized with the starting
 tableau. The condition @{term "{} \<doteq> \<B> (init t)"} is equivalent to
 asking that initial bounds are empty. Therefore, specification for
 \<open>init\<close> can be refined to:\<close>
 
 locale Init = fixes init::"tableau \<Rightarrow> ('i,'a::lrv) state"
   assumes
     \<comment> \<open>Tableau in the initial state for @{text t} is @{text t}:\<close> init_tableau_id: "\<T> (init t) = t" and
 
 \<comment> \<open>Since unsatisfiability is not detected, @{text \<U>}
      flag must not be set:\<close> init_unsat_flag: "\<not> \<U> (init t)" and
 
 \<comment> \<open>The current valuation must satisfy the tableau:\<close> init_satisfies_tableau: "\<langle>\<V> (init t)\<rangle> \<Turnstile>\<^sub>t t" and
 
 \<comment> \<open>In an inital state no atoms are yet asserted so the bounds
      must be empty:\<close>
 init_bounds: "\<B>\<^sub>i\<^sub>l (init t) = Mapping.empty"   "\<B>\<^sub>i\<^sub>u (init t) = Mapping.empty"  and
 
 \<comment> \<open>All tableau vars are valuated:\<close> init_tableau_valuated: "\<nabla> (init t)"
 
 begin
 
 
 lemma init_satisfies_bounds:
   "\<langle>\<V> (init t)\<rangle> \<Turnstile>\<^sub>b \<B> (init t)"
   using init_bounds
   unfolding satisfies_bounds.simps in_bounds.simps bound_compare_defs
   by (auto simp: boundsl_def boundsu_def)
 
 lemma init_satisfies:
   "\<Turnstile> (init t)"
   using init_satisfies_tableau init_satisfies_bounds init_tableau_id
   unfolding curr_val_satisfies_state_def satisfies_state_def
   by simp
 
 lemma init_atoms_equiv_bounds:
   "{} \<doteq> \<B> (init t)"
   using init_bounds
   unfolding atoms_equiv_bounds.simps satisfies_bounds.simps in_bounds.simps satisfies_atom_set_def
   unfolding bound_compare_defs
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma init_atoms_imply_bounds_index:
   "{} \<Turnstile>\<^sub>i \<B>\<I> (init t)"
   using init_bounds
   unfolding atoms_imply_bounds_index.simps satisfies_bounds_index.simps in_bounds.simps
     i_satisfies_atom_set.simps satisfies_atom_set_def
   unfolding bound_compare_defs
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 
 lemma init_tableau_normalized:
   "\<triangle> t \<Longrightarrow> \<triangle> (\<T> (init t))"
   using init_tableau_id
   by simp
 
 lemma init_index_valid: "index_valid as (init t)"
   using init_bounds unfolding index_valid_def by auto
 
 lemma init_indices: "indices_state (init t) = {}"
   unfolding indices_state_def init_bounds by auto
 end
 
 
 sublocale Init < Init' init
   using init_tableau_id init_satisfies init_unsat_flag init_atoms_equiv_bounds init_atoms_imply_bounds_index
   by unfold_locales auto
 
 
 
 abbreviation vars_list where
   "vars_list t \<equiv> remdups (map lhs t @ (concat (map (Abstract_Linear_Poly.vars_list \<circ> rhs) t)))"
 
 lemma "tvars t = set (vars_list t)"
   by (auto simp add: set_vars_list lvars_def rvars_def)
 
 
 text\<open>\smallskip The \<open>assert\<close> function asserts a single
 atom. Since the \<open>init\<close> function does not raise the \<open>\<U>\<close>
 flag, from the definition of \<open>assert_loop\<close>, it is clear that the
 flag is not raised when the \<open>assert\<close> function is
 called. Moreover, the assumptions about the \<open>assert_all_state\<close>
 imply that the loop invariant must be that if the \<open>\<U>\<close> flag is
 not raised, then the current valuation must satisfy the state (i.e.,
 \<open>\<Turnstile> s\<close>). The \<open>assert\<close> function will be more easily
 implemented if it is always applied to a state with a normalized and
 valuated tableau, so we make this another loop invariant. Therefore,
 the precondition for the \<open>assert a s\<close> function call is that
 \<open>\<not> \<U> s\<close>, \<open>\<Turnstile> s\<close>, \<open>\<triangle> (\<T> s)\<close> and \<open>\<nabla> s\<close>
 hold. The specification for \<open>assert\<close> directly follows from the
 specification of \<open>assert_all_state\<close> (except that it is
 additionally required that bounds reflect asserted atoms also when
 unsatisfiability is detected, and that it is required that \<open>assert\<close> keeps the tableau normalized and valuated).\<close>
 
 locale Assert = fixes assert::"('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>Tableau remains equivalent to the previous one and normalized and valuated.\<close>
     assert_tableau: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> let s' = assert a s in
      ((v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') \<and> \<nabla> s'" and
 
 \<comment> \<open>If the @{term \<U>} flag is not raised, then the current
    valuation is updated so that it satisfies the current tableau and
    the current bounds.\<close>
 assert_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<not> \<U> (assert a s) \<Longrightarrow> \<Turnstile> (assert a s)" and
 
 \<comment> \<open>The set of asserted atoms remains equivalent to the bounds
     in the state.\<close>
 assert_atoms_equiv_bounds: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert a s)" and
 
 \<comment> \<open>There is a subset of asserted atoms which remains index-equivalent to the bounds
     in the state.\<close>
 assert_atoms_imply_bounds_index: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> ats \<Turnstile>\<^sub>i \<B>\<I> s \<Longrightarrow>
   insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert a s)" and
 
 \<comment> \<open>If the @{term \<U>} flag is raised, then there is no valuation
    that satisfies both the current tableau and the current bounds.\<close>
 assert_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s; index_valid ats s\<rbrakk> \<Longrightarrow> \<U> (assert a s) \<Longrightarrow>  minimal_unsat_state_core (assert a s)" and
 
 assert_index_valid: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> index_valid ats s \<Longrightarrow> index_valid (insert a ats) (assert a s)"
 
 begin
 lemma assert_tableau_equiv: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> (v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (assert a s)"
   using assert_tableau
   by (simp add: Let_def)
 
 lemma assert_tableau_normalized: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<triangle> (\<T> (assert a s))"
   using assert_tableau
   by (simp add: Let_def)
 
 lemma assert_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (assert a s)"
   using assert_tableau
   by (simp add: Let_def)
 end
 
 
 
 locale AssertAllState' = Init init + Assert assert for
   init :: "tableau \<Rightarrow> ('i,'a::lrv) state" and assert :: "('i,'a) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
 begin
 
 definition assert_loop where
   "assert_loop as s \<equiv> foldl (\<lambda> s' a. if (\<U> s') then s' else assert a s') s as"
 
 definition assert_all_state where [simp]:
   "assert_all_state t as \<equiv> assert_loop as (init t)"
 
 
 lemma AssertAllState'_precond:
   "\<triangle> t \<Longrightarrow> \<triangle> (\<T> (assert_all_state t as))
     \<and> (\<nabla> (assert_all_state t as))
     \<and> (\<not> \<U> (assert_all_state t as) \<longrightarrow> \<Turnstile> (assert_all_state t as))"
   unfolding assert_all_state_def assert_loop_def
   using init_satisfies init_tableau_normalized init_index_valid
   using assert_sat assert_tableau_normalized init_tableau_valuated assert_tableau_valuated
   by (induct as rule: rev_induct) auto
 
 lemma AssertAllState'Induct:
   assumes
     "\<triangle> t"
     "P {} (init t)"
     "\<And> as bs t. as \<subseteq> bs \<Longrightarrow> P as t \<Longrightarrow> P bs t"
     "\<And> s a as. \<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s; P as s; index_valid as s\<rbrakk> \<Longrightarrow> P (insert a as) (assert a s)"
   shows "P (set as) (assert_all_state t as)"
 proof -
   have "P (set as) (assert_all_state t as) \<and> index_valid (set as) (assert_all_state t as)"
   proof (induct as rule: rev_induct)
     case Nil
     then show ?case
       unfolding assert_all_state_def assert_loop_def
       using assms(2) init_index_valid by auto
   next
     case (snoc a as')
     let ?f = "\<lambda>s' a. if \<U> s' then s' else assert a s'"
     let ?s = "foldl ?f (init t) as'"
     show ?case
     proof (cases "\<U> ?s")
       case True
       from snoc index_valid_mono[of _ "set (a # as')" "(assert_all_state t as')"]
       have index: "index_valid (set (a # as')) (assert_all_state t as')"
         by auto
       from snoc assms(3)[of "set as'" "set (a # as')"]
       have P: "P (set (a # as')) (assert_all_state t as')" by auto
       show ?thesis
         using True P index
         unfolding assert_all_state_def assert_loop_def
         by simp
     next
       case False
       then show ?thesis
         using snoc
         using assms(1) assms(4)
         using AssertAllState'_precond assert_index_valid
         unfolding assert_all_state_def assert_loop_def
         by auto
     qed
   qed
   then show ?thesis ..
 qed
 
 lemma AssertAllState_index_valid: "\<triangle> t \<Longrightarrow> index_valid (set as) (assert_all_state t as)"
   by (rule AssertAllState'Induct, auto intro: assert_index_valid init_index_valid index_valid_mono)
 
 lemma AssertAllState'_sat_atoms_equiv_bounds:
   "\<triangle> t \<Longrightarrow> \<not> \<U> (assert_all_state t as) \<Longrightarrow> flat (set as) \<doteq> \<B> (assert_all_state t as)"
   using AssertAllState'_precond
   using init_atoms_equiv_bounds assert_atoms_equiv_bounds
   unfolding assert_all_state_def assert_loop_def
   by (induct as rule: rev_induct) auto
 
 lemma AssertAllState'_unsat_atoms_implies_bounds:
   assumes "\<triangle> t"
   shows "set as \<Turnstile>\<^sub>i \<B>\<I> (assert_all_state t as)"
 proof (induct as rule: rev_induct)
   case Nil
   then show ?case
     using assms init_atoms_imply_bounds_index
     unfolding assert_all_state_def assert_loop_def
     by simp
 next
   case (snoc a as')
   let ?s = "assert_all_state t as'"
   show ?case
   proof (cases "\<U> ?s")
     case True
     then show ?thesis
       using snoc atoms_imply_bounds_index_mono[of "set as'" "set (as' @ [a])"]
       unfolding assert_all_state_def assert_loop_def
       by auto
   next
     case False
     then have id: "assert_all_state t (as' @ [a]) = assert a ?s"
       unfolding assert_all_state_def assert_loop_def by simp
     from snoc have as': "set as' \<Turnstile>\<^sub>i \<B>\<I> ?s" by auto
     from AssertAllState'_precond[of t as'] assms False
     have "\<Turnstile> ?s" "\<triangle> (\<T> ?s)" "\<nabla> ?s" by auto
     from assert_atoms_imply_bounds_index[OF False this as', of a]
     show ?thesis unfolding id by auto
   qed
 qed
 
 end
 
 text\<open>Under these assumptions, it can easily be shown (mainly by
 induction) that the previously shown implementation of \<open>assert_all_state\<close> satisfies its specification.\<close>
 
 sublocale AssertAllState' < AssertAllState assert_all_state
 proof
   fix v::"'a valuation" and t as s'
   assume *: "\<triangle> t" and id: "assert_all_state t as = s'"
   note idsym = id[symmetric]
 
   show "v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> s'" unfolding idsym
     using  init_tableau_id[of t] assert_tableau_equiv[of _ v]
     by (induct rule: AssertAllState'Induct) (auto simp add: * )
 
   show "\<not> \<U> s' \<Longrightarrow> \<Turnstile> s'" unfolding idsym
     using AssertAllState'_precond by (simp add: * )
 
   show "\<not> \<U> s' \<Longrightarrow> flat (set as) \<doteq> \<B> s'"
     unfolding idsym
     using *
     by (rule AssertAllState'_sat_atoms_equiv_bounds)
 
   show "\<U> s' \<Longrightarrow> set as \<Turnstile>\<^sub>i \<B>\<I> s'"
     using * unfolding idsym
     by (rule AssertAllState'_unsat_atoms_implies_bounds)
 
   show "\<U> s' \<Longrightarrow> minimal_unsat_state_core s'"
     using init_unsat_flag assert_unsat assert_index_valid unfolding idsym
     by (induct rule: AssertAllState'Induct) (auto simp add: * )
 
   show "indices_state s' \<subseteq> fst ` set as" unfolding idsym using *
     by (intro index_valid_indices_state, induct rule: AssertAllState'Induct,
         auto simp: init_index_valid index_valid_mono assert_index_valid)
 
   show "index_valid (set as) s'" using "*" AssertAllState_index_valid idsym by blast
 qed
 
 
 subsection\<open>Asserting Single Atoms\<close>
 
 text\<open>The @{term assert} function is split in two phases. First,
 @{term assert_bound} updates the bounds and checks only for conflicts
 cheap to detect. Next, \<open>check\<close> performs the full simplex
 algorithm. The \<open>assert\<close> function can be implemented as \<open>assert a s = check (assert_bound a s)\<close>. Note that it is also
 possible to do the first phase for several asserted atoms, and only
 then to let the expensive second phase work.
 
 \medskip Asserting an atom \<open>x \<bowtie> b\<close> begins with the function
 \<open>assert_bound\<close>.  If the atom is subsumed by the current bounds,
 then no changes are performed. Otherwise, bounds for \<open>x\<close> are
 changed to incorporate the atom. If the atom is inconsistent with the
 previous bounds for \<open>x\<close>, the @{term \<U>} flag is raised. If
 \<open>x\<close> is not a lhs variable in the current tableau and if the
 value for \<open>x\<close> in the current valuation violates the new bound
 \<open>b\<close>, the value for \<open>x\<close> can be updated and set to
 \<open>b\<close>, meanwhile updating the values for lhs variables of
 the tableau so that it remains satisfied. Otherwise, no changes to the
 current valuation are performed.\<close>
 
 fun satisfies_bounds_set  :: "'a::linorder valuation \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> var set \<Rightarrow> bool" where
   "satisfies_bounds_set v (lb, ub) S \<longleftrightarrow> (\<forall> x \<in> S. in_bounds x v (lb, ub))"
 declare satisfies_bounds_set.simps [simp del]
 syntax
   "_satisfies_bounds_set" :: "(var \<Rightarrow> 'a::linorder) \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> var set \<Rightarrow> bool"    ("_ \<Turnstile>\<^sub>b _ \<parallel>/ _")
 translations
   "v \<Turnstile>\<^sub>b b \<parallel> S" == "CONST satisfies_bounds_set v b S"
 lemma satisfies_bounds_set_iff:
   "v \<Turnstile>\<^sub>b (lb, ub) \<parallel> S \<equiv> (\<forall> x \<in> S. v x \<ge>\<^sub>l\<^sub>b lb x \<and> v x \<le>\<^sub>u\<^sub>b ub x)"
   by (simp add: satisfies_bounds_set.simps)
 
 
 definition curr_val_satisfies_no_lhs ("\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s") where
   "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s \<equiv> \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t (\<T> s) \<and> (\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>b (\<B> s) \<parallel> (- lvars (\<T> s)))"
 lemma satisfies_satisfies_no_lhs:
   "\<Turnstile> s \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
   by (simp add: curr_val_satisfies_state_def satisfies_state_def curr_val_satisfies_no_lhs_def satisfies_bounds.simps satisfies_bounds_set.simps)
 
 
 definition bounds_consistent :: "('i,'a::linorder) state \<Rightarrow> bool" ("\<diamond>") where
   "\<diamond> s \<equiv>
    \<forall> x. if \<B>\<^sub>l s x = None \<or> \<B>\<^sub>u s x = None then True else the (\<B>\<^sub>l s x) \<le> the (\<B>\<^sub>u s x)"
 
 
 text\<open>So, the \<open>assert_bound\<close> function must ensure that the
 given atom is included in the bounds, that the tableau remains
 satisfied by the valuation and that all variables except the lhs variables
 in the tableau are within their
 bounds. To formalize this, we introduce the notation \<open>v
 \<Turnstile>\<^sub>b (lb, ub) \<parallel> S\<close>, and define @{thm
 satisfies_bounds_set_iff[no_vars]}, and @{thm
 curr_val_satisfies_no_lhs_def[no_vars]}. The \<open>assert_bound\<close>
 function raises the \<open>\<U>\<close> flag if and only if lower and upper
 bounds overlap. This is formalized as @{thm
 bounds_consistent_def[no_vars]}.\<close>
 
 
 lemma satisfies_bounds_consistent:
   "(v::'a::linorder valuation) \<Turnstile>\<^sub>b \<B> s \<longrightarrow> \<diamond> s"
   unfolding satisfies_bounds.simps in_bounds.simps bounds_consistent_def bound_compare_defs
   by (auto split: option.split) force
 
 lemma satisfies_consistent:
   "\<Turnstile> s \<longrightarrow> \<diamond> s"
   by (auto simp add: curr_val_satisfies_state_def satisfies_state_def satisfies_bounds_consistent)
 
 lemma bounds_consistent_geq_lb:
   "\<lbrakk>\<diamond> s; \<B>\<^sub>u s x\<^sub>i = Some c\<rbrakk>
     \<Longrightarrow> c \<ge>\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i"
   unfolding bounds_consistent_def
   by (cases "\<B>\<^sub>l s x\<^sub>i", auto simp add: bound_compare_defs split: if_splits)
     (erule_tac x="x\<^sub>i" in allE, auto)
 
 lemma bounds_consistent_leq_ub:
   "\<lbrakk>\<diamond> s; \<B>\<^sub>l s x\<^sub>i = Some c\<rbrakk>
     \<Longrightarrow> c \<le>\<^sub>u\<^sub>b \<B>\<^sub>u s x\<^sub>i"
   unfolding bounds_consistent_def
   by (cases "\<B>\<^sub>u s x\<^sub>i", auto simp add: bound_compare_defs split: if_splits)
     (erule_tac x="x\<^sub>i" in allE, auto)
 
 lemma bounds_consistent_gt_ub:
   "\<lbrakk>\<diamond> s; c <\<^sub>l\<^sub>b \<B>\<^sub>l s x \<rbrakk> \<Longrightarrow> \<not> c >\<^sub>u\<^sub>b \<B>\<^sub>u s x"
   unfolding bounds_consistent_def
   by (case_tac[!] "\<B>\<^sub>l s x", case_tac[!] "\<B>\<^sub>u s x")
     (auto simp add: bound_compare_defs, erule_tac x="x" in allE, simp)
 
 lemma bounds_consistent_lt_lb:
   "\<lbrakk>\<diamond> s; c >\<^sub>u\<^sub>b \<B>\<^sub>u s x \<rbrakk> \<Longrightarrow> \<not> c <\<^sub>l\<^sub>b \<B>\<^sub>l s x"
   unfolding bounds_consistent_def
   by (case_tac[!] "\<B>\<^sub>l s x", case_tac[!] "\<B>\<^sub>u s x")
     (auto simp add: bound_compare_defs, erule_tac x="x" in allE, simp)
 
 
 text\<open>Since the \<open>assert_bound\<close> is the first step in the \<open>assert\<close> function implementation, the preconditions for \<open>assert_bound\<close> are the same as preconditions for the \<open>assert\<close>
 function. The specifiction for the \<open>assert_bound\<close> is:\<close>
 
 locale AssertBound = fixes assert_bound::"('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>The tableau remains unchanged and valuated.\<close>
 
 assert_bound_tableau: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> assert_bound a s = s' \<Longrightarrow> \<T> s' = \<T> s \<and> \<nabla> s'" and
 
 \<comment> \<open>If the @{term \<U>} flag is not set, all but the
    lhs variables in the tableau remain within their bounds,
    the new valuation satisfies the tableau, and bounds do not overlap.\<close>
 assert_bound_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> assert_bound a s = s' \<Longrightarrow> \<not> \<U> s' \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<and> \<diamond> s'" and
 
 \<comment> \<open>The set of asserted atoms remains equivalent to the bounds in the state.\<close>
 
 assert_bound_atoms_equiv_bounds: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
   flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert_bound a s)" and
 
 assert_bound_atoms_imply_bounds_index: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
   ats \<Turnstile>\<^sub>i \<B>\<I> s \<Longrightarrow> insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound a s)" and
 
 \<comment> \<open>@{term \<U>} flag is raised, only if the bounds became inconsistent:\<close>
 
 assert_bound_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> index_valid as s \<Longrightarrow> assert_bound a s = s' \<Longrightarrow> \<U> s' \<Longrightarrow> minimal_unsat_state_core s'" and
 
 assert_bound_index_valid: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> index_valid as s \<Longrightarrow> index_valid (insert a as) (assert_bound a s)"
 
 begin
 lemma assert_bound_tableau_id: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<T> (assert_bound a s) = \<T> s"
   using assert_bound_tableau by blast
 
 lemma assert_bound_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (assert_bound a s)"
   using assert_bound_tableau by blast
 
 end
 
 locale AssertBoundNoLhs =
   fixes assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes assert_bound_nolhs_tableau_id: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow> \<T> (assert_bound a s) = \<T> s"
   assumes assert_bound_nolhs_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     \<not> \<U> (assert_bound a s) \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound a s) \<and> \<diamond> (assert_bound a s)"
   assumes assert_bound_nolhs_atoms_equiv_bounds: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert_bound a s)"
   assumes assert_bound_nolhs_atoms_imply_bounds_index: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     ats \<Turnstile>\<^sub>i \<B>\<I> s \<Longrightarrow> insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound a s)"
   assumes assert_bound_nolhs_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     index_valid as s \<Longrightarrow> \<U> (assert_bound a s) \<Longrightarrow> minimal_unsat_state_core (assert_bound a s)"
   assumes assert_bound_nolhs_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
    \<nabla> (assert_bound a s)"
   assumes assert_bound_nolhs_index_valid: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     index_valid as s \<Longrightarrow> index_valid (insert a as) (assert_bound a s)"
 
 sublocale AssertBoundNoLhs < AssertBound 
   by unfold_locales
     ((metis satisfies_satisfies_no_lhs satisfies_consistent
         assert_bound_nolhs_tableau_id assert_bound_nolhs_sat assert_bound_nolhs_atoms_equiv_bounds
         assert_bound_nolhs_index_valid assert_bound_nolhs_atoms_imply_bounds_index
         assert_bound_nolhs_unsat assert_bound_nolhs_tableau_valuated)+) 
 
 
 text\<open>The second phase of \<open>assert\<close>, the \<open>check\<close> function,
 is the heart of the Simplex algorithm. It is always called after
 \<open>assert_bound\<close>, but in two different situations. In the first
 case \<open>assert_bound\<close> raised the \<open>\<U>\<close> flag and then
 \<open>check\<close> should retain the flag and should not perform any changes.
 In the second case \<open>assert_bound\<close> did not raise the
 \<open>\<U>\<close> flag, so \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>, \<open>\<diamond> s\<close>, \<open>\<triangle> (\<T>
 s)\<close>, and \<open>\<nabla> s\<close> hold.\<close>
 
 locale Check = fixes check::"('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>If @{text check} is called from an inconsistent state, the state is unchanged.\<close>
 
 check_unsat_id: "\<U> s \<Longrightarrow> check s = s"  and
 
 \<comment> \<open>The tableau remains equivalent to the previous one, normalized and valuated.\<close>
 
 check_tableau:  "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
    let s' = check s in ((v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') \<and> \<nabla> s'" and
 
 \<comment> \<open>The bounds remain unchanged.\<close>
 
 check_bounds_id:  "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<B>\<^sub>i (check s) = \<B>\<^sub>i s"  and
 
 \<comment> \<open>If @{term \<U>} flag is not raised, the current valuation
    @{text "\<V>"} satisfies both the tableau and the bounds and if it is
    raised, there is no valuation that satisfies them.\<close>
 
 check_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<not> \<U> (check s) \<Longrightarrow> \<Turnstile> (check s)"  and
 
 
 check_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<U> (check s) \<Longrightarrow> minimal_unsat_state_core (check s)"
 
 begin
 
 lemma check_tableau_equiv: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
                       (v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (check s)"
   using check_tableau
   by (simp add: Let_def)
 
 lemma check_tableau_index_valid: assumes "\<not> \<U> s" " \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" "\<triangle> (\<T> s)" "\<nabla> s"
   shows "index_valid as (check s) = index_valid as s"
   unfolding index_valid_def using check_bounds_id[OF assms]
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 
 lemma check_tableau_normalized: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<triangle> (\<T> (check s))"
   using check_tableau
   by (simp add: Let_def)
 
 lemma check_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (check s)"
   using check_tableau
   by (simp add: Let_def)
 
 lemma check_indices_state: assumes "\<not> \<U> s \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<not> \<U> s \<Longrightarrow> \<diamond> s" "\<not> \<U> s \<Longrightarrow> \<triangle> (\<T> s)" "\<not> \<U> s \<Longrightarrow> \<nabla> s"
   shows "indices_state (check s) = indices_state s" 
   using check_bounds_id[OF _ assms] check_unsat_id[of s]
   unfolding indices_state_def by (cases "\<U> s", auto)
 
 lemma check_distinct_indices_state: assumes "\<not> \<U> s \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<not> \<U> s \<Longrightarrow> \<diamond> s" "\<not> \<U> s \<Longrightarrow> \<triangle> (\<T> s)" "\<not> \<U> s \<Longrightarrow> \<nabla> s"
   shows "distinct_indices_state (check s) = distinct_indices_state s" 
   using check_bounds_id[OF _ assms] check_unsat_id[of s]
   unfolding distinct_indices_state_def by (cases "\<U> s", auto)
   
 end
 
 
 locale Assert' = AssertBound assert_bound + Check check for
   assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" and
   check :: "('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
 begin
 definition assert :: "('i,'a) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "assert a s \<equiv> check (assert_bound a s)"
 
 lemma Assert'Precond:
   assumes "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   shows
     "\<triangle> (\<T> (assert_bound a s))"
     "\<not> \<U> (assert_bound a s) \<Longrightarrow>  \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound a s) \<and> \<diamond> (assert_bound a s)"
     "\<nabla> (assert_bound a s)"
   using assms
   using assert_bound_tableau_id assert_bound_sat assert_bound_tableau_valuated
   by (auto simp add: satisfies_bounds_consistent Let_def)
 end
 
 
 sublocale Assert' < Assert assert
 proof
   fix s::"('i,'a) state" and v::"'a valuation" and  a::"('i,'a) i_atom"
   assume *: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   have "\<triangle> (\<T> (assert a s))"
     using check_tableau_normalized[of "assert_bound a s"] check_unsat_id[of "assert_bound a s"] *
     using assert_bound_sat[of s a] Assert'Precond[of s a]
     by (force simp add: assert_def)
   moreover
   have "v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> (assert a s)"
     using check_tableau_equiv[of "assert_bound a s" v] *
     using check_unsat_id[of "assert_bound a s"]
     by (force simp add: assert_def Assert'Precond assert_bound_sat assert_bound_tableau_id)
   moreover
   have "\<nabla> (assert a s)"
     using assert_bound_tableau_valuated[of s a] *
     using check_tableau_valuated[of "assert_bound a s"]
     using check_unsat_id[of "assert_bound a s"]
     by (cases "\<U> (assert_bound a s)") (auto simp add: Assert'Precond assert_def)
   ultimately
   show "let s' = assert a s in (v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') \<and> \<nabla> s'"
     by (simp add: Let_def)
 next
   fix s::"('i,'a) state" and a::"('i,'a) i_atom"
   assume "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   then show "\<not> \<U> (assert a s) \<Longrightarrow> \<Turnstile> (assert a s)"
     unfolding assert_def
     using check_unsat_id[of "assert_bound a s"]
     using check_sat[of "assert_bound a s"]
     by (force simp add: Assert'Precond)
 next
   fix s::"('i,'a) state" and a::"('i,'a) i_atom" and ats::"('i,'a) i_atom set"
   assume "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   then show "flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert a s)"
     using assert_bound_atoms_equiv_bounds
     using check_unsat_id[of "assert_bound a s"] check_bounds_id
     by (cases "\<U> (assert_bound a s)") (auto simp add: Assert'Precond assert_def
         simp: indexl_def indexu_def boundsl_def boundsu_def)
 next
   fix s::"('i,'a) state" and a::"('i,'a) i_atom" and ats
   assume *: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s" "\<U> (assert a s)" "index_valid ats s"
   show "minimal_unsat_state_core (assert a s)"
   proof (cases "\<U> (assert_bound a s)")
     case True
     then show ?thesis
       unfolding assert_def
       using * assert_bound_unsat check_tableau_equiv[of "assert_bound a s"] check_bounds_id
       using check_unsat_id[of "assert_bound a s"]
       by (auto simp add: Assert'Precond satisfies_state_def Let_def)
   next
     case False
     then show ?thesis
       unfolding assert_def
       using * assert_bound_sat[of s a] check_unsat Assert'Precond
       by (metis assert_def)
   qed
 next
   fix ats
   fix s::"('i,'a) state" and a::"('i,'a) i_atom"
   assume *: "index_valid ats s"
     and **: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   have *: "index_valid (insert a ats) (assert_bound a s)"
     using assert_bound_index_valid[OF ** *] .
   show "index_valid (insert a ats) (assert a s)"
   proof (cases "\<U> (assert_bound a s)")
     case True
     show ?thesis unfolding assert_def check_unsat_id[OF True] using * .
   next
     case False
     show ?thesis unfolding assert_def using Assert'Precond[OF **, of a] False *
       by (subst check_tableau_index_valid[OF False], auto)
   qed
 next
   fix s ats a
   let ?s = "assert_bound a s"
   assume *: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s" "ats \<Turnstile>\<^sub>i \<B>\<I> s"
   from assert_bound_atoms_imply_bounds_index[OF this, of a]
   have as: "insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound a s)" by auto
   show "insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert a s)"
   proof (cases "\<U> ?s")
     case True
     from check_unsat_id[OF True] as show ?thesis unfolding assert_def by auto
   next
     case False
     from assert_bound_tableau_id[OF *(1-4)] *
     have t: "\<triangle> (\<T> ?s)" by simp
     from assert_bound_tableau_valuated[OF *(1-4)]
     have v: "\<nabla> ?s" .
     from assert_bound_sat[OF *(1-4) refl False]
     have "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s" "\<diamond> ?s" by auto
     from check_bounds_id[OF False this t v]  as
     show ?thesis unfolding assert_def
       by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
   qed
 qed
 
 text\<open>Under these assumptions for \<open>assert_bound\<close> and \<open>check\<close>, it can be easily shown that the implementation of \<open>assert\<close> (previously given) satisfies its specification.\<close>
 
 locale AssertAllState'' = Init init + AssertBoundNoLhs assert_bound + Check check for
   init :: "tableau \<Rightarrow> ('i,'a::lrv) state" and
   assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" and
   check :: "('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
 begin
 definition assert_bound_loop where
   "assert_bound_loop ats s \<equiv> foldl (\<lambda> s' a. if (\<U> s') then s' else assert_bound a s') s ats"
 definition assert_all_state where [simp]:
   "assert_all_state t ats \<equiv> check (assert_bound_loop ats (init t))"
 
 text\<open>However, for efficiency reasons, we want to allow
 implementations that delay the \<open>check\<close> function call and call it
 after several \<open>assert_bound\<close> calls. For example:
 
 \smallskip
 \begin{small}
 @{thm assert_bound_loop_def[no_vars]}
 
 @{thm assert_all_state_def[no_vars]}
 \end{small}
 \smallskip
 
 Then, the loop consists only of \<open>assert_bound\<close> calls, so \<open>assert_bound\<close> postcondition must imply its precondition. This is not
 the case, since variables on the lhs may be out of their
 bounds. Therefore, we make a refinement and specify weaker
 preconditions (replace \<open>\<Turnstile> s\<close>, by \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close> and \<open>\<diamond> s\<close>) for \<open>assert_bound\<close>, and show that these
 preconditions are still good enough to prove the correctnes of this
 alternative \<open>assert_all_state\<close> definition.\<close>
 
 
 lemma AssertAllState''_precond':
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "\<not> \<U> s \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s \<and> \<diamond> s"
   shows "let s' = assert_bound_loop ats s in
          \<triangle> (\<T> s') \<and> \<nabla> s' \<and> (\<not> \<U> s' \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<and> \<diamond> s')"
   using assms
   using assert_bound_nolhs_tableau_id assert_bound_nolhs_sat assert_bound_nolhs_tableau_valuated
   by (induct ats rule: rev_induct) (auto simp add: assert_bound_loop_def Let_def)
 
 lemma AssertAllState''_precond:
   assumes "\<triangle> t"
   shows "let s' = assert_bound_loop ats (init t) in
          \<triangle> (\<T> s') \<and> \<nabla> s' \<and> (\<not> \<U> s' \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<and> \<diamond> s')"
   using assms
   using AssertAllState''_precond'[of "init t" ats]
   by (simp add: Let_def init_tableau_id init_unsat_flag init_satisfies satisfies_consistent
       satisfies_satisfies_no_lhs init_tableau_valuated)
 
 lemma AssertAllState''Induct:
   assumes
     "\<triangle> t"
     "P {} (init t)"
     "\<And> as bs t. as \<subseteq> bs \<Longrightarrow> P as t \<Longrightarrow> P bs t"
     "\<And> s a ats. \<lbrakk>\<not> \<U> s;  \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s; P (set ats) s; index_valid (set ats) s\<rbrakk>
       \<Longrightarrow> P (insert a (set ats)) (assert_bound a s)"
   shows "P (set ats) (assert_bound_loop ats (init t))"
 proof -
   have "P (set ats) (assert_bound_loop ats (init t)) \<and> index_valid (set ats) (assert_bound_loop ats (init t))"
   proof (induct ats rule: rev_induct)
     case Nil
     then show ?case
       unfolding assert_bound_loop_def
       using assms(2) init_index_valid
       by simp
   next
     case (snoc a as')
     let ?s = "assert_bound_loop as' (init t)"
     from snoc index_valid_mono[of _ "set (a # as')" "assert_bound_loop as' (init t)"]
     have index: "index_valid (set (a # as')) (assert_bound_loop as' (init t))"
       by auto
     from snoc assms(3)[of "set as'" "set (a # as')"]
     have P: "P (set (a # as')) (assert_bound_loop as' (init t))" by auto
     show ?case
     proof (cases "\<U> ?s")
       case True
       then show ?thesis
         using P index
         unfolding assert_bound_loop_def
         by simp
     next
       case False
       have id': "set (as' @ [a]) = insert a (set as')" by simp
       have id: "assert_bound_loop (as' @ [a]) (init t) =
         assert_bound a (assert_bound_loop as' (init t))"
         using False unfolding assert_bound_loop_def by auto
       from snoc have index: "index_valid (set as') ?s" by simp
       show ?thesis unfolding id unfolding id' using False snoc AssertAllState''_precond[OF assms(1)]
         by (intro conjI assert_bound_nolhs_index_valid index assms(4); (force simp: Let_def curr_val_satisfies_no_lhs_def)?)
     qed
   qed
   then show ?thesis ..
 qed
 
 lemma AssertAllState''_tableau_id:
   "\<triangle> t \<Longrightarrow> \<T> (assert_bound_loop ats (init t)) = \<T> (init t)"
   by (rule AssertAllState''Induct) (auto simp add: init_tableau_id assert_bound_nolhs_tableau_id)
 
 lemma AssertAllState''_sat:
   "\<triangle> t \<Longrightarrow>
     \<not> \<U> (assert_bound_loop ats (init t)) \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound_loop ats (init t)) \<and> \<diamond> (assert_bound_loop ats (init t))"
   by (rule AssertAllState''Induct) (auto simp add: init_unsat_flag init_satisfies satisfies_consistent satisfies_satisfies_no_lhs assert_bound_nolhs_sat)
 
 lemma AssertAllState''_unsat:
   "\<triangle> t \<Longrightarrow> \<U> (assert_bound_loop ats (init t)) \<longrightarrow> minimal_unsat_state_core (assert_bound_loop ats (init t))"
   by (rule AssertAllState''Induct)
     (auto simp add: init_tableau_id assert_bound_nolhs_unsat init_unsat_flag)
 
 lemma AssertAllState''_sat_atoms_equiv_bounds:
   "\<triangle> t \<Longrightarrow> \<not> \<U> (assert_bound_loop ats (init t)) \<longrightarrow> flat (set ats) \<doteq> \<B> (assert_bound_loop ats (init t))"
   using AssertAllState''_precond
   using assert_bound_nolhs_atoms_equiv_bounds init_atoms_equiv_bounds
   by (induct ats rule: rev_induct) (auto simp add: Let_def assert_bound_loop_def)
 
 lemma AssertAllState''_atoms_imply_bounds_index:
   assumes "\<triangle> t"
   shows "set ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound_loop ats (init t))"
 proof (induct ats rule: rev_induct)
   case Nil
   then show ?case
     unfolding assert_bound_loop_def
     using init_atoms_imply_bounds_index assms
     by simp
 next
   case (snoc a ats')
   let ?s = "assert_bound_loop ats' (init t)"
   show ?case
   proof (cases "\<U> ?s")
     case True
     then show ?thesis
       using snoc atoms_imply_bounds_index_mono[of "set ats'" "set (ats' @ [a])"]
       unfolding assert_bound_loop_def
       by auto
   next
     case False
     then have id: "assert_bound_loop (ats' @ [a]) (init t) = assert_bound a ?s"
       unfolding assert_bound_loop_def by auto
     from snoc have ats: "set ats' \<Turnstile>\<^sub>i \<B>\<I> ?s" by auto
     from AssertAllState''_precond[of t ats', OF assms, unfolded Let_def] False
     have *: "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s" "\<triangle> (\<T> ?s)" "\<nabla> ?s" "\<diamond> ?s" by auto
     show ?thesis unfolding id using assert_bound_nolhs_atoms_imply_bounds_index[OF False * ats, of a] by auto
   qed
 qed 
 
 lemma AssertAllState''_index_valid:
   "\<triangle> t \<Longrightarrow> index_valid (set ats) (assert_bound_loop ats (init t))"
   by (rule AssertAllState''Induct, auto simp: init_index_valid index_valid_mono assert_bound_nolhs_index_valid)
 
 end
 
 sublocale AssertAllState'' < AssertAllState assert_all_state
 proof
   fix v::"'a valuation" and t ats s'
   assume *: "\<triangle> t" and "assert_all_state t ats = s'"
   then have s': "s' = assert_all_state t ats" by simp
   let ?s' = "assert_bound_loop ats (init t)"
   show "v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> s'"
     unfolding assert_all_state_def s'
     using * check_tableau_equiv[of ?s' v] AssertAllState''_tableau_id[of t ats] init_tableau_id[of t]
     using AssertAllState''_sat[of t ats] check_unsat_id[of ?s']
     using AssertAllState''_precond[of t ats]
     by force
 
   show "\<not> \<U> s' \<Longrightarrow> \<Turnstile> s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats]
     using check_sat check_unsat_id
     by (force simp add: Let_def)
 
   show "\<U> s' \<Longrightarrow> minimal_unsat_state_core s'"
     using * check_unsat check_unsat_id[of ?s'] check_bounds_id
     using AssertAllState''_unsat[of t ats] AssertAllState''_precond[of t ats] s'
     by (force simp add: Let_def satisfies_state_def)
 
   show "\<not> \<U> s' \<Longrightarrow> flat (set ats) \<doteq> \<B> s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats]
     using check_bounds_id[of ?s'] check_unsat_id[of ?s']
     using AssertAllState''_sat_atoms_equiv_bounds[of t ats]
     by (force simp add: Let_def simp: indexl_def indexu_def boundsl_def boundsu_def)
 
   show "\<U> s' \<Longrightarrow> set ats \<Turnstile>\<^sub>i \<B>\<I> s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats]
     unfolding Let_def
     using check_bounds_id[of ?s']
     using AssertAllState''_atoms_imply_bounds_index[of t ats]
     using check_unsat_id[of ?s']
     by (cases "\<U> ?s'") (auto simp add: Let_def simp: indexl_def indexu_def boundsl_def boundsu_def)
 
   show "index_valid (set ats) s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats] AssertAllState''_index_valid[OF *, of ats]
     unfolding Let_def
     using check_tableau_index_valid[of ?s']
     using check_unsat_id[of ?s']
     by (cases "\<U> ?s'", auto)
 
   show "indices_state s' \<subseteq> fst ` set ats"
     by (intro index_valid_indices_state, fact)
 qed
 
 
 subsection\<open>Update and Pivot\<close>
 
 text\<open>Both \<open>assert_bound\<close> and \<open>check\<close> need to update
 the valuation so that the tableau remains satisfied. If the value for
 a variable not on the lhs of the tableau is changed, this
 can be done rather easily (once the value of that variable is changed,
 one should recalculate and change the values for all lhs
 variables of the tableau). The \<open>update\<close> function does this, and
 it is specified by:\<close>
 
 locale Update = fixes update::"var \<Rightarrow> 'a::lrv \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>Tableau, bounds, and the unsatisfiability flag are preserved.\<close>
 
 update_id:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow>
      let s' = update x c s in \<T> s' = \<T> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s" and
 
 \<comment> \<open>Tableau remains valuated.\<close>
 
 update_tableau_valuated:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<nabla> (update x v s)"  and
 
 \<comment> \<open>The given variable @{text "x"} in the updated valuation is
    set to the given value @{text "v"} while all other variables
    (except those on the lhs of the tableau) are
    unchanged.\<close>
 
 update_valuation_nonlhs:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> x' \<notin> lvars (\<T> s) \<longrightarrow>
        look (\<V> (update x v s)) x' = (if x = x' then Some v else look (\<V> s) x')" and
 
 \<comment> \<open>Updated valuation continues to satisfy the tableau.\<close>
 
 update_satisfies_tableau:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow>  \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<longrightarrow> \<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>t \<T> s"
 
 begin
 lemma update_bounds_id:
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   shows "\<B>\<^sub>i (update x c s) = \<B>\<^sub>i s"
     "\<B>\<I> (update x c s) = \<B>\<I> s"
     "\<B>\<^sub>l (update x c s) = \<B>\<^sub>l s"
     "\<B>\<^sub>u (update x c s) = \<B>\<^sub>u s"
   using update_id assms
   by (auto simp add: Let_def simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma update_indices_state_id:
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   shows "indices_state (update x c s) = indices_state s" 
   using update_bounds_id[OF assms] unfolding indices_state_def by auto
 
 lemma update_tableau_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<T> (update x c s) = \<T> s"
   using update_id
   by (auto simp add: Let_def)
 
 lemma update_unsat_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<U> (update x c s) = \<U> s"
   using update_id
   by (auto simp add: Let_def)
 
 lemma update_unsat_core_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<U>\<^sub>c (update x c s) = \<U>\<^sub>c s"
   using update_id
   by (auto simp add: Let_def)
 
 definition assert_bound' where
   [simp]: "assert_bound' dir i x c s \<equiv>
        (if (\<unrhd>\<^sub>u\<^sub>b (lt dir)) c (UB dir s x) then s
           else let s' = update\<B>\<I> (UBI_upd dir) i x c s in
              if (\<lhd>\<^sub>l\<^sub>b (lt dir)) c ((LB dir) s x) then
                   set_unsat [i, ((LI dir) s x)] s'
              else if x \<notin> lvars (\<T> s') \<and> (lt dir) c (\<langle>\<V> s\<rangle> x) then
                   update x c s'
              else
                   s')"
 
 fun assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "assert_bound (i,Leq x c) s = assert_bound' Positive i x c s"
 | "assert_bound (i,Geq x c) s = assert_bound' Negative i x c s"
 
 lemma assert_bound'_cases:
   assumes "\<lbrakk>\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<rbrakk> \<Longrightarrow> P s"
   assumes "\<lbrakk>\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<rbrakk> \<Longrightarrow>
      P (set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<lbrakk>x \<notin> lvars (\<T> s); (lt dir) c (\<langle>\<V> s\<rangle> x); \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x))\<rbrakk> \<Longrightarrow>
      P (update x c (update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<lbrakk>\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)); x \<in> lvars (\<T> s)\<rbrakk> \<Longrightarrow>
      P (update\<B>\<I> (UBI_upd dir) i x c s)"
   assumes "\<lbrakk>\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)); \<not> ((lt dir) c (\<langle>\<V> s\<rangle> x))\<rbrakk> \<Longrightarrow>
      P (update\<B>\<I> (UBI_upd dir) i x c s)"
   assumes "dir = Positive \<or> dir = Negative"
   shows "P (assert_bound' dir i x c s)"
 proof (cases "\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)")
   case True
   then show ?thesis
     using assms(1)
     by simp
 next
   case False
   show ?thesis
   proof (cases "\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)")
     case True
     then show ?thesis
       using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close>
       using assms(2)
       by simp
   next
     case False
     let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
     show ?thesis
     proof (cases "x \<notin> lvars (\<T> ?s) \<and> (lt dir) c (\<langle>\<V> s\<rangle> x)")
       case True
       then show ?thesis
         using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close> \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<close>
         using assms(3) assms(6)
         by auto
     next
       case False
       then have "x \<in> lvars (\<T> ?s) \<or> \<not> ((lt dir) c (\<langle>\<V> s\<rangle> x))"
         by simp
       then show ?thesis
       proof
         assume "x \<in> lvars (\<T> ?s)"
         then show ?thesis
           using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close> \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<close>
           using assms(4) assms(6)
           by auto
       next
         assume "\<not> (lt dir) c (\<langle>\<V> s\<rangle> x)"
         then show ?thesis
           using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close> \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<close>
           using assms(5) assms(6)
           by simp
       qed
     qed
   qed
 qed
 
 lemma assert_bound_cases:
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)
      \<rbrakk> \<Longrightarrow>
        P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir) s"
   assumes "\<And> c x dir.
      \<lbrakk>dir = Positive \<or> dir = Negative;
       a = LE dir x c;
       \<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x); \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
           (set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        x \<notin> lvars (\<T> s); (lt dir) c (\<langle>\<V> s\<rangle> x);
       \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x))
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
        (update x c ((update\<B>\<I> (UBI_upd dir) i x c s)))"
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        x \<in> lvars (\<T> s); \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x));
        \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x))
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
           ((update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x));
        \<not> ((lt dir) c (\<langle>\<V> s\<rangle> x))
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
            ((update\<B>\<I> (UBI_upd dir) i x c s))"
 
 assumes "\<And> s. P s = P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s"
 assumes "\<And> s. P s = P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s"
 shows "P (assert_bound (i,a) s)"
 proof (cases a)
   case (Leq x c)
   then show ?thesis
     apply (simp del: assert_bound'_def)
     apply (rule assert_bound'_cases, simp_all)
     using assms(1)[of Positive x c]
     using assms(2)[of Positive x c]
     using assms(3)[of Positive x c]
     using assms(4)[of Positive x c]
     using assms(5)[of Positive x c]
     using assms(7)
     by auto
 next
   case (Geq x c)
   then show ?thesis
     apply (simp del: assert_bound'_def)
     apply (rule assert_bound'_cases)
     using assms(1)[of Negative x c]
     using assms(2)[of Negative x c]
     using assms(3)[of Negative x c]
     using assms(4)[of Negative x c]
     using assms(5)[of Negative x c]
     using assms(6)
     by auto
 qed
 end
 
 lemma set_unsat_bounds_id: "\<B> (set_unsat I s) = \<B> s"
   unfolding boundsl_def boundsu_def by auto
 
 
 lemma decrease_ub_satisfied_inverse:
   assumes lt: "\<lhd>\<^sub>u\<^sub>b (lt dir) c  (UB dir s x)" and dir: "dir = Positive \<or> dir = Negative"
   assumes v: "v \<Turnstile>\<^sub>b \<B> (update\<B>\<I> (UBI_upd dir) i x c s)"
   shows "v \<Turnstile>\<^sub>b \<B> s"
   unfolding satisfies_bounds.simps
 proof
   fix x'
   show "in_bounds x' v (\<B> s)"
   proof (cases "x = x'")
     case False
     then show ?thesis
       using v dir
       unfolding satisfies_bounds.simps
       by (auto split: if_splits simp: boundsl_def boundsu_def)
   next
     case True
     then show ?thesis
       using v dir
       unfolding satisfies_bounds.simps
       using lt
       by (erule_tac x="x'" in allE)
         (auto simp add: lt_ubound_def[THEN sym] gt_lbound_def[THEN sym] compare_strict_nonstrict
           boundsl_def boundsu_def)
   qed
 qed
 
 lemma atoms_equiv_bounds_extend:
   fixes x c dir
   assumes "dir = Positive \<or> dir = Negative"  "\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)"  "ats \<doteq> \<B> s"
   shows "(ats \<union> {LE dir x c}) \<doteq> \<B> (update\<B>\<I> (UBI_upd dir) i x c s)"
   unfolding atoms_equiv_bounds.simps
 proof
   fix v
   let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
   show "v \<Turnstile>\<^sub>a\<^sub>s (ats \<union> {LE dir x c}) = v \<Turnstile>\<^sub>b \<B> ?s"
   proof
     assume "v \<Turnstile>\<^sub>a\<^sub>s (ats \<union> {LE dir x c})"
     then have "v \<Turnstile>\<^sub>a\<^sub>s ats" "le (lt dir) (v x) c"
       using \<open>dir = Positive \<or> dir = Negative\<close>
       unfolding satisfies_atom_set_def
       by auto
     show "v \<Turnstile>\<^sub>b \<B> ?s"
       unfolding satisfies_bounds.simps
     proof
       fix x'
       show "in_bounds x' v (\<B> ?s)"
         using \<open>v \<Turnstile>\<^sub>a\<^sub>s ats\<close> \<open>le (lt dir) (v x) c\<close> \<open>ats \<doteq> \<B> s\<close>
         using \<open>dir = Positive \<or> dir = Negative\<close>
         unfolding atoms_equiv_bounds.simps satisfies_bounds.simps
         by (cases "x = x'") (auto simp: boundsl_def boundsu_def)
     qed
   next
     assume "v \<Turnstile>\<^sub>b \<B> ?s"
     then have "v \<Turnstile>\<^sub>b \<B> s"
       using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)\<close>
       using \<open>dir = Positive \<or> dir = Negative\<close>
       using decrease_ub_satisfied_inverse[of dir c s x v]
       using neg_bounds_compare(1)[of c "\<B>\<^sub>u s x"]
       using neg_bounds_compare(5)[of c "\<B>\<^sub>l s x"]
       by (auto simp add:  lt_ubound_def[THEN sym] ge_ubound_def[THEN sym] le_lbound_def[THEN sym] gt_lbound_def[THEN sym])
     show "v \<Turnstile>\<^sub>a\<^sub>s (ats \<union> {LE dir x c})"
       unfolding satisfies_atom_set_def
     proof
       fix a
       assume "a \<in> ats \<union> {LE dir x c}"
       then show "v \<Turnstile>\<^sub>a a"
       proof
         assume "a \<in> {LE dir x c}"
         then show ?thesis
           using \<open>v \<Turnstile>\<^sub>b \<B> ?s\<close>
           using \<open>dir = Positive \<or> dir = Negative\<close>
           unfolding satisfies_bounds.simps
           by (auto split: if_splits simp: boundsl_def boundsu_def)
       next
         assume "a \<in> ats"
         then show ?thesis
           using \<open>ats \<doteq> \<B> s\<close>
           using \<open>v \<Turnstile>\<^sub>b \<B> s\<close>
           unfolding atoms_equiv_bounds.simps satisfies_atom_set_def
           by auto
       qed
     qed
   qed
 qed
 
 lemma bounds_updates: "\<B>\<^sub>l (\<B>\<^sub>i\<^sub>u_update u s) = \<B>\<^sub>l s"
   "\<B>\<^sub>u (\<B>\<^sub>i\<^sub>l_update u s) = \<B>\<^sub>u s"
   "\<B>\<^sub>u (\<B>\<^sub>i\<^sub>u_update (upd x (i,c)) s) = (\<B>\<^sub>u s) (x \<mapsto> c)"
   "\<B>\<^sub>l (\<B>\<^sub>i\<^sub>l_update (upd x (i,c)) s) = (\<B>\<^sub>l s) (x \<mapsto> c)"
   by (auto simp: boundsl_def boundsu_def)
 
 locale EqForLVar =
   fixes eq_idx_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> nat"
   assumes eq_idx_for_lvar:
     "\<lbrakk>x \<in> lvars t\<rbrakk> \<Longrightarrow> eq_idx_for_lvar t x < length t \<and> lhs (t ! eq_idx_for_lvar t x) = x"
 begin
 definition eq_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> eq" where
   "eq_for_lvar t v \<equiv> t ! (eq_idx_for_lvar t v)"
 lemma eq_for_lvar:
   "\<lbrakk>x \<in> lvars t\<rbrakk> \<Longrightarrow> eq_for_lvar t x \<in> set t \<and> lhs (eq_for_lvar t x) = x"
   unfolding eq_for_lvar_def
   using eq_idx_for_lvar
   by auto
 
 abbreviation rvars_of_lvar where
   "rvars_of_lvar t x \<equiv> rvars_eq (eq_for_lvar t x)"
 
 lemma rvars_of_lvar_rvars:
   assumes "x \<in> lvars t"
   shows "rvars_of_lvar t x \<subseteq> rvars t"
   using assms eq_for_lvar[of x t]
   unfolding rvars_def
   by auto
 
 end
 
 text \<open>Updating changes the value of \<open>x\<close> and then updates
 values of all lhs variables so that the tableau remains
 satisfied. This can be based on a function that recalculates rhs
 polynomial values in the changed valuation:\<close>
 
 locale RhsEqVal = fixes rhs_eq_val::"(var, 'a::lrv) mapping \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> eq \<Rightarrow> 'a"
   \<comment> \<open>@{text rhs_eq_val} computes the value of the rhs of @{text e} in @{text "\<langle>v\<rangle>(x := c)"}.\<close>
   assumes rhs_eq_val:  "\<langle>v\<rangle> \<Turnstile>\<^sub>e e \<Longrightarrow> rhs_eq_val v x c e = rhs e \<lbrace> \<langle>v\<rangle> (x := c) \<rbrace>"
 
 begin
 
 text\<open>\noindent Then, the next implementation of \<open>update\<close>
 satisfies its specification:\<close>
 
 abbreviation update_eq where
   "update_eq v x c v' e \<equiv> upd (lhs e) (rhs_eq_val v x c e) v'"
 
 definition update :: "var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "update x c s \<equiv> \<V>_update (upd x c (foldl (update_eq (\<V> s) x c) (\<V> s) (\<T> s))) s"
 
 lemma update_no_set_none:
   shows "look (\<V> s) y \<noteq> None \<Longrightarrow>
          look (foldl (update_eq (\<V> s) x v) (\<V> s) t) y \<noteq> None"
   by (induct t rule: rev_induct, auto simp: lookup_update')
 
 lemma update_no_left:
   assumes  "y \<notin> lvars t"
   shows "look (\<V> s) y = look (foldl (update_eq (\<V> s) x v) (\<V> s) t) y"
   using assms
   by (induct t rule: rev_induct) (auto simp add: lvars_def lookup_update')
 
 lemma update_left:
   assumes "y \<in> lvars t"
   shows "\<exists> eq \<in> set t. lhs eq = y \<and>
      look (foldl (update_eq (\<V> s) x v) (\<V> s) t) y = Some (rhs_eq_val (\<V> s) x v eq)"
   using assms
   by (induct t rule: rev_induct) (auto simp add: lvars_def lookup_update')
 
 lemma update_valuate_rhs:
   assumes "e \<in> set (\<T> s)" "\<triangle> (\<T> s)"
   shows "rhs e \<lbrace> \<langle>\<V> (update x c s)\<rangle> \<rbrace> = rhs e \<lbrace> \<langle>\<V> s\<rangle> (x := c) \<rbrace>"
 proof (rule valuate_depend, safe)
   fix y
   assume "y \<in> rvars_eq e"
   then have "y \<notin> lvars (\<T> s)"
     using \<open>\<triangle> (\<T> s)\<close> \<open>e \<in> set (\<T> s)\<close>
     by (auto simp add: normalized_tableau_def rvars_def)
   then show "\<langle>\<V> (update x c s)\<rangle> y = (\<langle>\<V> s\<rangle>(x := c)) y"
     using update_no_left[of y "\<T> s" s x c]
     by (auto simp add: update_def map2fun_def lookup_update')
 qed
 
 end
 
 
 sublocale RhsEqVal < Update update
 proof
   fix s::"('i,'a) state" and x c
   show "let s' = update x c s in \<T> s' = \<T> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s"
     by (simp add: Let_def update_def add: boundsl_def boundsu_def indexl_def indexu_def)
 next
   fix s::"('i,'a) state" and x c
   assume "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   then show "\<nabla> (update x c s)"
     using update_no_set_none[of s]
     by (simp add: Let_def update_def tableau_valuated_def lookup_update')
 next
   fix s::"('i,'a) state" and  x x' c
   assume "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   show "x' \<notin> lvars (\<T> s) \<longrightarrow>
           look (\<V> (update x c s)) x' =
           (if x = x' then Some c else look (\<V> s) x')"
     using update_no_left[of x' "\<T> s" s x c]
     unfolding update_def lvars_def Let_def
     by (auto simp: lookup_update')
 next
   fix s::"('i,'a) state" and x c
   assume "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   have "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<Longrightarrow> \<forall>e \<in> set (\<T> s). \<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>e e"
   proof
     fix e
     assume "e \<in> set (\<T> s)" "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s"
     then have "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>e e"
       by (simp add: satisfies_tableau_def)
 
     have "x \<noteq> lhs e"
       using \<open>x \<notin> lvars (\<T> s)\<close> \<open>e \<in> set (\<T> s)\<close>
       by (auto simp add: lvars_def)
     then have "\<langle>\<V> (update x c s)\<rangle> (lhs e) = rhs_eq_val (\<V> s) x c e"
       using update_left[of "lhs e" "\<T> s" s x c] \<open>e \<in> set (\<T> s)\<close> \<open>\<triangle> (\<T> s)\<close>
       by (auto simp add: lvars_def lookup_update' update_def Let_def map2fun_def normalized_tableau_def distinct_map inj_on_def)
     then show "\<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>e e"
       using \<open>\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>e e\<close> \<open>e \<in> set (\<T> s)\<close> \<open>x \<notin> lvars (\<T> s)\<close> \<open>\<triangle> (\<T> s)\<close>
       using rhs_eq_val
       by (simp add: satisfies_eq_def update_valuate_rhs)
   qed
   then show "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<longrightarrow> \<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>t \<T> s"
     by(simp add: satisfies_tableau_def update_def)
 qed
 
 
 text\<open>To update the valuation for a variable that is on the lhs of
 the tableau it should first be swapped with some rhs variable of its
 equation, in an operation called \emph{pivoting}. Pivoting has the
 precondition that the tableau is normalized and that it is always
 called for a lhs variable of the tableau, and a rhs variable in the
 equation with that lhs variable. The set of rhs variables for the
 given lhs variable is found using the \<open>rvars_of_lvar\<close> function
 (specified in a very simple locale \<open>EqForLVar\<close>, that we do not
 print).\<close>
 
 locale Pivot = EqForLVar + fixes pivot::"var \<Rightarrow> var \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>Valuation, bounds, and the unsatisfiability flag are not changed.\<close>
 
 pivot_id:  "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       let s' = pivot x\<^sub>i x\<^sub>j s in \<V> s' = \<V> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s" and
 
 \<comment> \<open>The tableau remains equivalent to the previous one and normalized.\<close>
 
 pivot_tableau:  "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       let s' = pivot x\<^sub>i x\<^sub>j s in  ((v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') " and
 
 \<comment> \<open>@{text "x\<^sub>i"} and @{text "x\<^sub>j"} are swapped, while the other variables do not change sides.\<close>
 
 pivot_vars':   "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> let s' = pivot x\<^sub>i x\<^sub>j s in
    rvars(\<T> s') = rvars(\<T> s)-{x\<^sub>j}\<union>{x\<^sub>i}  \<and>  lvars(\<T> s') = lvars(\<T> s)-{x\<^sub>i}\<union>{x\<^sub>j}"
 
 begin
 lemma pivot_bounds_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<B>\<^sub>i (pivot x\<^sub>i x\<^sub>j s) = \<B>\<^sub>i s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_bounds_id': assumes "\<triangle> (\<T> s)" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<B>\<I> (pivot x\<^sub>i x\<^sub>j s) = \<B>\<I> s" "\<B> (pivot x\<^sub>i x\<^sub>j s) = \<B> s" "\<I> (pivot x\<^sub>i x\<^sub>j s) = \<I> s"
   using pivot_bounds_id[OF assms]
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma pivot_valuation_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<V> (pivot x\<^sub>i x\<^sub>j s) = \<V> s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_unsat_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<U> (pivot x\<^sub>i x\<^sub>j s) = \<U> s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_unsat_core_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<U>\<^sub>c (pivot x\<^sub>i x\<^sub>j s) = \<U>\<^sub>c s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_tableau_equiv: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       (v::'a valuation) \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> (pivot x\<^sub>i x\<^sub>j s)"
   using pivot_tableau
   by (simp add: Let_def)
 
 lemma pivot_tableau_normalized: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<triangle> (\<T> (pivot x\<^sub>i x\<^sub>j s))"
   using pivot_tableau
   by (simp add: Let_def)
 
 lemma pivot_rvars: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> rvars (\<T> (pivot x\<^sub>i x\<^sub>j s)) = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
   using pivot_vars'
   by (simp add: Let_def)
 
 lemma pivot_lvars: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> lvars (\<T> (pivot x\<^sub>i x\<^sub>j s)) = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
   using pivot_vars'
   by (simp add: Let_def)
 
 lemma pivot_vars:
   "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> tvars (\<T> (pivot x\<^sub>i x\<^sub>j s)) = tvars (\<T> s) "
   using pivot_lvars[of s x\<^sub>i x\<^sub>j] pivot_rvars[of s x\<^sub>i x\<^sub>j]
   using rvars_of_lvar_rvars[of x\<^sub>i "\<T> s"]
   by auto
 
 lemma
   pivot_tableau_valuated: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i; \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (pivot x\<^sub>i x\<^sub>j s)"
   using pivot_valuation_id pivot_vars
   by (auto simp add: tableau_valuated_def)
 
 end
 
 
 text\<open>Functions \<open>pivot\<close> and \<open>update\<close> can be used to
 implement the \<open>check\<close> function. In its context, \<open>pivot\<close>
 and \<open>update\<close> functions are always called together, so the
 following definition can be used: @{prop "pivot_and_update x\<^sub>i x\<^sub>j c s =
 update x\<^sub>i c (pivot x\<^sub>i x\<^sub>j s)"}. It is possible to make a more efficient
 implementation of \<open>pivot_and_update\<close> that does not use separate
 implementations of \<open>pivot\<close> and \<open>update\<close>. To allow this, a
 separate specification for \<open>pivot_and_update\<close> can be given. It can be
 easily shown that the \<open>pivot_and_update\<close> definition above
 satisfies this specification.\<close>
 
 
 locale PivotAndUpdate = EqForLVar +
   fixes pivot_and_update :: "var \<Rightarrow> var \<Rightarrow> 'a::lrv \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes  pivotandupdate_unsat_id:   "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<U> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<U> s"
   assumes pivotandupdate_unsat_core_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<U>\<^sub>c (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<U>\<^sub>c s"
   assumes  pivotandupdate_bounds_id:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<B>\<^sub>i (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<B>\<^sub>i s"
   assumes  pivotandupdate_tableau_normalized:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<triangle> (\<T> (pivot_and_update x\<^sub>i x\<^sub>j c s))"
   assumes  pivotandupdate_tableau_equiv:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       (v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (pivot_and_update x\<^sub>i x\<^sub>j c s)"
   assumes pivotandupdate_satisfies_tableau:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<longrightarrow> \<langle>\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)\<rangle> \<Turnstile>\<^sub>t \<T> s"
   assumes  pivotandupdate_rvars:   "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       rvars (\<T> (pivot_and_update x\<^sub>i x\<^sub>j c s)) = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
   assumes  pivotandupdate_lvars:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       lvars (\<T> (pivot_and_update x\<^sub>i x\<^sub>j c s)) = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
   assumes pivotandupdate_valuation_nonlhs:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       x \<notin> lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j} \<longrightarrow> look (\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)) x = (if x = x\<^sub>i then Some c else look (\<V> s) x)"
   assumes pivotandupdate_tableau_valuated:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
  \<nabla> (pivot_and_update x\<^sub>i x\<^sub>j c s)"
 begin
 
 lemma pivotandupdate_bounds_id':  assumes "\<triangle> (\<T> s)" "\<nabla> s" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<B>\<I> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<B>\<I> s"
     "\<B> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<B> s"
     "\<I> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<I> s"
   using pivotandupdate_bounds_id[OF assms]
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma  pivotandupdate_valuation_xi: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> look (\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)) x\<^sub>i = Some c"
   using pivotandupdate_valuation_nonlhs[of s x\<^sub>i x\<^sub>j x\<^sub>i c]
   using rvars_of_lvar_rvars
   by (auto simp add:  normalized_tableau_def)
 
 lemma  pivotandupdate_valuation_other_nolhs: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i; x \<notin> lvars (\<T> s); x \<noteq> x\<^sub>j\<rbrakk> \<Longrightarrow> look (\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)) x = look (\<V> s) x"
   using pivotandupdate_valuation_nonlhs[of s x\<^sub>i x\<^sub>j x c]
   by auto
 
 lemma pivotandupdate_nolhs:
   "\<lbrakk> \<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i;
      \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<B>\<^sub>l s x\<^sub>i = Some c \<or> \<B>\<^sub>u s x\<^sub>i = Some c\<rbrakk> \<Longrightarrow>
      \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (pivot_and_update x\<^sub>i x\<^sub>j c s)"
   using pivotandupdate_satisfies_tableau[of s x\<^sub>i x\<^sub>j c]
   using pivotandupdate_tableau_equiv[of s x\<^sub>i x\<^sub>j _ c]
   using pivotandupdate_valuation_xi[of s x\<^sub>i x\<^sub>j c]
   using pivotandupdate_valuation_other_nolhs[of s x\<^sub>i x\<^sub>j _ c]
   using pivotandupdate_lvars[of s x\<^sub>i x\<^sub>j c]
   by (auto simp add: curr_val_satisfies_no_lhs_def satisfies_bounds.simps satisfies_bounds_set.simps
       bounds_consistent_geq_lb bounds_consistent_leq_ub map2fun_def pivotandupdate_bounds_id')
 
 lemma pivotandupdate_bounds_consistent:
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<diamond> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<diamond> s"
   using assms pivotandupdate_bounds_id'[of s x\<^sub>i x\<^sub>j c]
   by (simp add: bounds_consistent_def)
 end
 
 
 locale PivotUpdate = Pivot eq_idx_for_lvar pivot + Update update for
   eq_idx_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> nat" and
   pivot :: "var \<Rightarrow> var \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> ('i,'a) state" and
   update :: "var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
 begin
 definition  pivot_and_update :: "var \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where [simp]:
   "pivot_and_update x\<^sub>i x\<^sub>j c s \<equiv> update x\<^sub>i c (pivot x\<^sub>i x\<^sub>j s)"
 
 lemma pivot_update_precond:
   assumes "\<triangle> (\<T> s)" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<triangle> (\<T> (pivot x\<^sub>i x\<^sub>j s))" "x\<^sub>i \<notin> lvars (\<T> (pivot x\<^sub>i x\<^sub>j s))"
 proof-
   from assms have "x\<^sub>i \<noteq> x\<^sub>j"
     using rvars_of_lvar_rvars[of x\<^sub>i "\<T> s"]
     by (auto simp add: normalized_tableau_def)
   then show "\<triangle> (\<T> (pivot x\<^sub>i x\<^sub>j s))" "x\<^sub>i \<notin> lvars (\<T> (pivot x\<^sub>i x\<^sub>j s))"
     using assms
     using pivot_tableau_normalized[of s x\<^sub>i x\<^sub>j]
     using pivot_lvars[of s x\<^sub>i x\<^sub>j]
     by auto
 qed
 
 end
 
 
 sublocale PivotUpdate < PivotAndUpdate eq_idx_for_lvar pivot_and_update
   using pivot_update_precond
   using update_unsat_id pivot_unsat_id pivot_unsat_core_id update_bounds_id pivot_bounds_id
     update_tableau_id pivot_tableau_normalized pivot_tableau_equiv update_satisfies_tableau
     pivot_valuation_id pivot_lvars pivot_rvars  update_valuation_nonlhs update_valuation_nonlhs
     pivot_tableau_valuated update_tableau_valuated update_unsat_core_id
   by (unfold_locales, auto)
 
 text\<open>Given the @{term update} function, \<open>assert_bound\<close> can be
 implemented as follows.
 \vspace{-2mm}
 @{text[display]
   "assert_bound (Leq x c) s \<equiv>
           if c \<ge>\<^sub>u\<^sub>b \<B>\<^sub>u s x then s
           else let s' = s \<lparr> \<B>\<^sub>u := (\<B>\<^sub>u s) (x := Some c) \<rparr>
                in if c <\<^sub>l\<^sub>b \<B>\<^sub>l s x then s' \<lparr> \<U> := True \<rparr>
                else if x \<notin> lvars (\<T> s') \<and> c < \<langle>\<V> s\<rangle> x then update x c s' else s'"
 }
 \vspace{-2mm}
 \noindent The case of \<open>Geq x c\<close> atoms is analogous (a systematic way to
 avoid symmetries is discussed in Section \ref{sec:symmetries}). This
 implementation satisfies both its specifications.
 \<close>
 
 lemma indices_state_set_unsat: "indices_state (set_unsat I s) = indices_state s" 
   by (cases s, auto simp: indices_state_def)
 
 lemma \<B>\<I>_set_unsat: "\<B>\<I> (set_unsat I s) = \<B>\<I> s" 
   by (cases s, auto simp: boundsl_def boundsu_def indexl_def indexu_def)
 
 lemma satisfies_tableau_cong: assumes "\<And> x. x \<in> tvars t \<Longrightarrow> v x = w x"
   shows "(v \<Turnstile>\<^sub>t t) = (w \<Turnstile>\<^sub>t t)" 
   unfolding satisfies_tableau_def satisfies_eq_def
   by (intro ball_cong[OF refl] arg_cong2[of _ _ _ _ "(=)"] valuate_depend, 
       insert assms, auto simp: lvars_def rvars_def)
 
 lemma satisfying_state_valuation_to_atom_tabl: assumes J: "J \<subseteq> indices_state s" 
   and model: "(J, v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s" 
   and ivalid: "index_valid as s" 
   and dist: "distinct_indices_atoms as" 
 shows "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" "v \<Turnstile>\<^sub>t \<T> s" 
   unfolding i_satisfies_atom_set'.simps
 proof (intro ballI)
   from model[unfolded satisfies_state_index'.simps]
   have model: "v \<Turnstile>\<^sub>t \<T> s" "(J, v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e \<B>\<I> s" by auto
   show "v \<Turnstile>\<^sub>t \<T> s" by fact
   fix a 
   assume "a \<in> restrict_to J as" 
   then obtain i where iJ: "i \<in> J" and mem: "(i,a) \<in> as" by auto
   with J have "i \<in> indices_state s" by auto
   from this[unfolded indices_state_def] obtain x c where 
     look: "look (\<B>\<^sub>i\<^sub>l s) x = Some (i, c) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i, c)" by auto
   with ivalid[unfolded index_valid_def] 
   obtain b where "(i,b) \<in> as" "atom_var b = x" "atom_const b = c" by force
   with dist[unfolded distinct_indices_atoms_def, rule_format, OF this(1) mem]
   have a: "atom_var a = x" "atom_const a = c" by auto
   from model(2)[unfolded satisfies_bounds_index'.simps] look iJ have "v x = c" 
     by (auto simp: boundsu_def boundsl_def indexu_def indexl_def)
   thus "v \<Turnstile>\<^sub>a\<^sub>e a" unfolding satisfies_atom'_def a .
 qed
 
 text \<open>Note that in order to ensure minimality of the unsat cores, pivoting is required.\<close>
 
 sublocale AssertAllState < AssertAll assert_all
 proof
   fix t as v I
   assume D: "\<triangle> t"  
   from D show "assert_all t as = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s flat (set as)"
     unfolding Let_def assert_all_def
     using assert_all_state_tableau_equiv[OF D refl]
     using assert_all_state_sat[OF D refl]
     using assert_all_state_sat_atoms_equiv_bounds[OF D refl, of as]
     unfolding atoms_equiv_bounds.simps curr_val_satisfies_state_def satisfies_state_def satisfies_atom_set_def
     by (auto simp: Let_def split: if_splits)
   let ?s = "assert_all_state t as" 
   assume "assert_all t as = Unsat I"
   then have i: "I = the (\<U>\<^sub>c ?s)" and U: "\<U> ?s"
     unfolding assert_all_def Let_def by (auto split: if_splits)
   from assert_all_index_valid[OF D refl, of as] have ivalid: "index_valid (set as) ?s"  .
   note unsat = assert_all_state_unsat[OF D refl U, unfolded minimal_unsat_state_core_def unsat_state_core_def i[symmetric]]
   from unsat have "set I \<subseteq> indices_state ?s" by auto
   also have "\<dots> \<subseteq> fst ` set as" using assert_all_state_indices[OF D refl] .
   finally have indices: "set I \<subseteq> fst ` set as" .
   show "minimal_unsat_core_tabl_atoms (set I) t (set as)" 
     unfolding minimal_unsat_core_tabl_atoms_def
   proof (intro conjI impI allI indices, clarify)
     fix v
     assume model: "v \<Turnstile>\<^sub>t t" "(set I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as"
     from unsat have no_model: "\<not> ((set I, v) \<Turnstile>\<^sub>i\<^sub>s ?s)" by auto
     from assert_all_state_unsat_atoms_equiv_bounds[OF D refl U]
     have equiv: "set as \<Turnstile>\<^sub>i \<B>\<I> ?s" by auto
     from assert_all_state_tableau_equiv[OF D refl, of v] model
     have model_t: "v \<Turnstile>\<^sub>t \<T> ?s" by auto
     have model_as': "(set I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as"
       using model(2) by (auto simp: satisfies_atom_set_def)
     with equiv model_t have "(set I, v) \<Turnstile>\<^sub>i\<^sub>s ?s"
       unfolding satisfies_state_index.simps atoms_imply_bounds_index.simps by simp
     with no_model show False by simp
   next
     fix J
     assume dist: "distinct_indices_atoms (set as)" and J: "J \<subset> set I" 
     from J unsat[unfolded subsets_sat_core_def, folded i] 
     have J': "J \<subseteq> indices_state ?s" by auto
     from index_valid_distinct_indices[OF ivalid dist] J unsat[unfolded subsets_sat_core_def, folded i]
     obtain v where model: "(J, v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e ?s" by blast
     have "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s set as" "v \<Turnstile>\<^sub>t t" 
       using satisfying_state_valuation_to_atom_tabl[OF J' model ivalid dist]
        assert_all_state_tableau_equiv[OF D refl] by auto      
     then show "\<exists> v. v \<Turnstile>\<^sub>t t \<and> (J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s set as" by blast
   qed
 qed
 
 lemma (in Update) update_to_assert_bound_no_lhs: assumes pivot: "Pivot eqlvar (pivot :: var \<Rightarrow> var \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state)" 
   shows "AssertBoundNoLhs assert_bound" 
 proof
   fix s::"('i,'a) state" and a
   assume "\<not> \<U> s" "\<triangle> (\<T> s)" "\<nabla> s"
   then show "\<T> (assert_bound a s) = \<T> s"
     by (cases a, cases "snd a") (auto simp add: Let_def update_tableau_id tableau_valuated_def)
 next
   fix s::"('i,'a) state" and ia and as
   assume *: "\<not> \<U> s" "\<triangle> (\<T> s)" "\<nabla> s" and **: "\<U> (assert_bound ia s)"
     and index: "index_valid as s"
     and consistent: "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" 
   obtain i a where ia: "ia = (i,a)" by force
   let ?modelU = "\<lambda> lt UB UI s v x c i. UB s x = Some c \<longrightarrow> UI s x = i \<longrightarrow> i \<in> set (the (\<U>\<^sub>c s)) \<longrightarrow> (lt (v x) c \<or> v x = c)"
   let ?modelL = "\<lambda> lt LB LI s v x c i. LB s x = Some c \<longrightarrow> LI s x = i \<longrightarrow> i \<in> set (the (\<U>\<^sub>c s)) \<longrightarrow> (lt c (v x) \<or> c = v x)"
   let ?modelIU = "\<lambda> I lt UB UI s v x c i. UB s x = Some c \<longrightarrow> UI s x = i \<longrightarrow> i \<in> I \<longrightarrow> (v x = c)"
   let ?modelIL = "\<lambda> I lt LB LI s v x c i. LB s x = Some c \<longrightarrow> LI s x = i \<longrightarrow> i \<in> I \<longrightarrow> (v x = c)"
   let ?P' = "\<lambda> lt UBI LBI UB LB UBI_upd UI LI LE GE s.
     \<U> s \<longrightarrow> (set (the (\<U>\<^sub>c s)) \<subseteq> indices_state s \<and> \<not> (\<exists>v. (v \<Turnstile>\<^sub>t \<T> s
       \<and> (\<forall> x c i. ?modelU lt UB UI s v x c i)
       \<and> (\<forall> x c i. ?modelL lt LB LI s v x c i))))
       \<and> (distinct_indices_state s \<longrightarrow> (\<forall> I. I \<subset> set (the (\<U>\<^sub>c s)) \<longrightarrow> (\<exists> v. v \<Turnstile>\<^sub>t \<T> s \<and>
             (\<forall> x c i. ?modelIU I lt UB UI s v x c i) \<and> (\<forall> x c i. ?modelIL I lt LB LI s v x c i))))"
   have "\<U> (assert_bound ia s) \<longrightarrow> (unsat_state_core (assert_bound ia s) \<and> 
     (distinct_indices_state (assert_bound ia s) \<longrightarrow> subsets_sat_core (assert_bound ia s)))" (is "?P (assert_bound ia s)") unfolding ia
   proof (rule assert_bound_cases[of _ _ ?P'])
     fix s' :: "('i,'a) state"
     have id: "((x :: 'a) < y \<or> x = y) \<longleftrightarrow> x \<le> y" "((x :: 'a) > y \<or> x = y) \<longleftrightarrow> x \<ge> y" for x y by auto
     have id': "?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u undefined \<I>\<^sub>l \<I>\<^sub>u Geq Leq s' = ?P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l undefined \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'" 
       by (intro arg_cong[of _ _ "\<lambda> y. _ \<longrightarrow> y"] arg_cong[of _ _ "\<lambda> x. _ \<and> x"], 
         intro arg_cong2[of _ _ _ _ "(\<and>)"] arg_cong[of _ _ "\<lambda> y. _ \<longrightarrow> y"] arg_cong[of _ _ "\<lambda> y. \<forall> x \<subset> set (the (\<U>\<^sub>c s')). y x"] ext arg_cong[of _ _ Not],
         unfold id, auto)
     show "?P s' = ?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u undefined \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
       unfolding satisfies_state_def satisfies_bounds_index.simps satisfies_bounds.simps
         in_bounds.simps unsat_state_core_def satisfies_state_index.simps subsets_sat_core_def
         satisfies_state_index'.simps satisfies_bounds_index'.simps
       unfolding bound_compare''_defs id 
       by ((intro arg_cong[of _ _ "\<lambda> x. _ \<longrightarrow> x"] arg_cong[of _ _ "\<lambda> x. _ \<and> x"], 
         intro arg_cong2[of _ _ _ _ "(\<and>)"] refl arg_cong[of _ _ "\<lambda> x. _ \<longrightarrow> x"] arg_cong[of _ _ Not]
         arg_cong[of _ _ "\<lambda> y. \<forall> x \<subset> set (the (\<U>\<^sub>c s')). y x"] ext; intro arg_cong[of _ _ Ex] ext), auto)
     then show "?P s' = ?P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l undefined \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'" unfolding id' .
   next
     fix c::'a and x::nat and dir
     assume "\<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)" and dir: "dir = Positive \<or> dir = Negative"
     then obtain d where some: "LB dir s x = Some d" and lt: "lt dir c d"
       by (auto simp: bound_compare'_defs split: option.splits)
     from index[unfolded index_valid_def, rule_format, of x _ d]
       some dir obtain j where ind: "LI dir s x = j" "look (LBI dir s) x = Some (j,d)" and ge: "(j, GE dir x d) \<in> as"
       by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
     let ?s = "set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s)"
     let ?ss = "update\<B>\<I> (UBI_upd dir) i x c s" 
     show "?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir) ?s"
     proof (intro conjI impI allI, goal_cases)
       case 1
       thus ?case using dir ind ge lt some by (force simp: indices_state_def split: if_splits)
     next
       case 2
       {
         fix v
         assume vU: "\<forall> x c i. ?modelU (lt dir) (UB dir) (UI dir) ?s v x c i"
         assume vL: "\<forall> x c i. ?modelL (lt dir) (LB dir) (LI dir) ?s v x c i" 
         from dir have "UB dir ?s x = Some c" "UI dir ?s x = i" by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         from vU[rule_format, OF this] have vx_le_c: "lt dir (v x) c \<or> v x = c" by auto
         from dir ind some have *: "LB dir ?s x = Some d" "LI dir ?s x = j" by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         have d_le_vx: "lt dir d (v x) \<or> d = v x" by (intro vL[rule_format, OF *], insert some ind, auto)
         from dir d_le_vx vx_le_c lt
-        have False by auto
+        have False by (auto simp del: Simplex.bounds_lg)
       }
       thus ?case by blast
     next
       case (3 I)
       then obtain j where I: "I \<subseteq> {j}" by (auto split: if_splits)
       from 3 have dist: "distinct_indices_state ?ss" unfolding distinct_indices_state_def by auto
       have id1: "UB dir ?s y = UB dir ?ss y" "LB dir ?s y = LB dir ?ss y"
                "UI dir ?s y = UI dir ?ss y" "LI dir ?s y = LI dir ?ss y" 
                "\<T> ?s = \<T> s" 
                "set (the (\<U>\<^sub>c ?s)) = {i,LI dir s x}" for y        
         using dir by (auto simp: boundsu_def boundsl_def indexu_def indexl_def) 
       from I have id: "(\<forall> k. P1 k \<longrightarrow> P2 k \<longrightarrow> k \<in> I \<longrightarrow> Q k) \<longleftrightarrow> (I = {} \<or> (P1 j \<longrightarrow> P2 j \<longrightarrow> Q j))" for P1 P2 Q by auto
       have id2: "(UB dir s xa = Some ca \<longrightarrow> UI dir s xa = j \<longrightarrow> P) = (look (UBI dir s) xa = Some (j,ca) \<longrightarrow> P)"
           "(LB dir s xa = Some ca \<longrightarrow> LI dir s xa = j \<longrightarrow> P) = (look (LBI dir s) xa = Some (j,ca) \<longrightarrow> P)" for xa ca P s
         using dir by (auto simp: boundsu_def indexu_def boundsl_def indexl_def)
       have "\<exists>v. v \<Turnstile>\<^sub>t \<T> s \<and>
              (\<forall>xa ca ia.
                  UB dir ?ss xa = Some ca \<longrightarrow> UI dir ?ss xa = ia \<longrightarrow> ia \<in> I \<longrightarrow> v xa = ca) \<and>
              (\<forall>xa ca ia.
                  LB dir ?ss xa = Some ca \<longrightarrow> LI dir ?ss xa = ia \<longrightarrow> ia \<in> I \<longrightarrow> v xa = ca)" 
       proof (cases "\<exists> xa ca. look (UBI dir ?ss) xa = Some (j,ca) \<or> look (LBI dir ?ss) xa = Some (j,ca)")
         case False
         thus ?thesis unfolding id id2 using consistent unfolding curr_val_satisfies_no_lhs_def 
           by (intro exI[of _ "\<langle>\<V> s\<rangle>"], auto)
       next
         case True
         from consistent have val: " \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s" unfolding curr_val_satisfies_no_lhs_def by auto
         define ss where ss: "ss = ?ss" 
         from True obtain y b where "look (UBI dir ?ss) y = Some (j,b) \<or> look (LBI dir ?ss) y = Some (j,b)" by force
         then have id3: "(look (LBI dir ss) yy = Some (j,bb) \<or> look (UBI dir ss) yy = Some (j,bb)) \<longleftrightarrow> (yy = y \<and> bb = b)" for yy bb 
           using distinct_indices_stateD(1)[OF dist, of y j b yy bb] using dir
           unfolding ss[symmetric] 
           by (auto simp: boundsu_def boundsl_def indexu_def indexl_def)
         have "\<exists>v. v \<Turnstile>\<^sub>t \<T> s \<and> v y = b" 
         proof (cases "y \<in> lvars (\<T> s)")
           case False
           let ?v = "\<langle>\<V> (update y b s)\<rangle>" 
           show ?thesis
           proof (intro exI[of _ ?v] conjI)
             from update_satisfies_tableau[OF *(2,3) False] val 
             show "?v \<Turnstile>\<^sub>t \<T> s" by simp
             from update_valuation_nonlhs[OF *(2,3) False, of y b] False
             show "?v y = b" by (simp add: map2fun_def')
           qed
         next
           case True            
           from *(2)[unfolded normalized_tableau_def]
           have zero: "0 \<notin> rhs ` set (\<T> s)" by auto
           interpret Pivot eqlvar pivot by fact
           interpret PivotUpdate eqlvar pivot update ..
           let ?eq = "eq_for_lvar (\<T> s) y" 
           from eq_for_lvar[OF True] have "?eq \<in> set (\<T> s)" "lhs ?eq = y" by auto
           with zero have rhs: "rhs ?eq \<noteq> 0" by force
           hence "rvars_eq ?eq \<noteq> {}"
             by (simp add: vars_empty_zero)
           then obtain z where z: "z \<in> rvars_eq ?eq" by auto
           let ?v = "\<V> (pivot_and_update y z b s)" 
           let ?vv = "\<langle>?v\<rangle>" 
           from pivotandupdate_valuation_xi[OF *(2,3) True z]
           have "look ?v y = Some b" .
           hence vv: "?vv y = b" unfolding map2fun_def' by auto
           show ?thesis
           proof (intro exI[of _ ?vv] conjI vv)
             show "?vv \<Turnstile>\<^sub>t \<T> s" using pivotandupdate_satisfies_tableau[OF *(2,3) True z] val by auto
           qed
         qed
         thus ?thesis unfolding id id2 ss[symmetric] using id3 by metis
       qed
       thus ?case unfolding id1 .
     qed
   next
     fix c::'a and x::nat and dir
     assume **: "dir = Positive \<or> dir = Negative" "a = LE dir x c" "x \<notin> lvars (\<T> s)" "lt dir c (\<langle>\<V> s\<rangle> x)" 
       "\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)" "\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)"
     let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
     show "?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
       (update x c ?s)"
       using * **
       by (auto simp add: update_unsat_id tableau_valuated_def)
   qed (auto simp add: * update_unsat_id tableau_valuated_def)
   with ** show "minimal_unsat_state_core (assert_bound ia s)" by (auto simp: minimal_unsat_state_core_def)
 next
   fix s::"('i,'a) state" and ia
   assume *: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" "\<triangle> (\<T> s)" "\<nabla> s"
     and **: "\<not> \<U> (assert_bound ia s)" (is ?lhs)
   obtain i a where ia: "ia = (i,a)" by force
   have "\<langle>\<V> (assert_bound ia s)\<rangle> \<Turnstile>\<^sub>t \<T> (assert_bound ia s)"
   proof-
     let ?P = "\<lambda> lt UBI LBI UB LB UBI_upd UI LI LE GE s. \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s"
     show ?thesis unfolding ia
     proof (rule assert_bound_cases[of _ _ ?P])
       fix c x and dir :: "('i,'a) Direction"
       let ?s' = "update\<B>\<I> (UBI_upd dir) i x c s"
       assume "x \<notin> lvars (\<T> s)" "(lt dir) c (\<langle>\<V> s\<rangle> x)"
         "dir = Positive \<or> dir = Negative"
       then show "\<langle>\<V> (update x c ?s')\<rangle> \<Turnstile>\<^sub>t \<T> (update x c ?s')"
         using *
         using update_satisfies_tableau[of ?s' x c] update_tableau_id
         by (auto simp add: curr_val_satisfies_no_lhs_def tableau_valuated_def)
     qed (insert *, auto simp add: curr_val_satisfies_no_lhs_def)
   qed
   moreover
   have "\<not> \<U> (assert_bound ia s) \<longrightarrow> \<langle>\<V> (assert_bound ia s)\<rangle> \<Turnstile>\<^sub>b \<B> (assert_bound ia s) \<parallel> - lvars (\<T> (assert_bound ia s))" (is "?P (assert_bound ia s)")
   proof-
     let ?P' = "\<lambda> lt UBI LBI UB LB UB_upd UI LI LE GE s.
       \<not> \<U> s \<longrightarrow> (\<forall>x\<in>- lvars (\<T> s). \<unrhd>\<^sub>l\<^sub>b lt (\<langle>\<V> s\<rangle> x) (LB s x) \<and> \<unlhd>\<^sub>u\<^sub>b lt (\<langle>\<V> s\<rangle> x) (UB s x))"
     let ?P'' = "\<lambda> dir. ?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)"
 
     have x: "\<And> s'. ?P s' = ?P' (<) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'"
       and xx: "\<And> s'. ?P s' = ?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
       unfolding satisfies_bounds_set.simps in_bounds.simps bound_compare_defs
       by (auto split: option.split)
 
     show ?thesis unfolding ia
     proof (rule assert_bound_cases[of _ _ ?P'])
       fix dir :: "('i,'a) Direction"
       assume "dir = Positive \<or> dir = Negative"
       then show "?P'' dir s"
         using  x[of s] xx[of s] \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>
         by (auto simp add: curr_val_satisfies_no_lhs_def)
     next
       fix x c and dir :: "('i,'a) Direction"
       let ?s' = "update\<B>\<I> (UBI_upd dir) i x c s"
       assume "x \<in> lvars (\<T> s)" "dir = Positive \<or> dir = Negative"
       then have "?P ?s'"
         using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>
         by (auto simp add: satisfies_bounds_set.simps curr_val_satisfies_no_lhs_def
             boundsl_def boundsu_def indexl_def indexu_def)
       then show "?P'' dir ?s'"
         using x[of ?s'] xx[of ?s'] \<open>dir = Positive \<or> dir = Negative\<close>
         by auto
     next
       fix c x and dir :: "('i,'a) Direction"
       let ?s' = "update\<B>\<I> (UBI_upd dir) i x c s"
       assume "\<not> lt dir c (\<langle>\<V> s\<rangle> x)" "dir = Positive \<or> dir = Negative"
       then show "?P'' dir ?s'"
         using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>
         by (auto simp add: satisfies_bounds_set.simps curr_val_satisfies_no_lhs_def
             simp: boundsl_def boundsu_def indexl_def indexu_def)
           (auto simp add: bound_compare_defs)
     next
       fix c x and dir :: "('i,'a) Direction"
       let ?s' = "update x c (update\<B>\<I> (UBI_upd dir) i x c s)"
       assume "x \<notin> lvars (\<T> s)" "\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)"
         "dir = Positive \<or> dir = Negative"
       show "?P'' dir ?s'"
       proof (rule impI, rule ballI)
         fix y
         assume "\<not> \<U> ?s'" "y \<in> - lvars (\<T> ?s')"
         show "\<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> ?s'\<rangle> y) (LB dir ?s' y) \<and> \<unlhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> ?s'\<rangle> y) (UB dir ?s' y)"
         proof (cases "x = y")
           case True
           then show ?thesis
             using \<open>x \<notin> lvars (\<T> s)\<close>
             using \<open>y \<in> - lvars (\<T> ?s')\<close>
             using \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)\<close>
             using \<open>dir = Positive \<or> dir = Negative\<close>
             using neg_bounds_compare(7) neg_bounds_compare(3)
             using *
             by (auto simp add: update_valuation_nonlhs update_tableau_id update_bounds_id bound_compare''_defs map2fun_def tableau_valuated_def bounds_updates) (force simp add: bound_compare'_defs)+
         next
           case False
           then show ?thesis
             using \<open>x \<notin> lvars (\<T> s)\<close> \<open>y \<in> - lvars (\<T> ?s')\<close>
             using \<open>dir = Positive \<or> dir = Negative\<close> *
             by (auto simp add: update_valuation_nonlhs update_tableau_id update_bounds_id  bound_compare''_defs satisfies_bounds_set.simps curr_val_satisfies_no_lhs_def map2fun_def
                 tableau_valuated_def bounds_updates)
         qed
       qed
     qed (auto simp add: x xx)
   qed
   moreover
   have "\<not> \<U> (assert_bound ia s) \<longrightarrow> \<diamond> (assert_bound ia s)" (is "?P (assert_bound ia s)")
   proof-
     let ?P' = "\<lambda> lt UBI LBI UB LB UBI_upd UI LI LE GE s.
       \<not> \<U> s \<longrightarrow>
       (\<forall>x. if LB s x = None \<or> UB s x = None then True
            else lt (the (LB s x)) (the (UB s x)) \<or> (the (LB s x) = the (UB s x)))"
     let ?P'' = "\<lambda> dir. ?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)"
 
     have x: "\<And> s'. ?P s' = ?P' (<) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'" and
       xx: "\<And> s'. ?P s' = ?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
       unfolding bounds_consistent_def
       by auto
 
     show ?thesis unfolding ia
     proof (rule assert_bound_cases[of _ _ ?P'])
       fix dir :: "('i,'a) Direction"
       assume "dir = Positive \<or> dir = Negative"
       then show "?P'' dir s"
         using \<open>\<diamond> s\<close>
         by (auto simp add: bounds_consistent_def) (erule_tac x=x in allE, auto)+
     next
       fix x c and dir :: "('i,'a) Direction"
       let ?s' = "update x c (update\<B>\<I> (UBI_upd dir) i x c s)"
       assume "dir = Positive \<or> dir = Negative" "x \<notin> lvars (\<T> s)"
         "\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)" "\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)"
       then show "?P'' dir ?s'"
         using \<open>\<diamond> s\<close> *
         unfolding bounds_consistent_def
         by (auto simp add: update_bounds_id tableau_valuated_def bounds_updates split: if_splits)
           (force simp add: bound_compare'_defs, erule_tac x=xa in allE, simp)+
     next
       fix x c and dir :: "('i,'a) Direction"
       let ?s' = "update\<B>\<I> (UBI_upd dir) i x c s"
       assume "\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)" "\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)"
         "dir = Positive \<or> dir = Negative"
       then have "?P'' dir ?s'"
         using \<open>\<diamond> s\<close>
         unfolding bounds_consistent_def
         by (auto split: if_splits simp: bounds_updates)
           (force simp add: bound_compare'_defs, erule_tac x=xa in allE, simp)+
       then show "?P'' dir ?s'" "?P'' dir ?s'"
         by simp_all
     qed (auto simp add: x xx)
   qed
 
   ultimately
 
   show "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound ia s) \<and> \<diamond> (assert_bound ia s)"
     using \<open>?lhs\<close>
     unfolding curr_val_satisfies_no_lhs_def
     by simp
 next
   fix s :: "('i,'a) state" and ats and ia :: "('i,'a) i_atom"
   assume "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<triangle> (\<T> s)" "\<nabla> s"
   obtain i a where ia: "ia = (i,a)" by force
   {
     fix ats
     let ?P' = "\<lambda> lt UBI LBI UB LB UB_upd UI LI LE GE s'. ats \<doteq> \<B> s \<longrightarrow> (ats \<union> {a}) \<doteq> \<B> s'"
     let ?P'' = "\<lambda> dir. ?P' (lt dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)"
     have "ats \<doteq> \<B> s \<longrightarrow> (ats \<union> {a}) \<doteq> \<B> (assert_bound ia s)" (is "?P (assert_bound ia s)")
       unfolding ia
     proof (rule assert_bound_cases[of _ _ ?P'])
       fix x c and dir :: "('i,'a) Direction"
       assume "dir = Positive \<or> dir = Negative" "a = LE dir x c" "\<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)"
       then show "?P s"
         unfolding atoms_equiv_bounds.simps satisfies_atom_set_def satisfies_bounds.simps
         by auto (erule_tac x=x in allE, force simp add: bound_compare_defs)+
     next
       fix x c and dir :: "('i,'a) Direction"
       let ?s' = "set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s)"
 
       assume "dir = Positive \<or> dir = Negative" "a = LE dir x c" "\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x))"
       then show "?P ?s'" unfolding set_unsat_bounds_id
         using atoms_equiv_bounds_extend[of dir c s x ats i]
         by auto
     next
       fix x c and dir :: "('i,'a) Direction"
       let ?s' = "update\<B>\<I> (UBI_upd dir) i x c s"
       assume "dir = Positive \<or> dir = Negative" "a = LE dir x c" "\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x))"
       then have "?P ?s'"
         using atoms_equiv_bounds_extend[of dir c s x ats i]
         by auto
       then show "?P ?s'" "?P ?s'"
         by simp_all
     next
       fix x c and dir :: "('i,'a) Direction"
       let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
       let ?s' = "update x c ?s"
       assume *: "dir = Positive \<or> dir = Negative" "a = LE dir x c" "\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x))" "x \<notin> lvars (\<T> s)"
       then have "\<triangle> (\<T> ?s)" "\<nabla> ?s" "x \<notin> lvars (\<T> ?s)"
         using \<open>\<triangle> (\<T> s)\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close> \<open>\<nabla> s\<close>
         by (auto simp: tableau_valuated_def)
       from update_bounds_id[OF this, of c]
       have "\<B>\<^sub>i ?s' = \<B>\<^sub>i ?s" by blast
       then have id: "\<B> ?s' = \<B> ?s" unfolding boundsl_def boundsu_def by auto
       show "?P ?s'" unfolding id \<open>a = LE dir x c\<close>
         by (intro impI atoms_equiv_bounds_extend[rule_format] *(1,3))
     qed simp_all
   }
   then show "flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {ia}) \<doteq> \<B> (assert_bound ia s)" unfolding ia by auto
 next
   fix s :: "('i,'a) state" and ats and ia :: "('i,'a) i_atom"
   obtain i a where ia: "ia = (i,a)" by force
   assume "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<triangle> (\<T> s)" "\<nabla> s"
   have *: "\<And> dir x c s. dir = Positive \<or> dir = Negative \<Longrightarrow>
      \<nabla> (update\<B>\<I> (UBI_upd dir) i x c s) = \<nabla> s"
     "\<And> s y I . \<nabla> (set_unsat I s) = \<nabla> s"
     by (auto simp add: tableau_valuated_def)
 
   show "\<nabla> (assert_bound ia s)" (is "?P (assert_bound ia s)")
   proof-
     let ?P' = "\<lambda> lt UBI LBI UB LB UB_upd UI LI LE GE s'. \<nabla> s'"
     let ?P'' = "\<lambda> dir. ?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)"
     show ?thesis unfolding ia
     proof (rule assert_bound_cases[of _ _ ?P'])
       fix x c and dir :: "('i,'a) Direction"
       let ?s' = "update\<B>\<I> (UBI_upd dir) i x c s"
       assume "dir = Positive \<or> dir = Negative"
       then have "\<nabla> ?s'"
         using *(1)[of dir x c s] \<open>\<nabla> s\<close>
         by simp
       then show "\<nabla> (set_unsat [i, ((LI dir) s x)] ?s')"
         using *(2) by auto
     next
       fix x c and dir :: "('i,'a) Direction"
       assume *: "x \<notin> lvars (\<T> s)" "dir = Positive \<or> dir = Negative"
       let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
       let ?s' = "update x c ?s"
       from * show "\<nabla> ?s'"
         using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close>
         using update_tableau_valuated[of ?s x c]
         by (auto simp add: tableau_valuated_def)
     qed (insert \<open>\<nabla> s\<close> *(1), auto)
   qed
 next
   fix s :: "('i,'a) state" and as and ia :: "('i,'a) i_atom"
   obtain i a where ia: "ia = (i,a)" by force
   assume *: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<triangle> (\<T> s)" "\<nabla> s"
     and valid: "index_valid as s"
   have id: "\<And> dir x c s. dir = Positive \<or> dir = Negative \<Longrightarrow>
      \<nabla> (update\<B>\<I> (UBI_upd dir) i x c s) = \<nabla> s"
     "\<And> s y I. \<nabla> (set_unsat I s) = \<nabla> s"
     by (auto simp add: tableau_valuated_def)
   let ?I = "insert (i,a) as"
   define I where "I = ?I"
   from index_valid_mono[OF _ valid] have valid: "index_valid I s" unfolding I_def by auto
   have I: "(i,a) \<in> I" unfolding I_def by auto
   let ?P = "\<lambda> s. index_valid I s"
   let ?P' = "\<lambda> (lt :: 'a \<Rightarrow> 'a \<Rightarrow> bool)
     (UBI :: ('i,'a) state \<Rightarrow> ('i,'a) bounds_index) (LBI :: ('i,'a) state \<Rightarrow> ('i,'a) bounds_index)
     (UB :: ('i,'a) state \<Rightarrow> 'a bounds) (LB :: ('i,'a) state \<Rightarrow> 'a bounds)
     (UBI_upd :: (('i,'a) bounds_index \<Rightarrow> ('i,'a) bounds_index) \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state)
     (UI :: ('i,'a) state \<Rightarrow> 'i bound_index) (LI :: ('i,'a) state \<Rightarrow> 'i bound_index)
     LE GE s'.
     (\<forall> x c i. look (UBI s') x = Some (i,c) \<longrightarrow> (i,LE (x :: var) c) \<in> I) \<and>
     (\<forall> x c i. look (LBI s') x = Some (i,c) \<longrightarrow> (i,GE (x :: nat) c) \<in> I)"
   define P where "P = ?P'"
   let ?P'' = "\<lambda> (dir :: ('i,'a) Direction).
     P (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)"
   have x: "\<And> s'. ?P s' = P (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'"
     and xx: "\<And> s'. ?P s' = P (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
     unfolding satisfies_bounds_set.simps in_bounds.simps bound_compare_defs index_valid_def P_def
     by (auto split: option.split simp: indexl_def indexu_def boundsl_def boundsu_def)
   from valid have P'': "dir = Positive \<or> dir = Negative \<Longrightarrow> ?P'' dir s" for dir
     using x[of s] xx[of s] by auto
   have UTrue: "dir = Positive \<or> dir = Negative \<Longrightarrow> ?P'' dir s \<Longrightarrow> ?P'' dir (set_unsat I s)" for dir s I
     unfolding P_def by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
   have updateIB: "a = LE dir x c \<Longrightarrow> dir = Positive \<or> dir = Negative \<Longrightarrow> ?P'' dir s \<Longrightarrow> ?P'' dir
     (update\<B>\<I> (UBI_upd dir) i x c s)" for dir x c s
     unfolding P_def using I by (auto split: if_splits simp: simp: boundsl_def boundsu_def indexl_def indexu_def)
   show "index_valid (insert ia as) (assert_bound ia s)" unfolding ia I_def[symmetric]
   proof ((rule assert_bound_cases[of _ _ P]; (intro UTrue x xx updateIB P'')?))
     fix x c and dir :: "('i,'a) Direction"
     assume **: "dir = Positive \<or> dir = Negative"
       "a = LE dir x c"
       "x \<notin> lvars (\<T> s)"
     let ?s = "(update\<B>\<I> (UBI_upd dir) i x c s)"
     define s' where "s' = ?s"
     have 1: "\<triangle> (\<T> ?s)" using * ** by auto
     have 2: "\<nabla> ?s" using id(1) ** * \<open>\<nabla> s\<close> by auto
     have 3: "x \<notin> lvars (\<T> ?s)" using id(1) ** * \<open>\<nabla> s\<close> by auto
     have "?P'' dir ?s" using ** by (intro updateIB P'') auto
     with update_id[of ?s x c, OF 1 2 3, unfolded Let_def]  **(1)
     show "P (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
         (update x c (update\<B>\<I> (UBI_upd dir) i x c s))"
       unfolding P_def s'_def[symmetric] by auto
   qed auto
 next
   fix s and ia :: "('i,'a) i_atom" and ats :: "('i,'a) i_atom set"
   assume *: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s" and ats: "ats \<Turnstile>\<^sub>i \<B>\<I> s"
   obtain i a where ia: "ia = (i,a)" by force
   have id: "\<And> dir x c s. dir = Positive \<or> dir = Negative \<Longrightarrow>
      \<nabla> (update\<B>\<I> (UBI_upd dir) i x c s) = \<nabla> s"
     "\<And> s I. \<nabla> (set_unsat I s) = \<nabla> s"
     by (auto simp add: tableau_valuated_def)
   have idlt: "(c < (a :: 'a) \<or> c = a) = (c \<le> a)"
     "(a < c \<or> c = a) = (c \<ge> a)" for a c by auto
   define A where "A = insert (i,a) ats"
   let ?P = "\<lambda> (s :: ('i,'a) state). A \<Turnstile>\<^sub>i \<B>\<I> s"
   let ?Q = "\<lambda> bs (lt :: 'a \<Rightarrow> 'a \<Rightarrow> bool)
     (UBI :: ('i,'a) state \<Rightarrow> ('i,'a) bounds_index) (LBI :: ('i,'a) state \<Rightarrow> ('i,'a) bounds_index)
     (UB :: ('i,'a) state \<Rightarrow> 'a bounds) (LB :: ('i,'a) state \<Rightarrow> 'a bounds)
     (UBI_upd :: (('i,'a) bounds_index \<Rightarrow> ('i,'a) bounds_index) \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state)
     UI LI
     (LE :: nat \<Rightarrow> 'a \<Rightarrow> 'a atom) (GE :: nat \<Rightarrow> 'a \<Rightarrow> 'a atom) s'.
        (\<forall> I v. (I :: 'i set,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s bs \<longrightarrow>
        ((\<forall> x c. LB s' x = Some c \<longrightarrow> LI s' x \<in> I \<longrightarrow> lt c (v x) \<or> c = v x)
       \<and> (\<forall> x c. UB s' x = Some c \<longrightarrow> UI s' x \<in> I \<longrightarrow> lt (v x) c \<or> v x = c)))"
   define Q where "Q = ?Q"
   let ?P' = "Q A"
   have equiv:
     "bs \<Turnstile>\<^sub>i \<B>\<I> s' \<longleftrightarrow> Q bs (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'"
     "bs \<Turnstile>\<^sub>i \<B>\<I> s' \<longleftrightarrow> Q bs (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
     for bs s'
     unfolding satisfies_bounds_set.simps in_bounds.simps bound_compare_defs index_valid_def Q_def
       atoms_imply_bounds_index.simps
     by (atomize(full), (intro conjI iff_exI allI arg_cong2[of _ _ _ _ "(\<and>)"] refl iff_allI
           arg_cong2[of _ _ _ _ "(=)"]; unfold satisfies_bounds_index.simps idlt), auto)
   have x: "\<And> s'. ?P s' = ?P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'"
     and xx: "\<And> s'. ?P s' = ?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
     using equiv by blast+
   from ats equiv[of ats s]
   have Q_ats:
     "Q ats (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s"
     "Q ats (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s"
     by auto
   let ?P'' = "\<lambda> (dir :: ('i,'a) Direction). ?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)"
   have P_upd: "dir = Positive \<or> dir = Negative \<Longrightarrow> ?P'' dir (set_unsat I s) = ?P'' dir s" for s I dir
     unfolding Q_def
     by (intro iff_exI arg_cong2[of _ _ _ _ "(\<and>)"] refl iff_allI arg_cong2[of _ _ _ _ "(=)"]
         arg_cong2[of _ _ _ _ "(\<longrightarrow>)"], auto simp: boundsl_def boundsu_def indexl_def indexu_def)
   have P_upd: "dir = Positive \<or> dir = Negative \<Longrightarrow> ?P'' dir s \<Longrightarrow> ?P'' dir (set_unsat I s)" for s I dir
     using P_upd[of dir] by blast
   have ats_sub: "ats \<subseteq> A" unfolding A_def by auto
   {
     fix x c and dir :: "('i,'a) Direction"
     assume dir: "dir = Positive \<or> dir = Negative"
       and a: "a = LE dir x c"
     from Q_ats dir
     have Q_ats: "Q ats (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir) s"
       by auto
     have "?P'' dir (update\<B>\<I> (UBI_upd dir) i x c s)"
       unfolding Q_def
     proof (intro allI impI conjI)
       fix I v y d
       assume IvA: "(I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s A"
       from i_satisfies_atom_set_mono[OF ats_sub this]
       have "(I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s ats" by auto
       from Q_ats[unfolded Q_def, rule_format, OF this]
       have s_bnds:
         "LB dir s x = Some c \<Longrightarrow> LI dir s x \<in> I \<Longrightarrow> lt dir c (v x) \<or> c = v x"
         "UB dir s x = Some c \<Longrightarrow> UI dir s x \<in> I \<Longrightarrow> lt dir (v x) c \<or> v x = c" for x c by auto
       from IvA[unfolded A_def, unfolded i_satisfies_atom_set.simps satisfies_atom_set_def, simplified]
       have va: "i \<in> I \<Longrightarrow> v \<Turnstile>\<^sub>a a" by auto
       with a dir have vc: "i \<in> I \<Longrightarrow> lt dir (v x) c \<or> v x = c"
         by auto
       let ?s = "(update\<B>\<I> (UBI_upd dir) i x c s)"
       show "LB dir ?s y = Some d \<Longrightarrow> LI dir ?s y \<in> I \<Longrightarrow> lt dir d (v y) \<or> d = v y"
         "UB dir ?s y = Some d \<Longrightarrow> UI dir ?s y \<in> I \<Longrightarrow> lt dir (v y) d \<or> v y = d"
       proof (atomize(full), goal_cases)
         case 1
         consider (main) "y = x" "UI dir ?s x = i" |
           (easy1) "x \<noteq> y" | (easy2) "x = y" "UI dir ?s y \<noteq> i"
           by blast
         then show ?case
         proof cases
           case easy1
           then show ?thesis using s_bnds[of y d] dir by (fastforce simp: boundsl_def boundsu_def indexl_def indexu_def)
         next
           case easy2
           then show ?thesis using s_bnds[of y d] dir by (fastforce simp: boundsl_def boundsu_def indexl_def indexu_def)
         next
           case main
           note s_bnds = s_bnds[of x]
           show ?thesis unfolding main using s_bnds dir vc
             by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         qed
       qed
     qed
   } note main = this
   have Ps: "dir = Positive \<or> dir = Negative \<Longrightarrow> ?P'' dir s" for dir
     using Q_ats unfolding Q_def using i_satisfies_atom_set_mono[OF ats_sub] by fastforce
   have "?P (assert_bound (i,a) s)"
   proof ((rule assert_bound_cases[of _ _ ?P']; (intro x xx P_upd main Ps)?))
     fix c x and dir :: "('i,'a) Direction"
     assume **: "dir = Positive \<or> dir = Negative"
       "a = LE dir x c"
       "x \<notin> lvars (\<T> s)"
     let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
     define s' where "s' = ?s"
     from main[OF **(1-2)] have P: "?P'' dir s'" unfolding s'_def .
     have 1: "\<triangle> (\<T> ?s)" using * ** by auto
     have 2: "\<nabla> ?s" using id(1) ** * \<open>\<nabla> s\<close> by auto
     have 3: "x \<notin> lvars (\<T> ?s)" using id(1) ** * \<open>\<nabla> s\<close> by auto
     have "\<triangle> (\<T> s')" "\<nabla> s'" "x \<notin> lvars (\<T> s')" using 1 2 3 unfolding s'_def by auto
     from update_bounds_id[OF this, of c] **(1)
     have "?P'' dir (update x c s') = ?P'' dir s'"
       unfolding Q_def
       by (intro iff_allI arg_cong2[of _ _ _ _ "(\<longrightarrow>)"] arg_cong2[of _ _ _ _ "(\<and>)"] refl, auto)
     with P
     show "?P'' dir (update x c ?s)" unfolding s'_def by blast
   qed auto
   then show "insert ia ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound ia s)" unfolding ia A_def by blast
 qed
 
 
 text \<open>Pivoting the tableau can be reduced to pivoting single equations,
   and substituting variable by polynomials. These operations are specified
   by:\<close>
 
 locale PivotEq =
   fixes pivot_eq::"eq \<Rightarrow> var \<Rightarrow> eq"
   assumes
     \<comment> \<open>Lhs var of @{text eq} and @{text x\<^sub>j} are swapped,
      while the other variables do not change sides.\<close>
     vars_pivot_eq:"
 \<lbrakk>x\<^sub>j \<in> rvars_eq eq; lhs eq \<notin> rvars_eq eq \<rbrakk> \<Longrightarrow> let eq' = pivot_eq eq x\<^sub>j in
     lhs eq' = x\<^sub>j \<and> rvars_eq eq' = {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})" and
 
 \<comment> \<open>Pivoting keeps the equation equisatisfiable.\<close>
 
 equiv_pivot_eq:
 "\<lbrakk>x\<^sub>j \<in> rvars_eq eq; lhs eq \<notin> rvars_eq eq \<rbrakk> \<Longrightarrow>
     (v::'a::lrv valuation) \<Turnstile>\<^sub>e pivot_eq eq x\<^sub>j \<longleftrightarrow> v \<Turnstile>\<^sub>e eq"
 
 begin
 
 lemma lhs_pivot_eq:
   "\<lbrakk>x\<^sub>j \<in> rvars_eq eq; lhs eq \<notin> rvars_eq eq \<rbrakk> \<Longrightarrow> lhs (pivot_eq eq x\<^sub>j) = x\<^sub>j"
   using vars_pivot_eq
   by (simp add: Let_def)
 
 lemma rvars_pivot_eq:
   "\<lbrakk>x\<^sub>j \<in> rvars_eq eq; lhs eq \<notin> rvars_eq eq \<rbrakk> \<Longrightarrow> rvars_eq (pivot_eq eq x\<^sub>j) = {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})"
   using vars_pivot_eq
   by (simp add: Let_def)
 
 end
 
 
 abbreviation doublesub (" _ \<subseteq>s _ \<subseteq>s _" [50,51,51] 50) where
   "doublesub a b c \<equiv> a \<subseteq> b \<and> b \<subseteq> c"
 
 
 locale SubstVar =
   fixes subst_var::"var \<Rightarrow> linear_poly \<Rightarrow> linear_poly \<Rightarrow> linear_poly"
   assumes
     \<comment> \<open>Effect of @{text "subst_var x\<^sub>j lp' lp"} on @{text lp} variables.\<close>
 
 vars_subst_var':
 "(vars lp - {x\<^sub>j}) - vars lp' \<subseteq>s vars (subst_var x\<^sub>j lp' lp) \<subseteq>s (vars lp - {x\<^sub>j}) \<union> vars lp'"and
 
 subst_no_effect: "x\<^sub>j \<notin> vars lp \<Longrightarrow> subst_var x\<^sub>j lp' lp = lp" and
 
 subst_with_effect: "x\<^sub>j \<in> vars lp \<Longrightarrow> x \<in> vars lp' - vars lp \<Longrightarrow> x \<in> vars (subst_var x\<^sub>j lp' lp)" and
 
 \<comment> \<open>Effect of @{text "subst_var x\<^sub>j lp' lp"} on @{text lp} value.\<close>
 
 equiv_subst_var:
 "(v::'a :: lrv valuation) x\<^sub>j = lp' \<lbrace>v\<rbrace> \<longrightarrow> lp \<lbrace>v\<rbrace> = (subst_var x\<^sub>j lp' lp) \<lbrace>v\<rbrace>"
 
 begin
 
 lemma vars_subst_var:
   "vars (subst_var x\<^sub>j lp' lp) \<subseteq> (vars lp - {x\<^sub>j}) \<union> vars lp'"
   using vars_subst_var'
   by simp
 
 lemma vars_subst_var_supset:
   "vars (subst_var x\<^sub>j lp' lp) \<supseteq> (vars lp - {x\<^sub>j}) - vars lp'"
   using vars_subst_var'
   by simp
 
 definition subst_var_eq :: "var \<Rightarrow> linear_poly \<Rightarrow> eq \<Rightarrow> eq" where
   "subst_var_eq v lp' eq \<equiv> (lhs eq, subst_var v lp' (rhs eq))"
 
 lemma rvars_eq_subst_var_eq:
   shows "rvars_eq (subst_var_eq x\<^sub>j lp eq) \<subseteq> (rvars_eq eq - {x\<^sub>j}) \<union> vars lp"
   unfolding subst_var_eq_def
   by (auto simp add: vars_subst_var)
 
 lemma rvars_eq_subst_var_eq_supset:
   "rvars_eq (subst_var_eq x\<^sub>j lp eq) \<supseteq> (rvars_eq eq) - {x\<^sub>j} - (vars lp)"
   unfolding subst_var_eq_def
   by (simp add: vars_subst_var_supset)
 
 lemma equiv_subst_var_eq:
   assumes "(v::'a valuation) \<Turnstile>\<^sub>e (x\<^sub>j, lp')"
   shows "v \<Turnstile>\<^sub>e eq \<longleftrightarrow> v \<Turnstile>\<^sub>e subst_var_eq x\<^sub>j lp' eq"
   using assms
   unfolding subst_var_eq_def
   unfolding satisfies_eq_def
   using equiv_subst_var[of v x\<^sub>j lp' "rhs eq"]
   by auto
 end
 
 locale Pivot' = EqForLVar + PivotEq + SubstVar
 begin
 definition pivot_tableau' :: "var \<Rightarrow> var \<Rightarrow> tableau \<Rightarrow> tableau" where
   "pivot_tableau' x\<^sub>i x\<^sub>j t \<equiv>
     let x\<^sub>i_idx = eq_idx_for_lvar t x\<^sub>i; eq = t ! x\<^sub>i_idx; eq' = pivot_eq eq x\<^sub>j in
     map (\<lambda> idx. if idx = x\<^sub>i_idx then
                     eq'
                 else
                     subst_var_eq x\<^sub>j (rhs eq') (t ! idx)
         ) [0..<length t]"
 
 definition pivot' :: "var \<Rightarrow> var \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> ('i,'a) state" where
   "pivot' x\<^sub>i x\<^sub>j s \<equiv> \<T>_update (pivot_tableau' x\<^sub>i x\<^sub>j (\<T> s)) s"
 
 text\<open>\noindent Then, the next implementation of \<open>pivot\<close> satisfies its specification:\<close>
 
 definition pivot_tableau :: "var \<Rightarrow> var \<Rightarrow> tableau \<Rightarrow> tableau" where
   "pivot_tableau x\<^sub>i x\<^sub>j t \<equiv> let eq = eq_for_lvar t x\<^sub>i; eq' = pivot_eq eq x\<^sub>j in
     map (\<lambda> e. if lhs e = lhs eq then eq' else subst_var_eq x\<^sub>j (rhs eq') e) t"
 
 definition pivot :: "var \<Rightarrow> var \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> ('i,'a) state" where
   "pivot x\<^sub>i x\<^sub>j s \<equiv> \<T>_update (pivot_tableau x\<^sub>i x\<^sub>j (\<T> s)) s"
 
 lemma pivot_tableau'pivot_tableau:
   assumes "\<triangle> t" "x\<^sub>i \<in> lvars t"
   shows "pivot_tableau' x\<^sub>i x\<^sub>j t = pivot_tableau x\<^sub>i x\<^sub>j t"
 proof-
   let ?f = "\<lambda>idx. if idx = eq_idx_for_lvar t x\<^sub>i then pivot_eq (t ! eq_idx_for_lvar t x\<^sub>i) x\<^sub>j
           else subst_var_eq x\<^sub>j (rhs (pivot_eq (t ! eq_idx_for_lvar t x\<^sub>i) x\<^sub>j)) (t ! idx)"
   let ?f' = "\<lambda>e. if lhs e = lhs (eq_for_lvar t x\<^sub>i) then pivot_eq (eq_for_lvar t x\<^sub>i) x\<^sub>j else subst_var_eq x\<^sub>j (rhs (pivot_eq (eq_for_lvar t x\<^sub>i) x\<^sub>j)) e"
   have "\<forall> i < length t. ?f' (t ! i) = ?f i"
   proof(safe)
     fix i
     assume "i < length t"
     then have "t ! i \<in> set t" "i < length t"
       by auto
     moreover
     have "t ! eq_idx_for_lvar t x\<^sub>i \<in> set t" "eq_idx_for_lvar t x\<^sub>i < length t"
       using eq_for_lvar[of x\<^sub>i t] \<open>x\<^sub>i \<in> lvars t\<close> eq_idx_for_lvar[of x\<^sub>i t]
       by (auto simp add: eq_for_lvar_def)
     ultimately
     have "lhs (t ! i) = lhs (t ! eq_idx_for_lvar t x\<^sub>i) \<Longrightarrow> t ! i = t ! (eq_idx_for_lvar t x\<^sub>i)" "distinct t"
       using \<open>\<triangle> t\<close>
       unfolding normalized_tableau_def
       by (auto simp add: distinct_map inj_on_def)
     then have "lhs (t ! i) = lhs (t ! eq_idx_for_lvar t x\<^sub>i) \<Longrightarrow> i = eq_idx_for_lvar t x\<^sub>i"
       using \<open>i < length t\<close> \<open>eq_idx_for_lvar t x\<^sub>i < length t\<close>
       by (auto simp add: distinct_conv_nth)
     then show "?f' (t ! i) = ?f i"
       by (auto simp add: eq_for_lvar_def)
   qed
   then show "pivot_tableau' x\<^sub>i x\<^sub>j t = pivot_tableau x\<^sub>i x\<^sub>j t"
     unfolding pivot_tableau'_def pivot_tableau_def
     unfolding Let_def
     by (auto simp add: map_reindex)
 qed
 
 lemma pivot'pivot: fixes s :: "('i,'a::lrv)state"
   assumes "\<triangle> (\<T> s)" "x\<^sub>i \<in> lvars (\<T> s)"
   shows "pivot' x\<^sub>i x\<^sub>j s = pivot x\<^sub>i x\<^sub>j s"
   using pivot_tableau'pivot_tableau[OF assms]
   unfolding pivot_def pivot'_def by auto
 end
 
 
 sublocale Pivot' < Pivot eq_idx_for_lvar pivot
 proof
   fix s::"('i,'a) state" and x\<^sub>i x\<^sub>j and v::"'a valuation"
   assume "\<triangle> (\<T> s)" "x\<^sub>i \<in> lvars (\<T> s)"
     "x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)"
   show "let s' = pivot x\<^sub>i x\<^sub>j s in \<V> s' = \<V> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s"
     unfolding pivot_def
     by (auto simp add: Let_def simp: boundsl_def boundsu_def indexl_def indexu_def)
 
   let ?t = "\<T> s"
   let ?idx = "eq_idx_for_lvar ?t x\<^sub>i"
   let ?eq = "?t ! ?idx"
   let ?eq' = "pivot_eq ?eq x\<^sub>j"
 
   have "?idx < length ?t" "lhs (?t ! ?idx) = x\<^sub>i"
     using \<open>x\<^sub>i \<in> lvars ?t\<close>
     using eq_idx_for_lvar
     by auto
 
   have "distinct (map lhs ?t)"
     using \<open>\<triangle> ?t\<close>
     unfolding normalized_tableau_def
     by simp
 
   have "x\<^sub>j \<in> rvars_eq ?eq"
     using \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)\<close>
     unfolding eq_for_lvar_def
     by simp
   then have "x\<^sub>j \<in> rvars ?t"
     using \<open>?idx < length ?t\<close>
     using in_set_conv_nth[of ?eq ?t]
     by (auto simp add: rvars_def)
   then have "x\<^sub>j \<notin> lvars ?t"
     using \<open>\<triangle> ?t\<close>
     unfolding normalized_tableau_def
     by auto
 
   have "x\<^sub>i \<notin> rvars ?t"
     using \<open>x\<^sub>i \<in> lvars ?t\<close> \<open>\<triangle> ?t\<close>
     unfolding normalized_tableau_def rvars_def
     by auto
   then have "x\<^sub>i \<notin> rvars_eq ?eq"
     unfolding rvars_def
     using \<open>?idx < length ?t\<close>
     using in_set_conv_nth[of ?eq ?t]
     by auto
 
   have "x\<^sub>i \<noteq> x\<^sub>j"
     using \<open>x\<^sub>j \<in> rvars_eq ?eq\<close>  \<open>x\<^sub>i \<notin> rvars_eq ?eq\<close>
     by auto
 
   have "?eq' = (x\<^sub>j, rhs ?eq')"
     using lhs_pivot_eq[of x\<^sub>j ?eq]
     using \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)\<close> \<open>lhs (?t ! ?idx) = x\<^sub>i\<close> \<open>x\<^sub>i \<notin> rvars_eq ?eq\<close>
     by (auto simp add: eq_for_lvar_def) (cases "?eq'", simp)+
 
   let ?I1 = "[0..<?idx]"
   let ?I2 = "[?idx + 1..<length ?t]"
   have "[0..<length ?t] = ?I1 @ [?idx] @ ?I2"
     using \<open>?idx < length ?t\<close>
     by (rule interval_3split)
   then have map_lhs_pivot:
     "map lhs (\<T> (pivot' x\<^sub>i x\<^sub>j s)) =
      map (\<lambda>idx. lhs (?t ! idx)) ?I1 @ [x\<^sub>j] @ map (\<lambda>idx. lhs (?t ! idx)) ?I2"
     using \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)\<close> \<open>lhs (?t ! ?idx) = x\<^sub>i\<close> \<open>x\<^sub>i \<notin> rvars_eq ?eq\<close>
     by (auto simp add: Let_def subst_var_eq_def eq_for_lvar_def lhs_pivot_eq pivot'_def pivot_tableau'_def)
 
   have lvars_pivot: "lvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) =
         lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
   proof-
     have "lvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) =
           {x\<^sub>j} \<union> (\<lambda>idx. lhs (?t ! idx)) ` ({0..<length?t} - {?idx})"
       using \<open>?idx < length ?t\<close> \<open>?eq' = (x\<^sub>j, rhs ?eq')\<close>
       by (cases ?eq', auto simp add: Let_def pivot'_def pivot_tableau'_def lvars_def subst_var_eq_def)+
     also have "... = {x\<^sub>j} \<union> (((\<lambda>idx. lhs (?t ! idx)) ` {0..<length?t}) - {lhs (?t ! ?idx)})"
       using \<open>?idx < length ?t\<close> \<open>distinct (map lhs ?t)\<close>
       by (auto simp add: distinct_conv_nth)
     also have "... = {x\<^sub>j} \<union> (set (map lhs ?t) - {x\<^sub>i})"
       using \<open>lhs (?t ! ?idx) = x\<^sub>i\<close>
       by (auto simp add: in_set_conv_nth rev_image_eqI) (auto simp add: image_def)
     finally show "lvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) =
       lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
       by (simp add: lvars_def)
   qed
   moreover
   have rvars_pivot: "rvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) =
         rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
   proof-
     have "rvars_eq ?eq' = {x\<^sub>i} \<union> (rvars_eq ?eq - {x\<^sub>j})"
       using rvars_pivot_eq[of x\<^sub>j ?eq]
       using \<open>lhs (?t ! ?idx) = x\<^sub>i\<close>
       using \<open>x\<^sub>j \<in> rvars_eq ?eq\<close> \<open>x\<^sub>i \<notin> rvars_eq ?eq\<close>
       by simp
 
     let ?S1 = "rvars_eq ?eq'"
     let ?S2 = "\<Union>idx\<in>({0..<length ?t} - {?idx}).
                   rvars_eq (subst_var_eq x\<^sub>j (rhs ?eq') (?t ! idx))"
 
     have "rvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) = ?S1 \<union> ?S2"
       unfolding pivot'_def pivot_tableau'_def rvars_def
       using \<open>?idx < length ?t\<close>
       by (auto simp add: Let_def split: if_splits)
     also have "... = {x\<^sub>i} \<union> (rvars ?t - {x\<^sub>j})" (is "?S1 \<union> ?S2 = ?rhs")
     proof
       show "?S1 \<union> ?S2 \<subseteq> ?rhs"
       proof-
         have "?S1 \<subseteq> ?rhs"
           using \<open>?idx < length ?t\<close>
           unfolding rvars_def
           using \<open>rvars_eq ?eq' = {x\<^sub>i} \<union> (rvars_eq ?eq - {x\<^sub>j})\<close>
           by (force simp add: in_set_conv_nth)
         moreover
         have "?S2 \<subseteq> ?rhs"
         proof-
           have "?S2 \<subseteq> (\<Union>idx\<in>{0..<length ?t}. (rvars_eq (?t ! idx) - {x\<^sub>j}) \<union> rvars_eq ?eq')"
             apply (rule UN_mono)
             using rvars_eq_subst_var_eq
             by auto
           also have "... \<subseteq> rvars_eq ?eq' \<union> (\<Union>idx\<in>{0..<length ?t}. rvars_eq (?t ! idx) - {x\<^sub>j})"
             by auto
           also have "... = rvars_eq ?eq' \<union> (rvars ?t - {x\<^sub>j})"
             unfolding rvars_def
             by (force simp add: in_set_conv_nth)
           finally show ?thesis
             using \<open>rvars_eq ?eq' = {x\<^sub>i} \<union> (rvars_eq ?eq - {x\<^sub>j})\<close>
             unfolding rvars_def
             using \<open>?idx < length ?t\<close>
             by auto
         qed
         ultimately
         show ?thesis
           by simp
       qed
     next
       show "?rhs \<subseteq> ?S1 \<union> ?S2"
       proof
         fix x
         assume "x \<in> ?rhs"
         show "x \<in> ?S1 \<union> ?S2"
         proof (cases "x \<in> rvars_eq ?eq'")
           case True
           then show ?thesis
             by auto
         next
           case False
           let ?S2'  = "\<Union>idx\<in>({0..<length ?t} - {?idx}).
                         (rvars_eq (?t ! idx) - {x\<^sub>j}) - rvars_eq ?eq'"
           have "x \<in> ?S2'"
             using False \<open>x \<in> ?rhs\<close>
             using \<open>rvars_eq ?eq' = {x\<^sub>i} \<union> (rvars_eq ?eq - {x\<^sub>j})\<close>
             unfolding rvars_def
             by (force simp add: in_set_conv_nth)
           moreover
           have "?S2 \<supseteq> ?S2'"
             apply (rule UN_mono)
             using rvars_eq_subst_var_eq_supset[of _ x\<^sub>j "rhs ?eq'" ]
             by auto
           ultimately
           show ?thesis
             by auto
         qed
       qed
     qed
     ultimately
     show ?thesis
       by simp
   qed
   ultimately
   show "let s' = pivot x\<^sub>i x\<^sub>j s in rvars (\<T> s') = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i} \<and> lvars (\<T> s') = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
     using pivot'pivot[where ?'i = 'i]
     using \<open>\<triangle> (\<T> s)\<close> \<open>x\<^sub>i \<in> lvars (\<T> s)\<close>
     by (simp add: Let_def)
   have "\<triangle> (\<T> (pivot' x\<^sub>i x\<^sub>j s))"
     unfolding normalized_tableau_def
   proof
     have "lvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) \<inter> rvars (\<T> (pivot' x\<^sub>i x\<^sub>j s)) = {}" (is ?g1)
       using \<open>\<triangle> (\<T> s)\<close>
       unfolding normalized_tableau_def
       using lvars_pivot rvars_pivot
       using \<open>x\<^sub>i \<noteq> x\<^sub>j\<close>
       by auto
 
     moreover have "0 \<notin> rhs ` set (\<T> (pivot' x\<^sub>i x\<^sub>j s))" (is ?g2)
     proof
       let ?eq = "eq_for_lvar (\<T> s) x\<^sub>i" 
       from eq_for_lvar[OF \<open>x\<^sub>i \<in> lvars (\<T> s)\<close>]
       have "?eq \<in> set (\<T> s)" and var: "lhs ?eq = x\<^sub>i" by auto
       have "lhs ?eq \<notin> rvars_eq ?eq" using \<open>\<triangle> (\<T> s)\<close> \<open>?eq \<in> set (\<T> s)\<close>
         using \<open>x\<^sub>i \<notin> rvars_eq (\<T> s ! eq_idx_for_lvar (\<T> s) x\<^sub>i)\<close> eq_for_lvar_def var by auto
       from vars_pivot_eq[OF \<open>x\<^sub>j \<in> rvars_eq ?eq\<close> this]
       have vars_pivot: "lhs (pivot_eq ?eq x\<^sub>j) = x\<^sub>j" "rvars_eq (pivot_eq ?eq x\<^sub>j) = {lhs (eq_for_lvar (\<T> s) x\<^sub>i)} \<union> (rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i) - {x\<^sub>j})" 
         unfolding Let_def by auto
       from vars_pivot(2) have rhs_pivot0: "rhs (pivot_eq ?eq x\<^sub>j) \<noteq> 0" using vars_zero by auto
       assume "0 \<in> rhs ` set (\<T> (pivot' x\<^sub>i x\<^sub>j s))" 
       from this[unfolded pivot'pivot[OF \<open>\<triangle> (\<T> s)\<close> \<open>x\<^sub>i \<in> lvars (\<T> s)\<close>] pivot_def]
       have "0 \<in> rhs ` set (pivot_tableau x\<^sub>i x\<^sub>j (\<T> s))" by simp
       from this[unfolded pivot_tableau_def Let_def var, unfolded var] rhs_pivot0
       obtain e where "e \<in> set (\<T> s)" "lhs e \<noteq> x\<^sub>i" and rvars_eq: "rvars_eq (subst_var_eq x\<^sub>j (rhs (pivot_eq ?eq x\<^sub>j)) e) = {}" 
         by (auto simp: vars_zero)
       from rvars_eq[unfolded subst_var_eq_def]
       have empty: "vars (subst_var x\<^sub>j (rhs (pivot_eq ?eq x\<^sub>j)) (rhs e)) = {}" by auto 
       show False
       proof (cases "x\<^sub>j \<in> vars (rhs e)")
         case False
         from empty[unfolded subst_no_effect[OF False]]
         have "rvars_eq e = {}" by auto
         hence "rhs e = 0" using zero_coeff_zero coeff_zero by auto
         with \<open>e \<in> set (\<T> s)\<close> \<open>\<triangle> (\<T> s)\<close> show False unfolding normalized_tableau_def by auto
       next
         case True
         from \<open>e \<in> set (\<T> s)\<close> have "rvars_eq e \<subseteq> rvars (\<T> s)" unfolding rvars_def by auto
         hence "x\<^sub>i \<in> vars (rhs (pivot_eq ?eq x\<^sub>j)) - rvars_eq e" 
           unfolding vars_pivot(2) var 
           using \<open>\<triangle> (\<T> s)\<close>[unfolded normalized_tableau_def] \<open>x\<^sub>i \<in> lvars (\<T> s)\<close> by auto
         from subst_with_effect[OF True this] rvars_eq
         show ?thesis by (simp add: subst_var_eq_def)
       qed
     qed
 
     ultimately show "?g1 \<and> ?g2" ..
 
     show "distinct (map lhs (\<T> (pivot' x\<^sub>i x\<^sub>j s)))"
       using map_parametrize_idx[of lhs ?t]
       using map_lhs_pivot
       using \<open>distinct (map lhs ?t)\<close>
       using interval_3split[of ?idx "length ?t"] \<open>?idx < length ?t\<close>
       using \<open>x\<^sub>j \<notin> lvars ?t\<close>
       unfolding lvars_def
       by auto
   qed
   moreover
   have "v \<Turnstile>\<^sub>t ?t = v \<Turnstile>\<^sub>t \<T> (pivot' x\<^sub>i x\<^sub>j s)"
     unfolding satisfies_tableau_def
   proof
     assume "\<forall>e\<in>set (?t). v \<Turnstile>\<^sub>e e"
     show "\<forall>e\<in>set (\<T> (pivot' x\<^sub>i x\<^sub>j s)). v \<Turnstile>\<^sub>e e"
     proof-
       have "v \<Turnstile>\<^sub>e ?eq'"
         using \<open>x\<^sub>i \<notin> rvars_eq ?eq\<close>
         using \<open>?idx < length ?t\<close> \<open>\<forall>e\<in>set (?t). v \<Turnstile>\<^sub>e e\<close>
         using \<open>x\<^sub>j \<in> rvars_eq ?eq\<close> \<open>x\<^sub>i \<in> lvars ?t\<close>
         by (simp add: equiv_pivot_eq eq_idx_for_lvar)
       moreover
       {
         fix idx
         assume "idx < length ?t" "idx \<noteq> ?idx"
 
         have "v \<Turnstile>\<^sub>e subst_var_eq x\<^sub>j (rhs ?eq') (?t ! idx)"
           using \<open>?eq' = (x\<^sub>j, rhs ?eq')\<close>
           using \<open>v \<Turnstile>\<^sub>e ?eq'\<close> \<open>idx < length ?t\<close> \<open>\<forall>e\<in>set (?t). v \<Turnstile>\<^sub>e e\<close>
           using equiv_subst_var_eq[of v x\<^sub>j "rhs ?eq'" "?t ! idx"]
           by auto
       }
       ultimately
       show ?thesis
         by (auto simp add: pivot'_def pivot_tableau'_def Let_def)
     qed
   next
     assume "\<forall>e\<in>set (\<T> (pivot' x\<^sub>i x\<^sub>j s)). v \<Turnstile>\<^sub>e e"
     then have "v \<Turnstile>\<^sub>e ?eq'"
       "\<And> idx. \<lbrakk>idx < length ?t; idx \<noteq> ?idx \<rbrakk> \<Longrightarrow> v \<Turnstile>\<^sub>e subst_var_eq x\<^sub>j (rhs ?eq') (?t ! idx)"
       using \<open>?idx < length ?t\<close>
       unfolding pivot'_def pivot_tableau'_def
       by (auto simp add: Let_def)
 
     show "\<forall>e\<in>set (\<T> s). v \<Turnstile>\<^sub>e e"
     proof-
       {
         fix idx
         assume "idx < length ?t"
         have "v \<Turnstile>\<^sub>e (?t ! idx)"
         proof (cases "idx = ?idx")
           case True
           then show ?thesis
             using \<open>v \<Turnstile>\<^sub>e ?eq'\<close>
             using \<open>x\<^sub>j \<in> rvars_eq ?eq\<close> \<open>x\<^sub>i \<in> lvars ?t\<close> \<open>x\<^sub>i \<notin> rvars_eq ?eq\<close>
             by (simp add: eq_idx_for_lvar equiv_pivot_eq)
         next
           case False
           then show ?thesis
             using \<open>idx < length ?t\<close>
             using \<open>\<lbrakk>idx < length ?t; idx \<noteq> ?idx \<rbrakk> \<Longrightarrow> v \<Turnstile>\<^sub>e subst_var_eq x\<^sub>j (rhs ?eq') (?t ! idx)\<close>
             using \<open>v \<Turnstile>\<^sub>e ?eq'\<close> \<open>?eq' = (x\<^sub>j, rhs ?eq')\<close>
             using equiv_subst_var_eq[of v x\<^sub>j "rhs ?eq'" "?t ! idx"]
             by auto
         qed
       }
       then show ?thesis
         by (force simp add: in_set_conv_nth)
     qed
   qed
   ultimately
   show "let s' = pivot x\<^sub>i x\<^sub>j s in v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> s' \<and> \<triangle> (\<T> s')"
     using pivot'pivot[where ?'i = 'i]
     using \<open>\<triangle> (\<T> s)\<close> \<open>x\<^sub>i \<in> lvars (\<T> s)\<close>
     by (simp add: Let_def)
 qed
 
 
 subsection\<open>Check implementation\<close>
 
 text\<open>The \<open>check\<close> function is called when all rhs variables are
 in bounds, and it checks if there is a lhs variable that is not. If
 there is no such variable, then satisfiability is detected and \<open>check\<close> succeeds. If there is a lhs variable \<open>x\<^sub>i\<close> out of its
 bounds, a rhs variable \<open>x\<^sub>j\<close> is sought which allows pivoting
 with \<open>x\<^sub>i\<close> and updating \<open>x\<^sub>i\<close> to its violated bound. If
 \<open>x\<^sub>i\<close> is under its lower bound it must be increased, and if
 \<open>x\<^sub>j\<close> has a positive coefficient it must be increased so it
 must be under its upper bound and if it has a negative coefficient it
 must be decreased so it must be above its lower bound. The case when
 \<open>x\<^sub>i\<close> is above its upper bound is symmetric (avoiding
 symmetries is discussed in Section \ref{sec:symmetries}). If there is
 no such \<open>x\<^sub>j\<close>, unsatisfiability is detected and \<open>check\<close>
 fails. The procedure is recursively repeated, until it either succeeds
 or fails. To ensure termination, variables \<open>x\<^sub>i\<close> and \<open>x\<^sub>j\<close> must be chosen with respect to a fixed variable ordering. For
 choosing these variables auxiliary functions \<open>min_lvar_not_in_bounds\<close>, \<open>min_rvar_inc\<close> and \<open>min_rvar_dec\<close> are specified (each in its own locale). For, example:
 \<close>
 
 locale MinLVarNotInBounds = fixes min_lvar_not_in_bounds::"('i,'a::lrv) state \<Rightarrow> var option"
   assumes
 
 min_lvar_not_in_bounds_None: "min_lvar_not_in_bounds s = None \<longrightarrow> (\<forall>x\<in>lvars (\<T> s). in_bounds x \<langle>\<V> s\<rangle> (\<B> s))" and
 
 min_lvar_not_in_bounds_Some': "min_lvar_not_in_bounds s = Some x\<^sub>i \<longrightarrow> x\<^sub>i\<in>lvars (\<T> s) \<and> \<not>in_bounds x\<^sub>i \<langle>\<V> s\<rangle> (\<B> s)
     \<and> (\<forall>x\<in>lvars (\<T> s). x < x\<^sub>i \<longrightarrow> in_bounds x \<langle>\<V> s\<rangle> (\<B> s))"
 
 begin
 lemma min_lvar_not_in_bounds_None':
   "min_lvar_not_in_bounds s = None \<longrightarrow> (\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>b \<B> s \<parallel> lvars (\<T> s))"
   unfolding satisfies_bounds_set.simps
   by (rule min_lvar_not_in_bounds_None)
 
 lemma min_lvar_not_in_bounds_lvars:"min_lvar_not_in_bounds s = Some x\<^sub>i \<longrightarrow> x\<^sub>i \<in> lvars (\<T> s)"
   using min_lvar_not_in_bounds_Some'
   by simp
 
 lemma min_lvar_not_in_bounds_Some: "min_lvar_not_in_bounds s = Some x\<^sub>i \<longrightarrow> \<not> in_bounds x\<^sub>i \<langle>\<V> s\<rangle> (\<B> s)"
   using min_lvar_not_in_bounds_Some'
   by simp
 
 
 lemma min_lvar_not_in_bounds_Some_min: "min_lvar_not_in_bounds s = Some x\<^sub>i \<longrightarrow>  (\<forall> x \<in> lvars (\<T> s). x < x\<^sub>i \<longrightarrow> in_bounds x \<langle>\<V> s\<rangle> (\<B> s))"
   using min_lvar_not_in_bounds_Some'
   by simp
 
 end
 
 
 abbreviation reasable_var where
   "reasable_var dir x eq s \<equiv>
    (coeff (rhs eq) x > 0 \<and> \<lhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (UB dir s x)) \<or>
    (coeff (rhs eq) x < 0 \<and> \<rhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (LB dir s x))"
 
 locale MinRVarsEq =
   fixes min_rvar_incdec_eq :: "('i,'a) Direction \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> eq \<Rightarrow> 'i list + var"
   assumes min_rvar_incdec_eq_None:
     "min_rvar_incdec_eq dir s eq = Inl is \<Longrightarrow>
       (\<forall> x \<in> rvars_eq eq. \<not> reasable_var dir x eq s) \<and>
       (set is = {LI dir s (lhs eq)} \<union> {LI dir s x | x. x \<in> rvars_eq eq \<and> coeff (rhs eq) x < 0}
           \<union> {UI dir s x | x. x \<in> rvars_eq eq \<and> coeff (rhs eq) x > 0}) \<and>
       ((dir = Positive \<or> dir = Negative) \<longrightarrow> LI dir s (lhs eq) \<in> indices_state s \<longrightarrow> set is \<subseteq> indices_state s)"
   assumes min_rvar_incdec_eq_Some_rvars:
     "min_rvar_incdec_eq dir s eq = Inr x\<^sub>j \<Longrightarrow> x\<^sub>j \<in> rvars_eq eq"
   assumes min_rvar_incdec_eq_Some_incdec:
     "min_rvar_incdec_eq dir s eq = Inr x\<^sub>j \<Longrightarrow> reasable_var dir x\<^sub>j eq s"
   assumes min_rvar_incdec_eq_Some_min:
     "min_rvar_incdec_eq dir s eq = Inr x\<^sub>j \<Longrightarrow>
     (\<forall> x \<in> rvars_eq eq. x < x\<^sub>j \<longrightarrow> \<not> reasable_var dir x eq s)"
 begin
 lemma min_rvar_incdec_eq_None':
   assumes *: "dir = Positive \<or> dir = Negative"
     and min: "min_rvar_incdec_eq dir s eq = Inl is"
     and sub: "I = set is"
     and Iv: "(I,v) \<Turnstile>\<^sub>i\<^sub>b \<B>\<I> s"
   shows "le (lt dir) ((rhs eq) \<lbrace>v\<rbrace>) ((rhs eq) \<lbrace>\<langle>\<V> s\<rangle>\<rbrace>)"
 proof -
   have "\<forall> x \<in> rvars_eq eq. \<not> reasable_var dir x eq s"
     using min
     using min_rvar_incdec_eq_None
     by simp
 
   have "\<forall> x \<in> rvars_eq eq. (0 < coeff (rhs eq) x \<longrightarrow> le (lt dir) 0 (\<langle>\<V> s\<rangle> x - v x)) \<and> (coeff (rhs eq) x < 0 \<longrightarrow> le (lt dir) (\<langle>\<V> s\<rangle> x - v x) 0)"
   proof (safe)
     fix x
     assume x: "x \<in> rvars_eq eq" "0 < coeff (rhs eq) x" "0 \<noteq> \<langle>\<V> s\<rangle> x - v x"
     then have "\<not> (\<lhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (UB dir s x))"
       using \<open>\<forall> x \<in> rvars_eq eq. \<not> reasable_var dir x eq s\<close>
       by auto
     then have "\<unrhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (UB dir s x)"
       using *
       by (cases "UB dir s x") (auto simp add: bound_compare_defs)
     moreover
     from min_rvar_incdec_eq_None[OF min] x sub have "UI dir s x \<in> I" by auto
     from Iv * this
     have "\<unlhd>\<^sub>u\<^sub>b (lt dir) (v x) (UB dir s x)"
       unfolding satisfies_bounds_index.simps
       by (cases "UB dir s x", auto simp: indexl_def indexu_def boundsl_def boundsu_def bound_compare'_defs)
         (fastforce)+
     ultimately
     have "le (lt dir) (v x) (\<langle>\<V> s\<rangle> x)"
       using *
       by (cases "UB dir s x") (auto simp add: bound_compare_defs)
     then show "lt dir 0 (\<langle>\<V> s\<rangle> x - v x)"
       using \<open>0 \<noteq> \<langle>\<V> s\<rangle> x - v x\<close> *
       using minus_gt[of "v x" "\<langle>\<V> s\<rangle> x"] minus_lt[of "\<langle>\<V> s\<rangle> x" "v x"]
-      by auto
+      by (auto simp del: Simplex.bounds_lg)
   next
     fix x
     assume x: "x \<in> rvars_eq eq" "0 > coeff (rhs eq) x" "\<langle>\<V> s\<rangle> x - v x \<noteq> 0"
     then have "\<not> (\<rhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (LB dir s x))"
       using \<open>\<forall> x \<in> rvars_eq eq. \<not> reasable_var dir x eq s\<close>
       by auto
     then have "\<unlhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (LB dir s x)"
       using *
       by (cases "LB dir s x") (auto simp add: bound_compare_defs)
     moreover
     from min_rvar_incdec_eq_None[OF min] x sub have "LI dir s x \<in> I" by auto
     from Iv * this
     have "\<unrhd>\<^sub>l\<^sub>b (lt dir) (v x) (LB dir s x)"
       unfolding satisfies_bounds_index.simps
       by (cases "LB dir s x", auto simp: indexl_def indexu_def boundsl_def boundsu_def bound_compare'_defs)
         (fastforce)+
 
     ultimately
     have "le (lt dir) (\<langle>\<V> s\<rangle> x) (v x)"
       using *
       by (cases "LB dir s x") (auto simp add: bound_compare_defs)
     then show "lt dir (\<langle>\<V> s\<rangle> x - v x) 0"
       using \<open>\<langle>\<V> s\<rangle> x - v x \<noteq> 0\<close> *
       using minus_lt[of "\<langle>\<V> s\<rangle> x" "v x"] minus_gt[of "v x" "\<langle>\<V> s\<rangle> x"]
-      by auto
+      by (auto simp del: Simplex.bounds_lg)
   qed
   then have "le (lt dir) 0 (rhs eq \<lbrace> \<lambda> x. \<langle>\<V> s\<rangle> x - v x\<rbrace>)"
     using *
     apply auto
     using valuate_nonneg[of "rhs eq" "\<lambda>x. \<langle>\<V> s\<rangle> x - v x"]
-     apply force
+     apply (force simp del: Simplex.bounds_lg)
     using valuate_nonpos[of "rhs eq" "\<lambda>x. \<langle>\<V> s\<rangle> x - v x"]
-    apply force
+    apply (force simp del: Simplex.bounds_lg)
     done
   then show "le (lt dir) rhs eq \<lbrace> v \<rbrace> rhs eq \<lbrace> \<langle>\<V> s\<rangle> \<rbrace>"
     using \<open>dir = Positive \<or> dir = Negative\<close>
     using minus_gt[of "rhs eq \<lbrace> v \<rbrace>" "rhs eq \<lbrace> \<langle>\<V> s\<rangle> \<rbrace>"]
-    by (auto simp add: valuate_diff[THEN sym])
+    by (auto simp add: valuate_diff[THEN sym] simp del: Simplex.bounds_lg)
 qed
 end
 
 
 locale MinRVars = EqForLVar + MinRVarsEq min_rvar_incdec_eq
   for min_rvar_incdec_eq :: "('i, 'a :: lrv) Direction \<Rightarrow> _"
 begin
 abbreviation min_rvar_incdec :: "('i,'a) Direction \<Rightarrow> ('i,'a) state \<Rightarrow> var \<Rightarrow> 'i list + var" where
   "min_rvar_incdec dir s x\<^sub>i \<equiv> min_rvar_incdec_eq dir s (eq_for_lvar (\<T> s) x\<^sub>i)"
 end
 
 
 locale MinVars = MinLVarNotInBounds min_lvar_not_in_bounds + MinRVars eq_idx_for_lvar min_rvar_incdec_eq
   for min_lvar_not_in_bounds :: "('i,'a::lrv) state \<Rightarrow> _" and
     eq_idx_for_lvar and
     min_rvar_incdec_eq :: "('i, 'a :: lrv) Direction \<Rightarrow> _"
 
 locale PivotUpdateMinVars =
   PivotAndUpdate eq_idx_for_lvar pivot_and_update +
   MinVars min_lvar_not_in_bounds eq_idx_for_lvar min_rvar_incdec_eq for
   eq_idx_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> nat" and
   min_lvar_not_in_bounds :: "('i,'a::lrv) state \<Rightarrow> var option" and
   min_rvar_incdec_eq :: "('i,'a) Direction \<Rightarrow> ('i,'a) state \<Rightarrow> eq \<Rightarrow> 'i list + var" and
   pivot_and_update :: "var \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
 begin
 
 
 definition check' where
   "check' dir x\<^sub>i s \<equiv>
      let l\<^sub>i = the (LB dir s x\<^sub>i);
          x\<^sub>j' = min_rvar_incdec dir s x\<^sub>i
      in case x\<^sub>j' of
            Inl I \<Rightarrow> set_unsat I s
          | Inr x\<^sub>j \<Rightarrow> pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s"
 
 lemma check'_cases:
   assumes "\<And> I. \<lbrakk>min_rvar_incdec dir s x\<^sub>i = Inl I; check' dir x\<^sub>i s = set_unsat I s\<rbrakk> \<Longrightarrow> P (set_unsat I s)"
   assumes "\<And> x\<^sub>j l\<^sub>i. \<lbrakk>min_rvar_incdec dir s x\<^sub>i = Inr x\<^sub>j;
            l\<^sub>i = the (LB dir s x\<^sub>i);
            check' dir x\<^sub>i s = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s\<rbrakk> \<Longrightarrow>
         P (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s)"
   shows "P (check' dir x\<^sub>i s)"
   using assms
   unfolding check'_def
   by (cases "min_rvar_incdec dir s x\<^sub>i", auto)
 
 partial_function (tailrec) check where
   "check s =
     (if \<U> s then s
      else let x\<^sub>i' = min_lvar_not_in_bounds s
           in case x\<^sub>i' of
                None \<Rightarrow> s
              | Some x\<^sub>i \<Rightarrow> let dir = if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive
                                     else Negative
                           in check (check' dir x\<^sub>i s))"
 declare check.simps[code]
 
 inductive check_dom where
   step: "\<lbrakk>\<And>x\<^sub>i. \<lbrakk>\<not> \<U> s; Some x\<^sub>i = min_lvar_not_in_bounds s; \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i\<rbrakk>
      \<Longrightarrow> check_dom (check' Positive x\<^sub>i s);
   \<And>x\<^sub>i. \<lbrakk>\<not> \<U> s; Some x\<^sub>i = min_lvar_not_in_bounds s; \<not> \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i\<rbrakk>
      \<Longrightarrow> check_dom (check' Negative x\<^sub>i s)\<rbrakk>
 \<Longrightarrow> check_dom s"
 
 
 
 text\<open>
 The definition of \<open>check\<close> can be given by:
 
 @{text[display]
 "check s \<equiv> if \<U> s then s
             else let x\<^sub>i' = min_lvar_not_in_bounds s in
                  case x\<^sub>i' of  None \<Rightarrow> s
                            | Some x\<^sub>i \<Rightarrow> if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then check (check_inc x\<^sub>i s)
                                            else check (check_dec x\<^sub>i s)"
 }
 
 @{text[display]
 "check_inc x\<^sub>i s \<equiv> let l\<^sub>i = the (\<B>\<^sub>l s x\<^sub>i); x\<^sub>j' = min_rvar_inc s x\<^sub>i in
    case x\<^sub>j' of None \<Rightarrow> s \<lparr> \<U> := True \<rparr> | Some x\<^sub>j \<Rightarrow> pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s"
 }
 
 The definition of \<open>check_dec\<close> is analogous. It is shown (mainly
 by induction) that this definition satisfies the \<open>check\<close>
 specification. Note that this definition uses general recursion, so
 its termination is non-trivial. It has been shown that it terminates
 for all states satisfying the check preconditions. The proof is based
 on the proof outline given in \cite{simplex-rad}. It is very
 technically involved, but conceptually uninteresting so we do not
 discuss it in more details.\<close>
 
 lemma pivotandupdate_check_precond:
   assumes
     "dir = (if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive else Negative)"
     "min_lvar_not_in_bounds s = Some x\<^sub>i"
     "min_rvar_incdec dir s x\<^sub>i = Inr x\<^sub>j"
     "l\<^sub>i = the (LB dir s x\<^sub>i)"
     "\<nabla> s" "\<triangle> (\<T> s)" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" " \<diamond> s"
   shows "\<triangle> (\<T> (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s)) \<and> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s) \<and> \<diamond> (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s) \<and> \<nabla> (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s)"
 proof-
   have "\<B>\<^sub>l s x\<^sub>i = Some l\<^sub>i \<or> \<B>\<^sub>u s x\<^sub>i = Some l\<^sub>i"
     using \<open>l\<^sub>i = the (LB dir s x\<^sub>i)\<close> \<open>dir = (if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive else Negative)\<close>
     using \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close> min_lvar_not_in_bounds_Some[of s x\<^sub>i]
     using \<open>\<diamond> s\<close>
     by (case_tac[!] "\<B>\<^sub>l s x\<^sub>i", case_tac[!] "\<B>\<^sub>u s x\<^sub>i") (auto simp add: bounds_consistent_def bound_compare_defs)
   then show ?thesis
     using assms
     using pivotandupdate_tableau_normalized[of s x\<^sub>i x\<^sub>j l\<^sub>i]
     using pivotandupdate_nolhs[of s x\<^sub>i x\<^sub>j l\<^sub>i]
     using pivotandupdate_bounds_consistent[of s x\<^sub>i x\<^sub>j l\<^sub>i]
     using pivotandupdate_tableau_valuated[of s x\<^sub>i x\<^sub>j l\<^sub>i]
     by (auto simp add: min_lvar_not_in_bounds_lvars  min_rvar_incdec_eq_Some_rvars)
 qed
 
 
 (* -------------------------------------------------------------------------- *)
 (* Termination *)
 (* -------------------------------------------------------------------------- *)
 
 abbreviation gt_state' where
   "gt_state' dir s s' x\<^sub>i x\<^sub>j l\<^sub>i \<equiv>
   min_lvar_not_in_bounds s = Some x\<^sub>i \<and>
   l\<^sub>i = the (LB dir s x\<^sub>i) \<and>
   min_rvar_incdec dir s x\<^sub>i = Inr x\<^sub>j \<and>
   s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s"
 
 definition gt_state :: "('i,'a) state \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<succ>\<^sub>x" 100) where
   "s \<succ>\<^sub>x s' \<equiv>
    \<exists> x\<^sub>i x\<^sub>j l\<^sub>i.
      let dir = if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive else Negative in
      gt_state' dir s s' x\<^sub>i x\<^sub>j l\<^sub>i"
 
 abbreviation succ :: "('i,'a) state \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<succ>" 100) where
   "s \<succ> s' \<equiv> \<triangle> (\<T> s) \<and> \<diamond> s \<and> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s \<and> \<nabla> s \<and> s \<succ>\<^sub>x s' \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s"
 
 abbreviation succ_rel :: "('i,'a) state rel" where
   "succ_rel \<equiv> {(s, s'). s \<succ> s'}"
 
 abbreviation succ_rel_trancl :: "('i,'a) state \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<succ>\<^sup>+" 100) where
   "s \<succ>\<^sup>+ s' \<equiv> (s, s') \<in> succ_rel\<^sup>+"
 
 abbreviation succ_rel_rtrancl :: "('i,'a) state \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<succ>\<^sup>*" 100) where
   "s \<succ>\<^sup>* s' \<equiv> (s, s') \<in> succ_rel\<^sup>*"
 
 lemma succ_vars:
   assumes "s \<succ> s'"
   obtains x\<^sub>i x\<^sub>j where
     "x\<^sub>i \<in> lvars (\<T> s)"
     "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i" "x\<^sub>j \<in> rvars (\<T> s)"
     "lvars (\<T> s') = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
     "rvars (\<T> s') = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
 proof-
   from assms
   obtain x\<^sub>i x\<^sub>j c
     where *:
       "\<triangle> (\<T> s)" "\<nabla> s"
       "min_lvar_not_in_bounds s = Some x\<^sub>i"
       "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
       "s' = pivot_and_update x\<^sub>i x\<^sub>j c s"
     unfolding gt_state_def
     by (auto split: if_splits)
   then have
     "x\<^sub>i \<in> lvars (\<T> s)"
     "x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)"
     "lvars (\<T> s') =  lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
     "rvars (\<T> s') = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using pivotandupdate_rvars[of s x\<^sub>i x\<^sub>j]
     using pivotandupdate_lvars[of s x\<^sub>i x\<^sub>j]
     by auto
   moreover
   have "x\<^sub>j \<in> rvars (\<T> s)"
     using \<open>x\<^sub>i \<in> lvars (\<T> s)\<close>
     using \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)\<close>
     using eq_for_lvar[of x\<^sub>i "\<T> s"]
     unfolding rvars_def
     by auto
   ultimately
   have
     "x\<^sub>i \<in> lvars (\<T> s)"
     "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i" "x\<^sub>j \<in> rvars (\<T> s)"
     "lvars (\<T> s') = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
     "rvars (\<T> s') = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
     by auto
   then show thesis
     ..
 qed
 
 lemma succ_vars_id:
   assumes "s \<succ> s'"
   shows "lvars (\<T> s) \<union> rvars (\<T> s) =
          lvars (\<T> s') \<union> rvars (\<T> s')"
   using assms
   by (rule succ_vars) auto
 
 lemma succ_inv:
   assumes "s \<succ> s'"
   shows "\<triangle> (\<T> s')" "\<nabla> s'" "\<diamond> s'" "\<B>\<^sub>i s = \<B>\<^sub>i s'"
     "(v::'a valuation) \<Turnstile>\<^sub>t (\<T> s) \<longleftrightarrow> v \<Turnstile>\<^sub>t (\<T> s')"
 proof-
   from assms obtain x\<^sub>i x\<^sub>j c
     where *:
       "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
       "min_lvar_not_in_bounds s = Some x\<^sub>i"
       "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
       "s' = pivot_and_update x\<^sub>i x\<^sub>j c s"
     unfolding gt_state_def
     by (auto split: if_splits)
   then show  "\<triangle> (\<T> s')" "\<nabla> s'" "\<diamond> s'" "\<B>\<^sub>i s = \<B>\<^sub>i s'"
     "(v::'a valuation) \<Turnstile>\<^sub>t (\<T> s) \<longleftrightarrow> v \<Turnstile>\<^sub>t (\<T> s')"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using pivotandupdate_tableau_normalized[of s x\<^sub>i x\<^sub>j c]
     using pivotandupdate_bounds_consistent[of s x\<^sub>i x\<^sub>j c]
     using pivotandupdate_bounds_id[of s x\<^sub>i x\<^sub>j c]
     using pivotandupdate_tableau_equiv
     using pivotandupdate_tableau_valuated
     by auto
 qed
 
 lemma succ_rvar_valuation_id:
   assumes "s \<succ> s'" "x \<in> rvars (\<T> s)" "x \<in> rvars (\<T> s')"
   shows "\<langle>\<V> s\<rangle> x = \<langle>\<V> s'\<rangle> x"
 proof-
   from assms obtain x\<^sub>i x\<^sub>j c
     where *:
       "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
       "min_lvar_not_in_bounds s = Some x\<^sub>i"
       "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
       "s' = pivot_and_update x\<^sub>i x\<^sub>j c s"
     unfolding gt_state_def
     by (auto split: if_splits)
   then show ?thesis
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using \<open>x \<in> rvars (\<T> s)\<close> \<open>x \<in> rvars (\<T> s')\<close>
     using pivotandupdate_rvars[of s x\<^sub>i x\<^sub>j c]
     using pivotandupdate_valuation_xi[of s x\<^sub>i x\<^sub>j c]
     using pivotandupdate_valuation_other_nolhs[of s x\<^sub>i x\<^sub>j x c]
     by (force simp add: normalized_tableau_def map2fun_def)
 qed
 
 lemma succ_min_lvar_not_in_bounds:
   assumes "s \<succ> s'"
     "xr \<in> lvars (\<T> s)" "xr \<in> rvars (\<T> s')"
   shows "\<not> in_bounds xr (\<langle>\<V> s\<rangle>) (\<B> s)"
     "\<forall> x \<in> lvars (\<T> s). x < xr \<longrightarrow> in_bounds x (\<langle>\<V> s\<rangle>) (\<B> s)"
 proof-
   from assms obtain x\<^sub>i x\<^sub>j c
     where *:
       "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
       "min_lvar_not_in_bounds s = Some x\<^sub>i"
       "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
       "s' = pivot_and_update x\<^sub>i x\<^sub>j c s"
     unfolding gt_state_def
     by (auto split: if_splits)
   then have "x\<^sub>i = xr"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using \<open>xr \<in> lvars (\<T> s)\<close> \<open>xr \<in> rvars (\<T> s')\<close>
     using pivotandupdate_rvars
     by (auto simp add: normalized_tableau_def)
   then show "\<not> in_bounds xr (\<langle>\<V> s\<rangle>) (\<B> s)"
     "\<forall> x \<in> lvars (\<T> s). x < xr \<longrightarrow> in_bounds x (\<langle>\<V> s\<rangle>) (\<B> s)"
     using \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close>
     using min_lvar_not_in_bounds_Some min_lvar_not_in_bounds_Some_min
     by simp_all
 qed
 
 lemma succ_min_rvar:
   assumes "s \<succ> s'"
     "xs \<in> lvars (\<T> s)" "xs \<in> rvars (\<T> s')"
     "xr \<in> rvars (\<T> s)" "xr \<in> lvars (\<T> s')"
     "eq = eq_for_lvar (\<T> s) xs" and
     dir: "dir = Positive \<or> dir = Negative"
   shows
     "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> xs) (LB dir s xs) \<longrightarrow>
              reasable_var dir xr eq s \<and> (\<forall> x \<in> rvars_eq eq. x < xr \<longrightarrow> \<not> reasable_var dir x eq s)"
 proof-
   from assms(1) obtain x\<^sub>i x\<^sub>j c
     where"\<triangle> (\<T> s) \<and> \<nabla> s \<and> \<diamond> s \<and> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
       "gt_state' (if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive else Negative) s s' x\<^sub>i x\<^sub>j c"
     by (auto simp add: gt_state_def Let_def)
   then have
     "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
     "min_lvar_not_in_bounds s = Some x\<^sub>i"
     "s' = pivot_and_update x\<^sub>i x\<^sub>j c s" and
     *: "(\<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i \<and> min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j) \<or>
         (\<not> \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i \<and> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j)"
     by (auto split: if_splits)
 
   then have "xr = x\<^sub>j" "xs = x\<^sub>i"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using \<open>xr \<in> rvars (\<T> s)\<close> \<open>xr \<in> lvars (\<T> s')\<close>
     using \<open>xs \<in> lvars (\<T> s)\<close> \<open>xs \<in> rvars (\<T> s')\<close>
     using pivotandupdate_lvars pivotandupdate_rvars
     by (auto simp add: normalized_tableau_def)
   show "\<not> (\<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> xs) (LB dir s xs)) \<longrightarrow>
             reasable_var dir xr eq s \<and> (\<forall> x \<in> rvars_eq eq. x < xr \<longrightarrow> \<not> reasable_var dir x eq s)"
   proof
     assume "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> xs) (LB dir s xs)"
     then have "\<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> xs) (LB dir s xs)"
       using dir
       by (cases "LB dir s xs") (auto simp add: bound_compare_defs)
     moreover
     then have "\<not> (\<rhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> xs) (UB dir s xs))"
       using \<open>\<diamond> s\<close> dir
       using bounds_consistent_gt_ub bounds_consistent_lt_lb
       by (force simp add:  bound_compare''_defs)
     ultimately
     have "min_rvar_incdec dir s xs = Inr xr"
       using * \<open>xr = x\<^sub>j\<close> \<open>xs = x\<^sub>i\<close> dir
       by (auto simp add: bound_compare''_defs)
     then show "reasable_var dir xr eq s \<and> (\<forall> x \<in> rvars_eq eq. x < xr \<longrightarrow> \<not> reasable_var dir x eq s)"
       using \<open>eq = eq_for_lvar (\<T> s) xs\<close>
       using min_rvar_incdec_eq_Some_min[of dir s eq xr]
       using min_rvar_incdec_eq_Some_incdec[of dir s eq xr]
       by simp
   qed
 qed
 
 lemma succ_set_on_bound:
   assumes
     "s \<succ> s'" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>i \<in> rvars (\<T> s')" and
     dir: "dir = Positive \<or> dir = Negative"
   shows
     "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i) \<longrightarrow> \<langle>\<V> s'\<rangle> x\<^sub>i = the (LB dir s x\<^sub>i)"
     "\<langle>\<V> s'\<rangle> x\<^sub>i = the (\<B>\<^sub>l s x\<^sub>i) \<or> \<langle>\<V> s'\<rangle> x\<^sub>i = the (\<B>\<^sub>u s x\<^sub>i)"
 proof-
   from assms(1) obtain x\<^sub>i' x\<^sub>j c
     where"\<triangle> (\<T> s) \<and> \<nabla> s \<and> \<diamond> s \<and> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
       "gt_state' (if \<langle>\<V> s\<rangle> x\<^sub>i' <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i' then Positive else Negative) s s' x\<^sub>i' x\<^sub>j c"
     by (auto simp add: gt_state_def Let_def)
   then have
     "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
     "min_lvar_not_in_bounds s = Some x\<^sub>i'"
     "s' = pivot_and_update x\<^sub>i' x\<^sub>j c s" and
     *: "(\<langle>\<V> s\<rangle> x\<^sub>i' <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i' \<and> c = the (\<B>\<^sub>l s x\<^sub>i') \<and> min_rvar_incdec Positive s x\<^sub>i' = Inr x\<^sub>j) \<or>
         (\<not> \<langle>\<V> s\<rangle> x\<^sub>i' <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i' \<and> c = the (\<B>\<^sub>u s x\<^sub>i') \<and> min_rvar_incdec Negative s x\<^sub>i' = Inr x\<^sub>j)"
     by (auto split: if_splits)
   then have "x\<^sub>i = x\<^sub>i'" "x\<^sub>i' \<in> lvars (\<T> s)"
     "x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i')"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i']
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i'" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i'" x\<^sub>j]
     using \<open>x\<^sub>i \<in> lvars (\<T> s)\<close> \<open>x\<^sub>i \<in> rvars (\<T> s')\<close>
     using pivotandupdate_rvars
     by (auto simp add: normalized_tableau_def)
   show "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i) \<longrightarrow> \<langle>\<V> s'\<rangle> x\<^sub>i = the (LB dir s x\<^sub>i)"
   proof
     assume "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i)"
     then have "\<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i)"
       using dir
       by (cases "LB dir s x\<^sub>i") (auto simp add: bound_compare_defs)
     moreover
     then have "\<not> \<rhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (UB dir s x\<^sub>i)"
       using \<open>\<diamond> s\<close> dir
       using bounds_consistent_gt_ub bounds_consistent_lt_lb
       by (force simp add: bound_compare''_defs)
     ultimately
     show "\<langle>\<V> s'\<rangle> x\<^sub>i = the (LB dir s x\<^sub>i)"
       using * \<open>x\<^sub>i = x\<^sub>i'\<close> \<open>s' = pivot_and_update x\<^sub>i' x\<^sub>j c s\<close>
       using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close> \<open>x\<^sub>i' \<in> lvars (\<T> s)\<close>
         \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i')\<close>
       using pivotandupdate_valuation_xi[of s x\<^sub>i x\<^sub>j c] dir
       by (case_tac[!] "\<B>\<^sub>l s x\<^sub>i'", case_tac[!] "\<B>\<^sub>u s x\<^sub>i'") (auto simp add: bound_compare_defs map2fun_def)
   qed
 
   have "\<not> \<langle>\<V> s\<rangle> x\<^sub>i' <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i'  \<longrightarrow> \<langle>\<V> s\<rangle> x\<^sub>i' >\<^sub>u\<^sub>b \<B>\<^sub>u s x\<^sub>i'"
     using \<open>min_lvar_not_in_bounds s = Some x\<^sub>i'\<close>
     using min_lvar_not_in_bounds_Some[of s x\<^sub>i']
     using not_in_bounds[of x\<^sub>i' "\<langle>\<V> s\<rangle>" "\<B>\<^sub>l s" "\<B>\<^sub>u s"]
     by auto
   then show "\<langle>\<V> s'\<rangle> x\<^sub>i = the (\<B>\<^sub>l s x\<^sub>i) \<or> \<langle>\<V> s'\<rangle> x\<^sub>i = the (\<B>\<^sub>u s x\<^sub>i)"
     using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close> \<open>x\<^sub>i' \<in> lvars (\<T> s)\<close>
       \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i')\<close>
     using \<open>s' = pivot_and_update x\<^sub>i' x\<^sub>j c s\<close> \<open>x\<^sub>i = x\<^sub>i'\<close>
     using pivotandupdate_valuation_xi[of s x\<^sub>i x\<^sub>j c]
     using *
     by (case_tac[!] "\<B>\<^sub>l s x\<^sub>i'", case_tac[!] "\<B>\<^sub>u s x\<^sub>i'") (auto simp add: map2fun_def bound_compare_defs)
 qed
 
 lemma succ_rvar_valuation:
   assumes
     "s \<succ> s'" "x \<in> rvars (\<T> s')"
   shows
     "\<langle>\<V> s'\<rangle> x = \<langle>\<V> s\<rangle> x \<or> \<langle>\<V> s'\<rangle> x = the (\<B>\<^sub>l s x) \<or> \<langle>\<V> s'\<rangle> x = the (\<B>\<^sub>u s x)"
 proof-
   from assms
   obtain x\<^sub>i x\<^sub>j b where
     "\<triangle> (\<T> s)" "\<nabla> s"
     "min_lvar_not_in_bounds s = Some x\<^sub>i"
     "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
     "b = the (\<B>\<^sub>l s x\<^sub>i) \<or> b = the (\<B>\<^sub>u s x\<^sub>i)"
     "s' = pivot_and_update x\<^sub>i x\<^sub>j b s"
     unfolding gt_state_def
     by (auto simp add: Let_def split: if_splits)
   then have
     "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>i \<notin> rvars (\<T> s)"
     "x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)"
     "x\<^sub>j \<in> rvars (\<T> s)" "x\<^sub>j \<notin> lvars (\<T> s)" "x\<^sub>i \<noteq> x\<^sub>j"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using rvars_of_lvar_rvars \<open>\<triangle> (\<T> s)\<close>
     by (auto simp add: normalized_tableau_def)
   then have
     "rvars (\<T> s') = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
     "x \<in> rvars (\<T> s) \<or> x = x\<^sub>i" "x \<noteq> x\<^sub>j" "x \<noteq> x\<^sub>i \<longrightarrow> x \<notin> lvars (\<T> s)"
     using \<open>x \<in> rvars (\<T> s')\<close>
     using pivotandupdate_rvars[of s x\<^sub>i x\<^sub>j]
     using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close> \<open>s' = pivot_and_update x\<^sub>i x\<^sub>j b s\<close>
     by (auto simp add: normalized_tableau_def)
   then show ?thesis
     using pivotandupdate_valuation_xi[of s x\<^sub>i x\<^sub>j b]
     using pivotandupdate_valuation_other_nolhs[of s x\<^sub>i x\<^sub>j x b]
     using \<open>x\<^sub>i \<in> lvars (\<T> s)\<close> \<open>x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)\<close>
     using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close> \<open>s' = pivot_and_update x\<^sub>i x\<^sub>j b s\<close> \<open>b = the (\<B>\<^sub>l s x\<^sub>i) \<or> b = the (\<B>\<^sub>u s x\<^sub>i)\<close>
     by (auto simp add: map2fun_def)
 qed
 
 lemma succ_no_vars_valuation:
   assumes
     "s \<succ> s'" "x \<notin> tvars (\<T> s')"
   shows "look (\<V> s') x = look (\<V> s) x"
 proof-
   from assms
   obtain x\<^sub>i x\<^sub>j b where
     "\<triangle> (\<T> s)" "\<nabla> s"
     "min_lvar_not_in_bounds s = Some x\<^sub>i"
     "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
     "b = the (\<B>\<^sub>l s x\<^sub>i) \<or> b = the (\<B>\<^sub>u s x\<^sub>i)"
     "s' = pivot_and_update x\<^sub>i x\<^sub>j b s"
     unfolding gt_state_def
     by (auto simp add: Let_def split: if_splits)
   then have
     "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>i \<notin> rvars (\<T> s)"
     "x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)"
     "x\<^sub>j \<in> rvars (\<T> s)" "x\<^sub>j \<notin> lvars (\<T> s)" "x\<^sub>i \<noteq> x\<^sub>j"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using rvars_of_lvar_rvars \<open>\<triangle> (\<T> s)\<close>
     by (auto simp add: normalized_tableau_def)
   then show ?thesis
     using pivotandupdate_valuation_other_nolhs[of s x\<^sub>i x\<^sub>j x b]
     using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close> \<open>s' = pivot_and_update x\<^sub>i x\<^sub>j b s\<close>
     using \<open>x \<notin> tvars (\<T> s')\<close>
     using pivotandupdate_rvars[of s x\<^sub>i x\<^sub>j]
     using pivotandupdate_lvars[of s x\<^sub>i x\<^sub>j]
     by (auto simp add: map2fun_def)
 qed
 
 lemma succ_valuation_satisfies:
   assumes "s \<succ> s'" "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s"
   shows "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'"
 proof-
   from \<open>s \<succ> s'\<close>
   obtain x\<^sub>i x\<^sub>j b where
     "\<triangle> (\<T> s)" "\<nabla> s"
     "min_lvar_not_in_bounds s = Some x\<^sub>i"
     "min_rvar_incdec Positive s x\<^sub>i = Inr x\<^sub>j \<or> min_rvar_incdec Negative s x\<^sub>i = Inr x\<^sub>j"
     "b = the (\<B>\<^sub>l s x\<^sub>i) \<or> b = the (\<B>\<^sub>u s x\<^sub>i)"
     "s' = pivot_and_update x\<^sub>i x\<^sub>j b s"
     unfolding gt_state_def
     by (auto simp add: Let_def split: if_splits)
   then have
     "x\<^sub>i \<in> lvars (\<T> s)"
     "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
     using min_lvar_not_in_bounds_lvars[of s x\<^sub>i]
     using min_rvar_incdec_eq_Some_rvars[of Positive s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using min_rvar_incdec_eq_Some_rvars[of Negative s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j] \<open>\<triangle> (\<T> s)\<close>
     by (auto simp add: normalized_tableau_def)
   then show ?thesis
     using pivotandupdate_satisfies_tableau[of s x\<^sub>i x\<^sub>j b]
     using pivotandupdate_tableau_equiv[of s x\<^sub>i x\<^sub>j ]
     using \<open>\<triangle> (\<T> s)\<close> \<open>\<nabla> s\<close> \<open>\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s\<close> \<open>s' = pivot_and_update x\<^sub>i x\<^sub>j b s\<close>
     by auto
 qed
 
 lemma succ_tableau_valuated:
   assumes "s \<succ> s'" "\<nabla> s"
   shows "\<nabla> s'"
   using succ_inv(2) assms by blast
 
 (* -------------------------------------------------------------------------- *)
 abbreviation succ_chain where
   "succ_chain l \<equiv> rel_chain l succ_rel"
 
 lemma succ_chain_induct:
   assumes *: "succ_chain l" "i \<le> j" "j < length l"
   assumes base: "\<And> i. P i i"
   assumes step: "\<And> i. l ! i \<succ> (l ! (i + 1)) \<Longrightarrow> P i (i + 1)"
   assumes trans: "\<And> i j k. \<lbrakk>P i j; P j k; i < j; j \<le> k\<rbrakk> \<Longrightarrow> P i k"
   shows "P i j"
   using *
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case
     by (simp add: base)
 next
   case (Suc k)
   have "P (i + 1) j"
     using Suc(1)[of "i + 1"] Suc(2) Suc(3) Suc(4) Suc(5)
     by auto
   moreover
   have "P i (i + 1)"
   proof (rule step)
     show "l ! i \<succ> (l ! (i + 1))"
       using Suc(2) Suc(3) Suc(5)
       unfolding rel_chain_def
       by auto
   qed
   ultimately
   show ?case
     using trans[of i "i + 1" j] Suc(2)
     by simp
 qed
 
 lemma succ_chain_bounds_id:
   assumes "succ_chain l" "i \<le> j" "j < length l"
   shows "\<B>\<^sub>i (l ! i) = \<B>\<^sub>i (l ! j)"
   using assms
 proof (rule succ_chain_induct)
   fix i
   assume "l ! i \<succ> (l ! (i + 1))"
   then show "\<B>\<^sub>i (l ! i) = \<B>\<^sub>i (l ! (i + 1))"
     by (rule succ_inv(4))
 qed simp_all
 
 lemma succ_chain_vars_id':
   assumes "succ_chain l" "i \<le> j" "j < length l"
   shows "lvars (\<T> (l ! i)) \<union> rvars (\<T> (l ! i)) =
          lvars (\<T> (l ! j)) \<union> rvars (\<T> (l ! j))"
   using assms
 proof (rule succ_chain_induct)
   fix i
   assume "l ! i \<succ> (l ! (i + 1))"
   then show "tvars (\<T> (l ! i)) = tvars (\<T> (l ! (i + 1)))"
     by (rule succ_vars_id)
 qed simp_all
 
 lemma succ_chain_vars_id:
   assumes "succ_chain l" "i < length l" "j < length l"
   shows "lvars (\<T> (l ! i)) \<union> rvars (\<T> (l ! i)) =
          lvars (\<T> (l ! j)) \<union> rvars (\<T> (l ! j))"
 proof (cases "i \<le> j")
   case True
   then show ?thesis
     using assms succ_chain_vars_id'[of l i j]
     by simp
 next
   case False
   then have "j \<le> i"
     by simp
   then show ?thesis
     using assms succ_chain_vars_id'[of l j i]
     by simp
 qed
 
 lemma succ_chain_tableau_equiv':
   assumes "succ_chain l" "i \<le> j" "j < length l"
   shows "(v::'a valuation) \<Turnstile>\<^sub>t \<T> (l ! i) \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (l ! j)"
   using assms
 proof (rule succ_chain_induct)
   fix i
   assume "l ! i \<succ> (l ! (i + 1))"
   then show "v \<Turnstile>\<^sub>t \<T> (l ! i) = v \<Turnstile>\<^sub>t \<T> (l ! (i + 1))"
     by (rule succ_inv(5))
 qed simp_all
 
 lemma succ_chain_tableau_equiv:
   assumes "succ_chain l"  "i < length l" "j < length l"
   shows "(v::'a valuation) \<Turnstile>\<^sub>t \<T> (l ! i) \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (l ! j)"
 proof (cases "i \<le> j")
   case True
   then show ?thesis
     using assms succ_chain_tableau_equiv'[of l i j v]
     by simp
 next
   case False
   then have "j \<le> i"
     by auto
   then show ?thesis
     using assms succ_chain_tableau_equiv'[of l j i v]
     by simp
 qed
 
 lemma succ_chain_no_vars_valuation:
   assumes "succ_chain l"  "i \<le> j" "j < length l"
   shows "\<forall> x. x \<notin> tvars (\<T> (l ! i)) \<longrightarrow> look (\<V> (l ! i)) x = look (\<V> (l ! j)) x" (is "?P i j")
   using assms
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case
     by simp
 next
   case (Suc k)
   have "?P (i + 1) j"
     using Suc(1)[of "i + 1"] Suc(2) Suc(3) Suc(4) Suc(5)
     by auto
   moreover
   have "?P (i + 1) i"
   proof (rule+, rule succ_no_vars_valuation)
     show "l ! i \<succ> (l ! (i + 1))"
       using Suc(2) Suc(3) Suc(5)
       unfolding rel_chain_def
       by auto
   qed
   moreover
   have "tvars (\<T> (l ! i)) = tvars (\<T> (l ! (i + 1)))"
   proof (rule succ_vars_id)
     show "l ! i \<succ> (l ! (i + 1))"
       using Suc(2) Suc(3) Suc(5)
       unfolding rel_chain_def
       by simp
   qed
   ultimately
   show ?case
     by simp
 qed
 
 lemma succ_chain_rvar_valuation:
   assumes "succ_chain l" "i \<le> j" "j < length l"
   shows "\<forall>x\<in>rvars (\<T> (l ! j)).
   \<langle>\<V> (l ! j)\<rangle> x = \<langle>\<V> (l ! i)\<rangle> x \<or>
   \<langle>\<V> (l ! j)\<rangle> x = the (\<B>\<^sub>l (l ! i) x) \<or>
   \<langle>\<V> (l ! j)\<rangle> x = the (\<B>\<^sub>u (l ! i) x)" (is "?P i j")
   using assms
 proof (induct "j - i" arbitrary: j)
   case 0
   then show ?case
     by simp
 next
   case (Suc k)
   have  "k = j - 1 - i" "succ_chain l" "i \<le> j - 1" "j - 1 < length l" "j > 0"
     using Suc(2) Suc(3) Suc(4) Suc(5)
     by auto
   then have ji: "?P i (j - 1)"
     using Suc(1)
     by simp
 
   have "l ! (j - 1) \<succ> (l ! j)"
     using Suc(3) \<open>j < length l\<close> \<open>j > 0\<close>
     unfolding rel_chain_def
     by (erule_tac x="j - 1" in allE) simp
 
   then have
     jj: "?P (j - 1) j"
     using succ_rvar_valuation
     by auto
 
   obtain x\<^sub>i x\<^sub>j where
     vars: "x\<^sub>i \<in> lvars (\<T> (l ! (j - 1)))" "x\<^sub>j \<in> rvars (\<T> (l ! (j - 1)))"
     "rvars (\<T> (l ! j)) = rvars (\<T> (l ! (j - 1))) - {x\<^sub>j} \<union> {x\<^sub>i}"
     using \<open>l ! (j - 1) \<succ> (l ! j)\<close>
     by (rule succ_vars) simp
 
   then have bounds:
     "\<B>\<^sub>l (l ! (j - 1)) = \<B>\<^sub>l (l ! i)" "\<B>\<^sub>l (l ! j) = \<B>\<^sub>l (l ! i)"
     "\<B>\<^sub>u (l ! (j - 1)) = \<B>\<^sub>u (l ! i)" "\<B>\<^sub>u (l ! j) = \<B>\<^sub>u (l ! i)"
     using \<open>succ_chain l\<close>
     using succ_chain_bounds_id[of l i "j - 1", THEN sym] \<open>j - 1 < length l\<close> \<open>i \<le> j - 1\<close>
     using succ_chain_bounds_id[of l "j - 1" j, THEN sym] \<open>j < length l\<close>
     by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
   show ?case
   proof
     fix x
     assume "x \<in> rvars (\<T> (l ! j))"
     then have "x \<noteq> x\<^sub>j \<and> x \<in> rvars (\<T> (l ! (j - 1))) \<or> x = x\<^sub>i"
       using vars
       by auto
     then show "\<langle>\<V> (l ! j)\<rangle> x = \<langle>\<V> (l ! i)\<rangle> x \<or>
           \<langle>\<V> (l ! j)\<rangle> x = the (\<B>\<^sub>l (l ! i) x) \<or>
           \<langle>\<V> (l ! j)\<rangle> x = the (\<B>\<^sub>u (l ! i) x)"
     proof
       assume "x \<noteq> x\<^sub>j \<and> x \<in> rvars (\<T> (l ! (j - 1)))"
       then show ?thesis
         using jj \<open>x \<in> rvars (\<T> (l ! j))\<close> ji
         using bounds
         by force
     next
       assume "x = x\<^sub>i"
       then show ?thesis
         using succ_set_on_bound(2)[of "l ! (j - 1)" "l ! j" x\<^sub>i] \<open>l ! (j - 1) \<succ> (l ! j)\<close>
         using vars bounds
         by auto
     qed
   qed
 qed
 
 lemma succ_chain_valuation_satisfies:
   assumes "succ_chain l"  "i \<le> j" "j < length l"
   shows "\<langle>\<V> (l ! i)\<rangle> \<Turnstile>\<^sub>t \<T> (l ! i) \<longrightarrow> \<langle>\<V> (l ! j)\<rangle> \<Turnstile>\<^sub>t \<T> (l ! j)"
   using assms
 proof (rule succ_chain_induct)
   fix i
   assume "l ! i \<succ> (l ! (i + 1))"
   then show "\<langle>\<V> (l ! i)\<rangle> \<Turnstile>\<^sub>t \<T> (l ! i) \<longrightarrow> \<langle>\<V> (l ! (i + 1))\<rangle> \<Turnstile>\<^sub>t \<T> (l ! (i + 1))"
     using succ_valuation_satisfies
     by auto
 qed simp_all
 
 lemma succ_chain_tableau_valuated:
   assumes "succ_chain l"  "i \<le> j" "j < length l"
   shows "\<nabla> (l ! i) \<longrightarrow> \<nabla> (l ! j)"
   using assms
 proof(rule succ_chain_induct)
   fix i
   assume "l ! i \<succ> (l ! (i + 1))"
   then show "\<nabla> (l ! i) \<longrightarrow> \<nabla> (l ! (i + 1))"
     using succ_tableau_valuated
     by auto
 qed simp_all
 
 abbreviation swap_lr where
   "swap_lr l i x \<equiv> i + 1 < length l \<and> x \<in> lvars (\<T> (l ! i)) \<and> x \<in> rvars (\<T> (l ! (i + 1)))"
 
 abbreviation swap_rl where
   "swap_rl l i x \<equiv> i + 1 < length l \<and> x \<in> rvars (\<T> (l ! i)) \<and> x \<in> lvars (\<T> (l ! (i + 1)))"
 
 abbreviation always_r where
   "always_r l i j x \<equiv> \<forall> k. i \<le> k \<and> k \<le> j \<longrightarrow> x \<in> rvars (\<T> (l ! k))"
 
 lemma succ_chain_always_r_valuation_id:
   assumes "succ_chain l" "i \<le> j" "j < length l"
   shows "always_r l i j x \<longrightarrow> \<langle>\<V> (l ! i)\<rangle> x = \<langle>\<V> (l ! j)\<rangle> x" (is "?P i j")
   using assms
 proof (rule succ_chain_induct)
   fix i
   assume "l ! i \<succ> (l ! (i + 1))"
   then show "?P i (i + 1)"
     using succ_rvar_valuation_id
     by simp
 qed simp_all
 
 lemma succ_chain_swap_rl_exists:
   assumes "succ_chain l" "i < j" "j < length l"
     "x \<in> rvars (\<T> (l ! i))" "x \<in> lvars (\<T> (l ! j))"
   shows "\<exists> k. i \<le> k \<and> k < j \<and> swap_rl l k x"
   using assms
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case
     by simp
 next
   case (Suc k)
   have "l ! i \<succ> (l ! (i + 1))"
     using Suc(3) Suc(4) Suc(5)
     unfolding rel_chain_def
     by auto
   then have "\<triangle> (\<T> (l ! (i + 1)))"
     by (rule succ_inv)
 
   show ?case
   proof (cases "x \<in> rvars (\<T> (l ! (i + 1)))")
     case True
     then have "j \<noteq> i + 1"
       using Suc(7) \<open>\<triangle> (\<T> (l ! (i + 1)))\<close>
       by (auto simp add: normalized_tableau_def)
     have "k = j - Suc i"
       using Suc(2)
       by simp
     then obtain k where "k \<ge> i + 1" "k < j" "swap_rl l k x"
       using \<open>x \<in> rvars (\<T> (l ! (i + 1)))\<close> \<open>j \<noteq> i + 1\<close>
       using Suc(1)[of "i + 1"] Suc(2) Suc(3) Suc(4) Suc(5) Suc(6) Suc(7)
       by auto
     then show ?thesis
       by (rule_tac x="k" in exI) simp
   next
     case False
     then have "x \<in> lvars (\<T> (l ! (i + 1)))"
       using Suc(6)
       using \<open>l ! i \<succ> (l ! (i + 1))\<close> succ_vars_id
       by auto
     then show ?thesis
       using Suc(4) Suc(5) Suc(6)
       by force
   qed
 qed
 
 lemma succ_chain_swap_lr_exists:
   assumes "succ_chain l" "i < j" "j < length l"
     "x \<in> lvars (\<T> (l ! i))" "x \<in> rvars (\<T> (l ! j))"
   shows "\<exists> k. i \<le> k \<and> k < j \<and> swap_lr l k x"
   using assms
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case
     by simp
 next
   case (Suc k)
   have "l ! i \<succ> (l ! (i + 1))"
     using Suc(3) Suc(4) Suc(5)
     unfolding rel_chain_def
     by auto
   then have "\<triangle> (\<T> (l ! (i + 1)))"
     by (rule succ_inv)
 
   show ?case
   proof (cases "x \<in> lvars (\<T> (l ! (i + 1)))")
     case True
     then have "j \<noteq> i + 1"
       using Suc(7) \<open>\<triangle> (\<T> (l ! (i + 1)))\<close>
       by (auto simp add: normalized_tableau_def)
     have "k = j - Suc i"
       using Suc(2)
       by simp
     then obtain k where "k \<ge> i + 1" "k < j" "swap_lr l k x"
       using \<open>x \<in> lvars (\<T> (l ! (i + 1)))\<close> \<open>j \<noteq> i + 1\<close>
       using Suc(1)[of "i + 1"] Suc(2) Suc(3) Suc(4) Suc(5) Suc(6) Suc(7)
       by auto
     then show ?thesis
       by (rule_tac x="k" in exI) simp
   next
     case False
     then have "x \<in> rvars (\<T> (l ! (i + 1)))"
       using Suc(6)
       using \<open>l ! i \<succ> (l ! (i + 1))\<close> succ_vars_id
       by auto
     then show ?thesis
       using Suc(4) Suc(5) Suc(6)
       by force
   qed
 qed
 
 (* -------------------------------------------------------------------------- *)
 
 lemma finite_tableaus_aux:
   shows "finite {t. lvars t = L \<and> rvars t = V - L \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}" (is "finite (?Al L)")
 proof (cases "?Al L = {}")
   case True
   show ?thesis
     by (subst True) simp
 next
   case False
   then have "\<exists> t. t \<in> ?Al L"
     by auto
   let ?t = "SOME t. t \<in> ?Al L"
   have "?t \<in> ?Al L"
     using \<open>\<exists> t. t \<in> ?Al L\<close>
     by (rule someI_ex)
   have "?Al L \<subseteq> {t. mset t = mset ?t}"
   proof
     fix x
     assume "x \<in> ?Al L"
     have "mset x = mset ?t"
       apply (rule tableau_perm)
       using \<open>?t \<in> ?Al L\<close> \<open>x \<in> ?Al L\<close>
       by auto
     then show "x \<in> {t. mset t = mset ?t}"
       by simp
   qed
   moreover
   have "finite {t. mset t = mset ?t}"
     by (fact mset_eq_finite)
   ultimately
   show ?thesis
     by (rule finite_subset)
 qed
 
 lemma finite_tableaus:
   assumes "finite V"
   shows "finite {t. tvars t = V \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}" (is "finite ?A")
 proof-
   let ?Al = "\<lambda> L. {t. lvars t = L \<and> rvars t = V - L \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}"
   have "?A = \<Union> (?Al ` {L. L \<subseteq> V})"
     by (auto simp add: normalized_tableau_def)
   then show ?thesis
     using \<open>finite V\<close>
     using finite_tableaus_aux
     by auto
 qed
 
 lemma finite_accessible_tableaus:
   shows "finite (\<T> ` {s'. s \<succ>\<^sup>* s'})"
 proof-
   have "{s'. s \<succ>\<^sup>* s'} = {s'. s \<succ>\<^sup>+ s'} \<union> {s}"
     by (auto simp add: rtrancl_eq_or_trancl)
   moreover
   have "finite (\<T> ` {s'. s \<succ>\<^sup>+ s'})" (is "finite ?A")
   proof-
     let ?T = "{t. tvars t = tvars (\<T> s) \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t(\<T> s))}"
     have "?A \<subseteq> ?T"
     proof
       fix t
       assume "t \<in> ?A"
       then obtain s' where "s \<succ>\<^sup>+ s'" "t = \<T> s'"
         by auto
       then obtain l where *: "l \<noteq> []" "1 < length l" "hd l = s" "last l = s'" "succ_chain l"
         using trancl_rel_chain[of s s' succ_rel]
         by auto
       show "t \<in> ?T"
       proof-
         have "tvars (\<T> s') = tvars (\<T> s)"
           using succ_chain_vars_id[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by simp
         moreover
         have "\<triangle> (\<T> s')"
           using \<open>s \<succ>\<^sup>+ s'\<close>
           using succ_inv(1)[of _ s']
           by (auto dest: tranclD2)
         moreover
         have "\<forall>v::'a valuation. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t \<T> s"
           using succ_chain_tableau_equiv[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         ultimately
         show ?thesis
           using \<open>t = \<T> s'\<close>
           by simp
       qed
     qed
     moreover
     have "finite (tvars (\<T> s))"
       by (auto simp add: lvars_def rvars_def finite_vars)
     ultimately
     show ?thesis
       using finite_tableaus[of "tvars (\<T> s)" "\<T> s"]
       by (auto simp add: finite_subset)
   qed
   ultimately
   show ?thesis
     by simp
 qed
 
 abbreviation check_valuation  where
   "check_valuation (v::'a valuation) v0 bl0 bu0 t0 V \<equiv>
      \<exists> t. tvars t = V \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0) \<and> v \<Turnstile>\<^sub>t t \<and>
      (\<forall> x \<in> rvars t. v x = v0 x \<or> v x = bl0 x \<or> v x = bu0 x) \<and>
      (\<forall> x. x \<notin> V \<longrightarrow> v x = v0 x)"
 
 lemma finite_valuations:
   assumes "finite V"
   shows "finite {v::'a valuation. check_valuation v v0 bl0 bu0 t0 V}" (is "finite ?A")
 proof-
   let ?Al = "\<lambda> L. {t. lvars t = L \<and> rvars t = V - L \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}"
   let ?Vt = "\<lambda> t. {v::'a valuation. v \<Turnstile>\<^sub>t t \<and> (\<forall> x \<in> rvars t. v x = v0 x \<or> v x = bl0 x \<or> v x = bu0 x) \<and> (\<forall> x. x \<notin> V \<longrightarrow> v x = v0 x)}"
 
   have "finite {L. L \<subseteq> V}"
     using \<open>finite V\<close>
     by auto
   have "\<forall> L. L \<subseteq> V \<longrightarrow> finite (?Al L)"
     using finite_tableaus_aux
     by auto
   have "\<forall> L t. L \<subseteq> V \<and> t \<in> ?Al L \<longrightarrow> finite (?Vt  t)"
   proof (safe)
     fix L t
     assume "lvars t \<subseteq> V" "rvars t = V - lvars t" "\<triangle> t" "\<forall>v. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0"
     then have "rvars t \<union> lvars t = V"
       by auto
 
     let ?f = "\<lambda> v x. if x \<in> rvars t then v x else 0"
 
     have "inj_on ?f (?Vt t)"
       unfolding inj_on_def
     proof (safe, rule ext)
       fix v1 v2 x
       assume "(\<lambda>x. if x \<in> rvars t then v1 x else (0 :: 'a)) =
               (\<lambda>x. if x \<in> rvars t then v2 x else (0 :: 'a))" (is "?f1 = ?f2")
       have "\<forall>x\<in>rvars t. v1 x = v2 x"
       proof
         fix x
         assume "x \<in> rvars t"
         then show "v1 x = v2 x"
           using \<open>?f1 = ?f2\<close> fun_cong[of ?f1 ?f2 x]
           by auto
       qed
       assume *: "v1 \<Turnstile>\<^sub>t t" "v2 \<Turnstile>\<^sub>t t"
         "\<forall>x. x \<notin> V \<longrightarrow> v1 x = v0 x" "\<forall>x. x \<notin> V \<longrightarrow> v2 x = v0 x"
       show "v1 x = v2 x"
       proof (cases "x \<in> lvars t")
         case False
         then show ?thesis
           using * \<open>\<forall>x\<in>rvars t. v1 x = v2 x\<close> \<open>rvars t \<union> lvars t = V\<close>
           by auto
       next
         case True
         let ?eq = "eq_for_lvar t x"
         have "?eq \<in> set t \<and> lhs ?eq = x"
           using eq_for_lvar \<open>x \<in> lvars t\<close>
           by simp
         then have "v1 x = rhs ?eq \<lbrace> v1 \<rbrace>" "v2 x = rhs ?eq \<lbrace> v2 \<rbrace>"
           using \<open>v1 \<Turnstile>\<^sub>t t\<close> \<open>v2 \<Turnstile>\<^sub>t t\<close>
           unfolding satisfies_tableau_def satisfies_eq_def
           by auto
         moreover
         have "rhs ?eq \<lbrace> v1 \<rbrace> = rhs ?eq \<lbrace> v2 \<rbrace>"
           apply (rule valuate_depend)
           using \<open>\<forall>x\<in>rvars t. v1 x = v2 x\<close> \<open>?eq \<in> set t \<and> lhs ?eq = x\<close>
           unfolding rvars_def
           by auto
         ultimately
         show ?thesis
           by simp
       qed
     qed
 
     let ?R = "{v. \<forall> x. if x \<in> rvars t then v x = v0 x \<or> v x = bl0 x \<or> v x = bu0 x else v x = 0 }"
     have "?f ` (?Vt t) \<subseteq> ?R"
       by auto
     moreover
     have "finite ?R"
     proof-
       have "finite (rvars t)"
         using \<open>finite V\<close> \<open>rvars t \<union> lvars t = V\<close>
         using  finite_subset[of "rvars t" V]
         by auto
       moreover
       let ?R' = "{v. \<forall> x. if x \<in> rvars t then v x \<in> {v0 x, bl0 x, bu0 x} else v x = 0}"
       have "?R = ?R'"
         by auto
       ultimately
       show ?thesis
         using finite_fun_args[of "rvars t" "\<lambda> x. {v0 x,  bl0 x, bu0 x}" "\<lambda> x. 0"]
         by auto
     qed
     ultimately
     have "finite (?f ` (?Vt t))"
       by (simp add: finite_subset)
     then show "finite (?Vt t)"
       using \<open>inj_on ?f (?Vt t)\<close>
       by (auto dest: finite_imageD)
   qed
 
   have "?A = \<Union> (\<Union> (((`) ?Vt) ` (?Al ` {L. L \<subseteq> V})))" (is "?A = ?A'")
     by (auto simp add: normalized_tableau_def cong del: image_cong_simp)
   moreover
   have "finite ?A'"
   proof (rule finite_Union)
     show "finite (\<Union> (((`) ?Vt) ` (?Al ` {L. L \<subseteq> V})))"
       using \<open>finite {L. L \<subseteq> V}\<close> \<open>\<forall> L. L \<subseteq> V \<longrightarrow> finite (?Al L)\<close>
       by auto
   next
     fix M
     assume "M \<in> \<Union> (((`) ?Vt) ` (?Al ` {L. L \<subseteq> V}))"
     then obtain L t where "L \<subseteq> V" "t \<in> ?Al L" "M = ?Vt t"
       by blast
     then show "finite M"
       using \<open>\<forall> L t. L \<subseteq> V \<and> t \<in> ?Al L \<longrightarrow> finite (?Vt  t)\<close>
       by blast
   qed
   ultimately
   show ?thesis
     by simp
 qed
 
 
 lemma finite_accessible_valuations:
   shows "finite (\<V> ` {s'. s \<succ>\<^sup>* s'})"
 proof-
   have "{s'. s \<succ>\<^sup>* s'} = {s'. s \<succ>\<^sup>+ s'} \<union> {s}"
     by (auto simp add: rtrancl_eq_or_trancl)
   moreover
   have "finite (\<V> ` {s'. s \<succ>\<^sup>+ s'})" (is "finite ?A")
   proof-
     let ?P = "\<lambda> v. check_valuation v (\<langle>\<V> s\<rangle>) (\<lambda> x. the (\<B>\<^sub>l s x)) (\<lambda> x. the (\<B>\<^sub>u s x)) (\<T> s) (tvars (\<T> s))"
     let ?P' = "\<lambda> v::(var, 'a) mapping.
          \<exists> t. tvars t = tvars (\<T> s) \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> s) \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and>
     (\<forall> x \<in> rvars t. \<langle>v\<rangle> x = \<langle>\<V> s\<rangle> x \<or>
                        \<langle>v\<rangle> x = the (\<B>\<^sub>l s x) \<or>
                        \<langle>v\<rangle> x = the (\<B>\<^sub>u s x)) \<and>
     (\<forall> x. x \<notin> tvars (\<T> s) \<longrightarrow> look v x = look (\<V> s) x) \<and>
     (\<forall> x. x \<in> tvars (\<T> s) \<longrightarrow> look v x \<noteq> None)"
 
     have "finite (tvars (\<T> s))"
       by (auto simp add: lvars_def rvars_def finite_vars)
     then have "finite {v. ?P v}"
       using finite_valuations[of "tvars (\<T> s)" "\<T> s" "\<langle>\<V> s\<rangle>" "\<lambda> x. the (\<B>\<^sub>l s x)" "\<lambda> x. the (\<B>\<^sub>u s x)"]
       by auto
     moreover
     have "map2fun ` {v. ?P' v} \<subseteq> {v. ?P v}"
       by (auto simp add: map2fun_def)
     ultimately
     have "finite (map2fun ` {v. ?P' v})"
       by (auto simp add: finite_subset)
     moreover
     have "inj_on map2fun {v. ?P' v}"
       unfolding inj_on_def
     proof (safe)
       fix x y
       assume "\<langle>x\<rangle> = \<langle>y\<rangle>" and *:
         "\<forall>x. x \<notin> Simplex.tvars (\<T> s) \<longrightarrow> look y x = look (\<V> s) x"
         "\<forall>xa. xa \<notin> Simplex.tvars (\<T> s) \<longrightarrow> look x xa = look (\<V> s) xa"
         "\<forall>x. x \<in> Simplex.tvars (\<T> s) \<longrightarrow> look y x \<noteq> None"
         "\<forall>xa. xa \<in> Simplex.tvars (\<T> s) \<longrightarrow> look x xa \<noteq> None"
       show "x = y"
       proof (rule mapping_eqI)
         fix k
         have "\<langle>x\<rangle> k = \<langle>y\<rangle> k"
           using \<open>\<langle>x\<rangle> = \<langle>y\<rangle>\<close>
           by simp
         then show "look x k = look y k"
           using *
           by  (cases "k \<in> tvars (\<T> s)") (auto simp add: map2fun_def split: option.split)
       qed
     qed
     ultimately
     have "finite {v. ?P' v}"
       by (rule finite_imageD)
     moreover
     have "?A \<subseteq> {v. ?P' v}"
     proof (safe)
       fix s'
       assume "s \<succ>\<^sup>+ s'"
       then obtain l where *: "l \<noteq> []" "1 < length l" "hd l = s" "last l = s'" "succ_chain l"
         using trancl_rel_chain[of s s' succ_rel]
         by auto
       show "?P' (\<V> s')"
       proof-
         have "\<nabla> s" "\<triangle> (\<T> s)" "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s"
           using \<open>s \<succ>\<^sup>+ s'\<close>
           using tranclD[of s s' succ_rel]
           by (auto simp add: curr_val_satisfies_no_lhs_def)
         have "tvars (\<T> s') = tvars (\<T> s)"
           using succ_chain_vars_id[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by simp
         moreover
         have "\<triangle>(\<T> s')"
           using \<open>s \<succ>\<^sup>+ s'\<close>
           using succ_inv(1)[of _ s']
           by (auto dest: tranclD2)
         moreover
         have "\<forall>v::'a valuation. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t \<T> s"
           using succ_chain_tableau_equiv[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         moreover
         have "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'"
           using succ_chain_valuation_satisfies[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l] \<open>\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s\<close>
           by simp
         moreover
         have "\<forall>x\<in>rvars (\<T> s'). \<langle>\<V> s'\<rangle> x = \<langle>\<V> s\<rangle> x \<or> \<langle>\<V> s'\<rangle> x = the (\<B>\<^sub>l s x) \<or> \<langle>\<V> s'\<rangle> x = the (\<B>\<^sub>u s x)"
           using succ_chain_rvar_valuation[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         moreover
         have "\<forall>x. x \<notin> tvars (\<T> s) \<longrightarrow> look (\<V> s') x = look (\<V> s) x"
           using succ_chain_no_vars_valuation[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         moreover
         have "\<forall>x. x \<in> Simplex.tvars (\<T> s') \<longrightarrow> look (\<V> s') x \<noteq> None"
           using succ_chain_tableau_valuated[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           using \<open>tvars (\<T> s') = tvars (\<T> s)\<close> \<open>\<nabla> s\<close>
           by (auto simp add: tableau_valuated_def)
         ultimately
         show ?thesis
           by (rule_tac x="\<T> s'" in exI) auto
       qed
     qed
     ultimately
     show ?thesis
       by (auto simp add: finite_subset)
   qed
   ultimately
   show ?thesis
     by simp
 qed
 
 lemma accessible_bounds:
   shows "\<B>\<^sub>i ` {s'. s \<succ>\<^sup>* s'} = {\<B>\<^sub>i s}"
 proof -
   have "s \<succ>\<^sup>* s' \<Longrightarrow> \<B>\<^sub>i s' = \<B>\<^sub>i s" for s'
     by (induct s s' rule: rtrancl.induct, auto)
   then show ?thesis by blast
 qed
 
 lemma accessible_unsat_core:
   shows "\<U>\<^sub>c ` {s'. s \<succ>\<^sup>* s'} = {\<U>\<^sub>c s}"
 proof -
   have "s \<succ>\<^sup>* s' \<Longrightarrow> \<U>\<^sub>c s' = \<U>\<^sub>c s" for s'
     by (induct s s' rule: rtrancl.induct, auto)
   then show ?thesis by blast
 qed
 
 lemma state_eqI:
   "\<B>\<^sub>i\<^sub>l s = \<B>\<^sub>i\<^sub>l s' \<Longrightarrow> \<B>\<^sub>i\<^sub>u s = \<B>\<^sub>i\<^sub>u s' \<Longrightarrow>
    \<T> s = \<T> s' \<Longrightarrow> \<V> s = \<V> s' \<Longrightarrow>
    \<U> s = \<U> s' \<Longrightarrow> \<U>\<^sub>c s = \<U>\<^sub>c s' \<Longrightarrow>
    s = s'"
   by (cases s, cases s', auto)
 
 lemma finite_accessible_states:
   shows "finite {s'. s \<succ>\<^sup>* s'}" (is "finite ?A")
 proof-
   let ?V = "\<V> ` ?A"
   let ?T = "\<T> ` ?A"
   let ?P = "?V \<times> ?T \<times> {\<B>\<^sub>i s} \<times> {True, False} \<times> {\<U>\<^sub>c s}"
   have "finite ?P"
     using finite_accessible_valuations finite_accessible_tableaus
     by auto
   moreover
   let ?f = "\<lambda> s. (\<V> s, \<T> s, \<B>\<^sub>i s, \<U> s, \<U>\<^sub>c s)"
   have "?f ` ?A \<subseteq> ?P"
     using accessible_bounds[of s] accessible_unsat_core[of s]
     by auto
   moreover
   have "inj_on ?f ?A"
     unfolding inj_on_def by (auto intro: state_eqI)
   ultimately
   show ?thesis
     using finite_imageD [of ?f ?A]
     using finite_subset
     by auto
 qed
 
 (* -------------------------------------------------------------------------- *)
 lemma acyclic_suc_rel: "acyclic succ_rel"
 proof (rule acyclicI, rule allI)
   fix s
   show "(s, s) \<notin> succ_rel\<^sup>+"
   proof
     assume "s \<succ>\<^sup>+ s"
     then obtain l where
       "l \<noteq> []" "length l > 1" "hd l = s" "last l = s" "succ_chain l"
       using trancl_rel_chain[of s s succ_rel]
       by auto
 
     have "l ! 0 = s"
       using \<open>l \<noteq> []\<close> \<open>hd l = s\<close>
       by (simp add: hd_conv_nth)
     then have "s \<succ> (l ! 1)"
       using \<open>succ_chain l\<close>
       unfolding rel_chain_def
       using \<open>length l > 1\<close>
       by auto
     then have "\<triangle> (\<T> s)"
       by simp
 
     let ?enter_rvars =
       "{x. \<exists> sl. swap_lr l sl x}"
 
     have "finite ?enter_rvars"
     proof-
       let ?all_vars = "\<Union> (set (map (\<lambda> t. lvars t \<union> rvars t) (map \<T> l)))"
       have "finite ?all_vars"
         by (auto simp add: lvars_def rvars_def finite_vars)
       moreover
       have "?enter_rvars \<subseteq> ?all_vars"
         by force
       ultimately
       show ?thesis
         by (simp add: finite_subset)
     qed
 
     let ?xr = "Max ?enter_rvars"
     have "?xr \<in> ?enter_rvars"
     proof (rule Max_in)
       show "?enter_rvars \<noteq> {}"
       proof-
         from \<open>s \<succ> (l ! 1)\<close>
         obtain x\<^sub>i x\<^sub>j :: var where
           "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>i \<in> rvars (\<T> (l ! 1))"
           by (rule succ_vars) auto
         then have "x\<^sub>i \<in> ?enter_rvars"
           using \<open>hd l = s\<close> \<open>l \<noteq> []\<close> \<open>length l > 1\<close>
           by (auto simp add: hd_conv_nth)
         then show ?thesis
           by auto
       qed
     next
       show "finite ?enter_rvars"
         using \<open>finite ?enter_rvars\<close>
         .
     qed
     then obtain xr sl where
       "xr = ?xr" "swap_lr l sl xr"
       by auto
     then have "sl + 1 < length l"
       by simp
 
     have "(l ! sl) \<succ> (l ! (sl + 1))"
       using \<open>sl + 1 < length l\<close> \<open>succ_chain l\<close>
       unfolding rel_chain_def
       by auto
 
 
     have "length l > 2"
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with \<open>length l > 1\<close>
       have "length l = 2"
         by auto
       then have "last l = l ! 1"
         by (cases l) (auto simp add: last_conv_nth nth_Cons split: nat.split)
       then have "xr \<in> lvars (\<T> s)" "xr \<in> rvars (\<T> s)"
         using \<open>length l = 2\<close>
         using \<open>swap_lr l sl xr\<close>
         using \<open>hd l = s\<close> \<open>last l = s\<close> \<open>l \<noteq> []\<close>
         by (auto simp add: hd_conv_nth)
       then show False
         using \<open>\<triangle> (\<T> s)\<close>
         unfolding normalized_tableau_def
         by auto
     qed
 
     obtain l' where
       "hd l' = l ! (sl + 1)" "last l' = l ! sl" "length l' = length l - 1"  "succ_chain l'" and
       l'_l:   "\<forall> i. i + 1 < length l' \<longrightarrow>
      (\<exists> j. j + 1 < length l \<and> l' ! i = l ! j \<and> l' ! (i + 1) = l ! (j + 1))"
       using \<open>length l > 2\<close> \<open>sl + 1 < length l\<close> \<open>hd l = s\<close> \<open>last l = s\<close> \<open>succ_chain l\<close>
       using reorder_cyclic_list[of l s sl]
       by blast
 
     then have "xr \<in> rvars (\<T> (hd l'))"  "xr \<in> lvars (\<T> (last l'))" "length l' > 1" "l' \<noteq> []"
       using \<open>swap_lr l sl xr\<close> \<open>length l > 2\<close>
       by auto
 
     then have "\<exists> sp. swap_rl l' sp xr"
       using \<open>succ_chain l'\<close>
       using succ_chain_swap_rl_exists[of l' 0 "length l' - 1" xr]
       by (auto simp add: hd_conv_nth last_conv_nth)
     then have "\<exists> sp. swap_rl l' sp xr \<and> (\<forall> sp'. sp' < sp \<longrightarrow> \<not> swap_rl l' sp' xr)"
       by (rule min_element)
     then obtain sp where
       "swap_rl l' sp xr" "\<forall> sp'. sp' < sp \<longrightarrow> \<not> swap_rl l' sp' xr"
       by blast
     then have "sp + 1 < length l'"
       by simp
 
     have "\<langle>\<V> (l' ! 0)\<rangle> xr = \<langle>\<V> (l' ! sp)\<rangle> xr"
     proof-
       have "always_r l' 0 sp xr"
         using \<open>xr \<in> rvars (\<T> (hd l'))\<close> \<open>sp + 1 < length l'\<close>
           \<open>\<forall> sp'. sp' < sp \<longrightarrow> \<not> swap_rl l' sp' xr\<close>
       proof (induct sp)
         case 0
         then have "l' \<noteq> []"
           by auto
         then show ?case
           using 0(1)
           by (auto simp add: hd_conv_nth)
       next
         case (Suc sp')
         show ?case
         proof (safe)
           fix k
           assume "k \<le> Suc sp'"
           show "xr \<in> rvars (\<T> (l' ! k))"
           proof (cases "k = sp' + 1")
             case False
             then show ?thesis
               using Suc \<open>k \<le> Suc sp'\<close>
               by auto
           next
             case True
             then have "xr \<in> rvars (\<T> (l' ! (k - 1)))"
               using Suc
               by auto
             moreover
             then have "xr \<notin> lvars (\<T> (l' ! k))"
               using True Suc(3) Suc(4)
               by auto
             moreover
             have "(l' ! (k - 1)) \<succ> (l' ! k)"
               using \<open>succ_chain l'\<close>
               using Suc(3) True
               by (simp add: rel_chain_def)
             ultimately
             show ?thesis
               using succ_vars_id[of "l' ! (k - 1)" "l' ! k"]
               by auto
           qed
         qed
       qed
       then show ?thesis
         using \<open>sp + 1 < length l'\<close>
         using \<open>succ_chain l'\<close>
         using succ_chain_always_r_valuation_id
         by simp
     qed
 
     have "(l' ! sp) \<succ> (l' ! (sp+1))"
       using \<open>sp + 1 < length l'\<close> \<open>succ_chain l'\<close>
       unfolding rel_chain_def
       by simp
     then obtain xs xr' :: var where
       "xs \<in> lvars (\<T> (l' ! sp))"
       "xr \<in> rvars (\<T> (l' ! sp))"
       "swap_lr l' sp xs"
       apply (rule succ_vars)
       using \<open>swap_rl l' sp xr\<close> \<open>sp + 1 < length l'\<close>
       by auto
     then have "xs \<noteq> xr"
       using \<open>(l' ! sp) \<succ> (l' ! (sp+1))\<close>
       by (auto simp add: normalized_tableau_def)
 
     obtain sp' where
       "l' ! sp = l ! sp'" "l' ! (sp + 1) = l ! (sp' + 1)"
       "sp' + 1 < length l"
       using \<open>sp + 1 < length l'\<close> l'_l
       by auto
 
     have "xs \<in> ?enter_rvars"
       using \<open>swap_lr l' sp xs\<close> l'_l
       by force
 
     have "xs < xr"
     proof-
       have "xs \<le> ?xr"
         using \<open>finite ?enter_rvars\<close> \<open>xs \<in> ?enter_rvars\<close>
         by (rule Max_ge)
       then show ?thesis
         using \<open>xr = ?xr\<close> \<open>xs \<noteq> xr\<close>
         by simp
     qed
 
     let ?sl = "l ! sl"
     let ?sp = "l' ! sp"
     let ?eq = "eq_for_lvar (\<T> ?sp) xs"
     let ?bl = "\<V> ?sl"
     let ?bp = "\<V> ?sp"
 
     have "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sl" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sp"
       using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>
       using \<open>l' ! sp \<succ> (l' ! (sp+ 1))\<close>
       by simp_all
 
     have "\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl"
     proof-
       have "\<B>\<^sub>i (l' ! sp) = \<B>\<^sub>i (l' ! (length l' - 1))"
         using \<open>sp + 1 < length l'\<close> \<open>succ_chain l'\<close>
         using succ_chain_bounds_id
         by auto
       then have "\<B>\<^sub>i (last l') = \<B>\<^sub>i (l' ! sp)"
         using \<open>l' \<noteq> []\<close>
         by (simp add: last_conv_nth)
       then show ?thesis
         using \<open>last l' = l ! sl\<close>
         by simp
     qed
 
     have diff_satified: "\<langle>?bl\<rangle> xs - \<langle>?bp\<rangle> xs = ((rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>) - ((rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>)"
     proof-
       have "\<langle>?bp\<rangle> \<Turnstile>\<^sub>e ?eq"
         using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sp\<close>
         using eq_for_lvar[of xs "\<T> ?sp"]
         using \<open>xs \<in> lvars (\<T> (l' ! sp))\<close>
         unfolding curr_val_satisfies_no_lhs_def satisfies_tableau_def
         by auto
       moreover
       have "\<langle>?bl\<rangle> \<Turnstile>\<^sub>e ?eq"
       proof-
         have "\<langle>\<V> (l ! sl)\<rangle> \<Turnstile>\<^sub>t \<T> (l' ! sp)"
           using \<open>l' ! sp = l ! sp'\<close> \<open>sp' + 1 < length l\<close> \<open>sl + 1 < length l\<close>
           using \<open>succ_chain l\<close>
           using succ_chain_tableau_equiv[of l sl sp']
           using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sl\<close>
           unfolding curr_val_satisfies_no_lhs_def
           by simp
         then show ?thesis
           unfolding satisfies_tableau_def
           using eq_for_lvar
           using \<open>xs \<in> lvars (\<T> (l' ! sp))\<close>
           by simp
       qed
       moreover
       have "lhs ?eq = xs"
         using \<open>xs \<in> lvars (\<T> (l' ! sp))\<close>
         using eq_for_lvar
         by simp
       ultimately
       show ?thesis
         unfolding satisfies_eq_def
         by auto
     qed
 
     have "\<not> in_bounds xr \<langle>?bl\<rangle> (\<B> ?sl)"
       using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>  \<open>swap_lr l sl xr\<close>
       using succ_min_lvar_not_in_bounds(1)[of ?sl "l ! (sl + 1)" xr]
       by simp
 
     have "\<forall> x. x < xr \<longrightarrow> in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)"
     proof (safe)
       fix x
       assume "x < xr"
       show "in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)"
       proof (cases "x \<in> lvars (\<T> ?sl)")
         case True
         then show ?thesis
           using succ_min_lvar_not_in_bounds(2)[of ?sl "l ! (sl + 1)" xr]
           using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>  \<open>swap_lr l sl xr\<close> \<open>x < xr\<close>
           by simp
       next
         case False
         then show ?thesis
           using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sl\<close>
           unfolding curr_val_satisfies_no_lhs_def
           by (simp add: satisfies_bounds_set.simps)
       qed
     qed
 
     then have "in_bounds xs \<langle>?bl\<rangle> (\<B> ?sl)"
       using \<open>xs < xr\<close>
       by simp
 
     have "\<not> in_bounds xs \<langle>?bp\<rangle> (\<B> ?sp)"
       using \<open>l' ! sp \<succ> (l' ! (sp + 1))\<close>  \<open>swap_lr l' sp xs\<close>
       using succ_min_lvar_not_in_bounds(1)[of ?sp "l' ! (sp + 1)" xs]
       by simp
 
     have "\<forall> x \<in> rvars_eq ?eq. x > xr \<longrightarrow> \<langle>?bp\<rangle> x = \<langle>?bl\<rangle> x"
     proof (safe)
       fix x
       assume "x \<in> rvars_eq ?eq" "x > xr"
       then have "always_r l' 0 (length l' - 1) x"
       proof (safe)
         fix k
         assume "x \<in> rvars_eq ?eq" "x > xr" "0 \<le> k" "k \<le> length l' - 1"
         obtain k' where "l ! k' = l' ! k" "k' < length l"
           using l'_l \<open>k \<le> length l' - 1\<close> \<open>length l' > 1\<close>
           apply (cases "k > 0")
            apply (erule_tac x="k - 1" in allE)
            apply (drule mp)
           by auto
 
         let ?eq' = "eq_for_lvar (\<T> (l ! sp')) xs"
 
         have "\<forall> x \<in> rvars_eq ?eq'. x > xr \<longrightarrow> always_r l 0 (length l - 1) x"
         proof (safe)
           fix x k
           assume "x \<in> rvars_eq ?eq'" "xr < x" "0 \<le> k" "k \<le> length l - 1"
           then have "x \<in> rvars (\<T> (l ! sp'))"
             using eq_for_lvar[of xs "\<T> (l ! sp')"]
             using \<open>swap_lr l' sp xs\<close> \<open>l' ! sp = l ! sp'\<close>
             by (auto simp add: rvars_def)
           have *: "\<forall> i. i < sp' \<longrightarrow> x \<in> rvars (\<T> (l ! i))"
           proof (safe, rule ccontr)
             fix i
             assume "i < sp'" "x \<notin> rvars (\<T> (l ! i))"
             then have "x \<in> lvars (\<T> (l ! i))"
               using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
               using \<open>sp' + 1 < length l\<close>
               using \<open>succ_chain l\<close>
               using succ_chain_vars_id[of l i sp']
               by auto
             obtain i' where "swap_lr l i' x"
               using \<open>x \<in> lvars (\<T> (l ! i))\<close>
               using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
               using \<open>i < sp'\<close> \<open>sp' + 1 < length l\<close>
               using \<open>succ_chain l\<close>
               using succ_chain_swap_lr_exists[of l i sp' x]
               by auto
             then have "x \<in> ?enter_rvars"
               by auto
             then have "x \<le> ?xr"
               using \<open>finite ?enter_rvars\<close>
               using Max_ge[of ?enter_rvars x]
               by simp
             then show False
               using \<open>x > xr\<close>
               using \<open>xr = ?xr\<close>
               by simp
           qed
 
           then have "x \<in> rvars (\<T> (last l))"
             using \<open>hd l = s\<close> \<open>last l = s\<close> \<open>l \<noteq> []\<close>
             using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
             by (auto simp add: hd_conv_nth)
 
           show "x \<in> rvars (\<T> (l ! k))"
           proof (cases "k = length l - 1")
             case True
             then show ?thesis
               using \<open>x \<in> rvars (\<T> (last l))\<close>
               using \<open>l \<noteq> []\<close>
               by (simp add: last_conv_nth)
           next
             case False
             then have "k < length l - 1"
               using \<open>k \<le> length l - 1\<close>
               by simp
             then have "k < length l"
               using \<open>length l > 1\<close>
               by auto
             show ?thesis
             proof (rule ccontr)
               assume "\<not> ?thesis"
               then have "x \<in> lvars (\<T> (l ! k))"
                 using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
                 using \<open>sp' + 1 < length l\<close> \<open>k < length l\<close>
                 using succ_chain_vars_id[of l k sp']
                 using \<open>succ_chain l\<close> \<open>l \<noteq> []\<close>
                 by auto
               obtain i' where "swap_lr l i' x"
                 using \<open>succ_chain l\<close>
                 using \<open>x \<in> lvars (\<T> (l ! k))\<close>
                 using \<open>x \<in> rvars (\<T> (last l))\<close>
                 using \<open>k < length l - 1\<close> \<open>l \<noteq> []\<close>
                 using succ_chain_swap_lr_exists[of l k "length l - 1" x]
                 by (auto simp add: last_conv_nth)
               then have "x \<in> ?enter_rvars"
                 by auto
               then have "x \<le> ?xr"
                 using \<open>finite ?enter_rvars\<close>
                 using Max_ge[of ?enter_rvars x]
                 by simp
               then show False
                 using \<open>x > xr\<close>
                 using \<open>xr = ?xr\<close>
                 by simp
             qed
           qed
         qed
         then have "x \<in> rvars (\<T> (l ! k'))"
           using \<open>x \<in> rvars_eq ?eq\<close> \<open>x > xr\<close> \<open>k' < length l\<close>
           using \<open>l' ! sp = l ! sp'\<close>
           by simp
 
         then show "x \<in> rvars (\<T> (l' ! k))"
           using \<open>l ! k' = l' ! k\<close>
           by simp
       qed
       then have "\<langle>?bp\<rangle> x = \<langle>\<V> (l' ! (length l' - 1))\<rangle> x"
         using \<open>succ_chain l'\<close> \<open>sp + 1 < length l'\<close>
         by (auto intro!: succ_chain_always_r_valuation_id[rule_format])
       then have "\<langle>?bp\<rangle> x = \<langle>\<V> (last l')\<rangle> x"
         using \<open>l' \<noteq> []\<close>
         by (simp add: last_conv_nth)
       then show "\<langle>?bp\<rangle> x = \<langle>?bl\<rangle> x"
         using \<open>last l' = l ! sl\<close>
         by simp
     qed
 
     have "\<langle>?bp\<rangle> xr = \<langle>\<V> (l ! (sl + 1))\<rangle> xr"
       using \<open>\<langle>\<V> (l' ! 0)\<rangle> xr = \<langle>\<V> (l' ! sp)\<rangle> xr\<close>
       using \<open>hd l' = l ! (sl + 1)\<close> \<open>l' \<noteq> []\<close>
       by (simp add: hd_conv_nth)
 
     {
       fix dir1 dir2 :: "('i,'a) Direction"
       assume dir1: "dir1 = (if \<langle>?bl\<rangle> xr <\<^sub>l\<^sub>b \<B>\<^sub>l ?sl xr then Positive else Negative)"
       then have "\<lhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)"
         using \<open>\<not> in_bounds xr \<langle>?bl\<rangle> (\<B> ?sl)\<close>
         using neg_bounds_compare(7) neg_bounds_compare(3)
         by (auto simp add: bound_compare''_defs)
       then have "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)"
         using bounds_compare_contradictory(7) bounds_compare_contradictory(3) neg_bounds_compare(6) dir1
         unfolding bound_compare''_defs
         by auto force
       have "LB dir1 ?sl xr \<noteq> None"
         using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)\<close>
         by (cases "LB dir1 ?sl xr")  (auto simp add: bound_compare_defs)
 
       assume dir2: "dir2 = (if \<langle>?bp\<rangle> xs <\<^sub>l\<^sub>b \<B>\<^sub>l ?sp xs then Positive else Negative)"
       then have "\<lhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)"
         using \<open>\<not> in_bounds xs \<langle>?bp\<rangle> (\<B> ?sp)\<close>
         using neg_bounds_compare(2) neg_bounds_compare(6)
         by (auto simp add: bound_compare''_defs)
       then have "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)"
         using bounds_compare_contradictory(3) bounds_compare_contradictory(7) neg_bounds_compare(6) dir2
         unfolding bound_compare''_defs
         by auto force
       then have "\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow> \<not> reasable_var dir2 x ?eq ?sp"
         using succ_min_rvar[of ?sp "l' ! (sp + 1)" xs xr ?eq]
         using \<open>l' ! sp \<succ> (l' ! (sp + 1))\<close>
         using \<open>swap_lr l' sp xs\<close> \<open>swap_rl l' sp xr\<close> dir2
         unfolding bound_compare''_defs
         by auto
 
       have "LB dir2 ?sp xs \<noteq> None"
         using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)\<close>
         by (cases "LB dir2 ?sp xs")  (auto simp add: bound_compare_defs)
 
       have *: "\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow>
         ((coeff (rhs ?eq) x > 0 \<longrightarrow> \<unrhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (UB dir2 ?sp x)) \<and>
          (coeff (rhs ?eq) x < 0 \<longrightarrow> \<unlhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (LB dir2 ?sp x)))"
       proof (safe)
         fix x
         assume "x \<in> rvars_eq ?eq" "x < xr" "coeff (rhs ?eq) x > 0"
         then have "\<not> \<lhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (UB dir2 ?sp x)"
           using \<open>\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow> \<not> reasable_var dir2 x ?eq ?sp\<close>
           by simp
         then show "\<unrhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (UB dir2 ?sp x)"
           using dir2 neg_bounds_compare(4) neg_bounds_compare(8)
           unfolding bound_compare''_defs
           by force
       next
         fix x
         assume "x \<in> rvars_eq ?eq" "x < xr" "coeff (rhs ?eq) x < 0"
         then have "\<not> \<rhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (LB dir2 ?sp x)"
           using \<open>\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow> \<not> reasable_var dir2 x ?eq ?sp\<close>
           by simp
         then show "\<unlhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (LB dir2 ?sp x)"
           using dir2 neg_bounds_compare(4) neg_bounds_compare(8) dir2
           unfolding bound_compare''_defs
           by force
       qed
 
       have "(lt dir2) (\<langle>?bp\<rangle> xs) (\<langle>?bl\<rangle> xs)"
         using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)\<close>
         using \<open>\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl\<close> dir2
         using \<open>in_bounds xs \<langle>?bl\<rangle> (\<B> ?sl)\<close>
         by (auto simp add: bound_compare''_defs
             simp: indexl_def indexu_def boundsl_def boundsu_def)
       then have "(lt dir2) 0 (\<langle>?bl\<rangle> xs - \<langle>?bp\<rangle> xs)"
         using dir2
         by (auto simp add: minus_gt[THEN sym] minus_lt[THEN sym])
 
       moreover
 
       have "le (lt dir2) ((rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace> - (rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>) 0"
       proof-
         have "\<forall> x \<in> rvars_eq ?eq. (0 < coeff (rhs ?eq) x \<longrightarrow> le (lt dir2) 0 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x)) \<and>
                     (coeff (rhs ?eq) x < 0 \<longrightarrow> le (lt dir2) (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x) 0)"
         proof
           fix x
           assume "x \<in> rvars_eq ?eq"
           show "(0 < coeff (rhs ?eq) x \<longrightarrow> le (lt dir2) 0 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x)) \<and>
                 (coeff (rhs ?eq) x < 0 \<longrightarrow> le (lt dir2) (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x) 0)"
           proof (cases "x < xr")
             case True
             then have "in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)"
               using \<open>\<forall> x. x < xr \<longrightarrow> in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)\<close>
               by simp
             show ?thesis
             proof (safe)
               assume "coeff (rhs ?eq) x > 0" "0 \<noteq> \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x"
               then have "\<unrhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>\<V> (l' ! sp)\<rangle> x) (UB dir2 (l' ! sp) x)"
                 using * \<open>x < xr\<close> \<open>x \<in> rvars_eq ?eq\<close>
                 by simp
               then have "le (lt dir2) (\<langle>?bl\<rangle> x) (\<langle>?bp\<rangle> x)"
                 using \<open>in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)\<close> \<open>\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl\<close> dir2
                 apply (auto simp add: bound_compare''_defs)
                 using bounds_lg(3)[of "\<langle>?bp\<rangle> x" "\<B>\<^sub>u (l ! sl) x" "\<langle>?bl\<rangle> x"]
                 using bounds_lg(6)[of "\<langle>?bp\<rangle> x" "\<B>\<^sub>l (l ! sl) x" "\<langle>?bl\<rangle> x"]
                 unfolding bound_compare''_defs
                 by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
               then show "lt dir2 0 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x)"
                 using \<open>0 \<noteq> \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x\<close>
                 using minus_gt[of "\<langle>?bl\<rangle> x" "\<langle>?bp\<rangle> x"] minus_lt[of "\<langle>?bp\<rangle> x" "\<langle>?bl\<rangle> x"] dir2
-                by auto
+                by (auto simp del: Simplex.bounds_lg)
             next
               assume "coeff (rhs ?eq) x < 0"  "\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x \<noteq> 0"
               then have "\<unlhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>\<V> (l' ! sp)\<rangle> x) (LB dir2 (l' ! sp) x)"
                 using * \<open>x < xr\<close> \<open>x \<in> rvars_eq ?eq\<close>
                 by simp
               then have "le (lt dir2) (\<langle>?bp\<rangle> x) (\<langle>?bl\<rangle> x)"
                 using \<open>in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)\<close> \<open>\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl\<close> dir2
                 apply (auto simp add: bound_compare''_defs)
                 using bounds_lg(3)[of "\<langle>?bp\<rangle> x" "\<B>\<^sub>u (l ! sl) x" "\<langle>?bl\<rangle> x"]
                 using bounds_lg(6)[of "\<langle>?bp\<rangle> x" "\<B>\<^sub>l (l ! sl) x" "\<langle>?bl\<rangle> x"]
                 unfolding bound_compare''_defs
                 by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
               then show "lt dir2 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x) 0"
                 using \<open>\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x \<noteq> 0\<close>
                 using minus_gt[of "\<langle>?bl\<rangle> x" "\<langle>?bp\<rangle> x"] minus_lt[of "\<langle>?bp\<rangle> x" "\<langle>?bl\<rangle> x"] dir2
-                by auto
+                by (auto simp del: Simplex.bounds_lg)
             qed
           next
             case False
             show ?thesis
             proof (cases "x = xr")
               case True
               have "\<langle>\<V> (l ! (sl + 1))\<rangle> xr = the (LB dir1 ?sl xr)"
                 using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>
                 using \<open>swap_lr l sl xr\<close>
                 using succ_set_on_bound(1)[of "l ! sl" "l ! (sl + 1)" xr]
                 using \<open>\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)\<close> dir1
                 unfolding bound_compare''_defs
                 by auto
               then have "\<langle>?bp\<rangle> xr = the (LB dir1 ?sl xr)"
                 using \<open>\<langle>?bp\<rangle> xr = \<langle>\<V> (l ! (sl + 1))\<rangle> xr\<close>
                 by simp
               then have "lt dir1 (\<langle>?bl\<rangle> xr) (\<langle>?bp\<rangle> xr)"
                 using \<open>LB dir1 ?sl xr \<noteq> None\<close>
                 using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)\<close> dir1
                 by (auto simp add: bound_compare_defs)
 
               moreover
 
               have "reasable_var dir2 xr ?eq ?sp"
                 using \<open>\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)\<close>
                 using \<open>l' ! sp \<succ> (l' ! (sp + 1))\<close>
                 using \<open>swap_lr l' sp xs\<close> \<open>swap_rl l' sp xr\<close>
                 using succ_min_rvar[of "l' ! sp" "l' ! (sp + 1)"xs xr ?eq] dir2
                 unfolding bound_compare''_defs
                 by auto
 
               then have "if dir1 = dir2 then coeff (rhs ?eq) xr > 0 else coeff (rhs ?eq) xr < 0"
                 using \<open>\<langle>?bp\<rangle> xr = the (LB dir1 ?sl xr)\<close>
                 using \<open>\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl\<close>[THEN sym] dir1
                 using \<open>LB dir1 ?sl xr \<noteq> None\<close> dir1 dir2
                 by (auto split: if_splits simp add: bound_compare_defs
                     indexl_def indexu_def boundsl_def boundsu_def)
               moreover
               have "dir1 = Positive \<or> dir1 = Negative" "dir2 = Positive \<or> dir2 = Negative"
                 using dir1 dir2
                 by auto
               ultimately
               show ?thesis
                 using \<open>x = xr\<close>
                 using minus_lt[of "\<langle>?bp\<rangle> xr" "\<langle>?bl\<rangle> xr"] minus_gt[of "\<langle>?bl\<rangle> xr" "\<langle>?bp\<rangle> xr"]
-                by (auto split: if_splits)
+                by (auto split: if_splits simp del: Simplex.bounds_lg)
             next
               case False
               then have "x > xr"
                 using \<open>\<not> x < xr\<close>
                 by simp
               then have "\<langle>?bp\<rangle> x = \<langle>?bl\<rangle> x"
                 using \<open>\<forall> x \<in> rvars_eq ?eq. x > xr \<longrightarrow> \<langle>?bp\<rangle> x = \<langle>?bl\<rangle> x\<close>
                 using \<open>x \<in> rvars_eq ?eq\<close>
                 by simp
               then show ?thesis
                 by simp
             qed
           qed
         qed
         then have "le (lt dir2) 0 (rhs ?eq \<lbrace> \<lambda> x. \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x \<rbrace>)"
           using dir2
           apply auto
           using valuate_nonneg[of "rhs ?eq" "\<lambda> x. \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x"]
-           apply force
+           apply (force simp del: Simplex.bounds_lg)
           using valuate_nonpos[of "rhs ?eq" "\<lambda> x. \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x"]
-          apply force
+          apply (force simp del: Simplex.bounds_lg)
           done
         then have "le (lt dir2) 0 ((rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace> - (rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>)"
           by (subst valuate_diff)+ simp
         then have "le (lt dir2) ((rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>) ((rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>)"
           using minus_lt[of "(rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>" "(rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>"] dir2
-          by auto
+          by (auto simp del: Simplex.bounds_lg)
         then show ?thesis
           using dir2
           using minus_lt[of "(rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>" "(rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>"]
           using minus_gt[of "(rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>" "(rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>"]
-          by auto
+          by (auto simp del: Simplex.bounds_lg)
       qed
       ultimately
       have False
         using diff_satified dir2
-        by (auto split: if_splits)
+        by (auto split: if_splits simp del: Simplex.bounds_lg)
     }
     then show False
       by auto
   qed
 qed
 
 (* -------------------------------------------------------------------------- *)
 
 lemma check_unsat_terminates:
   assumes "\<U> s"
   shows "check_dom s"
   by (rule check_dom.intros) (auto simp add: assms)
 
 lemma check_sat_terminates'_aux:
   assumes
     dir: "dir = (if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive else Negative)" and
     *: "\<And> s'. \<lbrakk>s \<succ> s'; \<nabla> s'; \<triangle> (\<T> s'); \<diamond> s'; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<rbrakk> \<Longrightarrow> check_dom s'" and
     "\<nabla> s" "\<triangle> (\<T> s)" "\<diamond> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
     "\<not> \<U> s" "min_lvar_not_in_bounds s = Some x\<^sub>i"
     "\<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i)"
   shows "check_dom
             (case min_rvar_incdec dir s x\<^sub>i of Inl I \<Rightarrow> set_unsat I s
              | Inr x\<^sub>j \<Rightarrow> pivot_and_update x\<^sub>i x\<^sub>j (the (LB dir s x\<^sub>i)) s)"
 proof (cases "min_rvar_incdec dir s x\<^sub>i")
   case Inl
   then show ?thesis
     using check_unsat_terminates by simp
 next
   case (Inr x\<^sub>j)
   then have xj: "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
     using min_rvar_incdec_eq_Some_rvars[of _ s "eq_for_lvar (\<T> s) x\<^sub>i" x\<^sub>j]
     using dir
     by simp
   let ?s' = "pivot_and_update x\<^sub>i x\<^sub>j (the (LB dir s x\<^sub>i)) s"
   have "check_dom ?s'"
   proof (rule * )
     show **: "\<nabla> ?s'" "\<triangle> (\<T> ?s')" "\<diamond> ?s'" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s'"
       using \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close>  Inr
       using \<open>\<nabla> s\<close> \<open>\<triangle> (\<T> s)\<close>  \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>  dir
       using pivotandupdate_check_precond
       by auto
     have xi: "x\<^sub>i \<in> lvars (\<T> s)"
       using assms(8) min_lvar_not_in_bounds_lvars by blast
     show "s \<succ> ?s'"
       unfolding gt_state_def
       using \<open>\<triangle> (\<T> s)\<close> \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close> \<open>\<nabla> s\<close>
       using \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close> \<open>\<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i)\<close>
         Inr dir
       by (intro conjI pivotandupdate_bounds_id pivotandupdate_unsat_core_id,
           auto intro!: xj xi)
   qed
   then show ?thesis using Inr by simp
 qed
 
 lemma check_sat_terminates':
   assumes "\<nabla> s" "\<triangle> (\<T> s)" "\<diamond> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "s\<^sub>0 \<succ>\<^sup>* s"
   shows "check_dom s"
   using assms
 proof (induct s rule: wf_induct[of "{(y, x). s\<^sub>0 \<succ>\<^sup>* x \<and> x \<succ> y}"])
   show "wf {(y, x). s\<^sub>0 \<succ>\<^sup>* x \<and> x \<succ> y}"
   proof (rule finite_acyclic_wf)
     let ?A = "{(s', s). s\<^sub>0 \<succ>\<^sup>* s \<and> s \<succ> s'}"
     let ?B = "{s. s\<^sub>0 \<succ>\<^sup>* s}"
     have "?A \<subseteq> ?B \<times> ?B"
     proof
       fix p
       assume "p \<in> ?A"
       then have "fst p \<in> ?B" "snd p \<in> ?B"
         using rtrancl_into_trancl1[of s\<^sub>0 "snd p" succ_rel "fst p"]
         by auto
       then show "p \<in> ?B \<times> ?B"
         using mem_Sigma_iff[of "fst p" "snd p"]
         by auto
     qed
     then show "finite ?A"
       using finite_accessible_states[of s\<^sub>0]
       using finite_subset[of ?A "?B \<times> ?B"]
       by simp
 
     show "acyclic ?A"
     proof-
       have "?A \<subseteq> succ_rel\<inverse>"
         by auto
       then show ?thesis
         using acyclic_converse acyclic_subset
         using acyclic_suc_rel
         by auto
     qed
   qed
 next
   fix s
   assume "\<forall> s'. (s', s) \<in> {(y, x). s\<^sub>0 \<succ>\<^sup>* x \<and> x \<succ> y} \<longrightarrow> \<nabla> s' \<longrightarrow> \<triangle> (\<T> s') \<longrightarrow> \<diamond> s' \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<longrightarrow> s\<^sub>0 \<succ>\<^sup>* s' \<longrightarrow> check_dom s'"
     "\<nabla> s" "\<triangle> (\<T> s)" "\<diamond> s" " \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "s\<^sub>0 \<succ>\<^sup>* s"
   then have *: "\<And> s'. \<lbrakk>s \<succ> s'; \<nabla> s'; \<triangle> (\<T> s'); \<diamond> s'; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<rbrakk> \<Longrightarrow> check_dom s'"
     using rtrancl_into_trancl1[of s\<^sub>0 s succ_rel]
     using trancl_into_rtrancl[of s\<^sub>0 _ succ_rel]
     by auto
   show "check_dom s"
   proof (rule check_dom.intros, simp_all add: check'_def, unfold Positive_def[symmetric], unfold Negative_def[symmetric])
     fix x\<^sub>i
     assume "\<not> \<U> s" "Some x\<^sub>i = min_lvar_not_in_bounds s" "\<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i"
     have "\<B>\<^sub>l s x\<^sub>i = LB Positive s x\<^sub>i"
       by simp
     show "check_dom
             (case min_rvar_incdec Positive s x\<^sub>i of
                Inl I \<Rightarrow> set_unsat I s
              | Inr x\<^sub>j \<Rightarrow> pivot_and_update x\<^sub>i x\<^sub>j (the (\<B>\<^sub>l s x\<^sub>i)) s)"
       apply (subst \<open>\<B>\<^sub>l s x\<^sub>i = LB Positive s x\<^sub>i\<close>)
       apply (rule check_sat_terminates'_aux[of Positive s x\<^sub>i])
       using \<open>\<nabla> s\<close> \<open>\<triangle> (\<T> s)\<close>  \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close> *
       using \<open>\<not> \<U> s\<close> \<open>Some x\<^sub>i = min_lvar_not_in_bounds s\<close> \<open>\<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i\<close>
       by (simp_all add: bound_compare''_defs)
   next
     fix x\<^sub>i
     assume "\<not> \<U> s" "Some x\<^sub>i = min_lvar_not_in_bounds s" "\<not> \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i"
     then have "\<langle>\<V> s\<rangle> x\<^sub>i >\<^sub>u\<^sub>b \<B>\<^sub>u s x\<^sub>i"
       using min_lvar_not_in_bounds_Some[of s x\<^sub>i]
       using neg_bounds_compare(7) neg_bounds_compare(2)
       by auto
     have "\<B>\<^sub>u s x\<^sub>i = LB Negative s x\<^sub>i"
       by simp
     show "check_dom
             (case min_rvar_incdec Negative s x\<^sub>i of
                Inl I \<Rightarrow> set_unsat I s
              | Inr x\<^sub>j \<Rightarrow> pivot_and_update x\<^sub>i x\<^sub>j (the (\<B>\<^sub>u s x\<^sub>i)) s)"
       apply (subst \<open>\<B>\<^sub>u s x\<^sub>i = LB Negative s x\<^sub>i\<close>)
       apply (rule check_sat_terminates'_aux)
       using \<open>\<nabla> s\<close> \<open>\<triangle> (\<T> s)\<close>  \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close> *
       using \<open>\<not> \<U> s\<close> \<open>Some x\<^sub>i = min_lvar_not_in_bounds s\<close> \<open>\<langle>\<V> s\<rangle> x\<^sub>i >\<^sub>u\<^sub>b \<B>\<^sub>u s x\<^sub>i\<close> \<open>\<not> \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i\<close>
       by (simp_all add: bound_compare''_defs)
   qed
 qed
 
 lemma check_sat_terminates:
   assumes "\<nabla> s" "\<triangle> (\<T> s)" "\<diamond> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
   shows "check_dom s"
   using assms
   using check_sat_terminates'[of s s]
   by simp
 
 
 lemma check_cases:
   assumes "\<U> s \<Longrightarrow> P s"
   assumes "\<lbrakk>\<not> \<U> s; min_lvar_not_in_bounds s = None\<rbrakk> \<Longrightarrow> P s"
   assumes "\<And> x\<^sub>i dir I.
     \<lbrakk>dir = Positive \<or> dir = Negative;
      \<not> \<U> s; min_lvar_not_in_bounds s = Some x\<^sub>i;
      \<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i);
      min_rvar_incdec dir s x\<^sub>i = Inl I\<rbrakk> \<Longrightarrow>
         P (set_unsat I s)"
   assumes "\<And> x\<^sub>i x\<^sub>j l\<^sub>i dir.
     \<lbrakk>dir = (if \<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i then Positive else Negative);
      \<not> \<U> s; min_lvar_not_in_bounds s = Some x\<^sub>i;
      \<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i);
      min_rvar_incdec dir s x\<^sub>i = Inr x\<^sub>j;
      l\<^sub>i = the (LB dir s x\<^sub>i);
      check' dir x\<^sub>i s = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s\<rbrakk> \<Longrightarrow>
         P (check (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s))"
   assumes "\<triangle> (\<T> s)" "\<diamond> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
   shows "P (check s)"
 proof (cases "\<U> s")
   case True
   then show ?thesis
     using assms(1)
     using check.simps[of s]
     by simp
 next
   case False
   show ?thesis
   proof (cases "min_lvar_not_in_bounds s")
     case None
     then show ?thesis
       using \<open>\<not> \<U> s\<close>
       using assms(2) \<open>\<triangle> (\<T> s)\<close> \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>
       using check.simps[of s]
       by simp
   next
     case (Some x\<^sub>i)
     let ?dir = "if (\<langle>\<V> s\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i) then (Positive :: ('i,'a)Direction) else Negative"
     let ?s' = "check' ?dir x\<^sub>i s"
     have "\<lhd>\<^sub>l\<^sub>b (lt ?dir) (\<langle>\<V> s\<rangle> x\<^sub>i)  (LB ?dir s x\<^sub>i)"
       using \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close>
       using min_lvar_not_in_bounds_Some[of s x\<^sub>i]
       using not_in_bounds[of x\<^sub>i "\<langle>\<V> s\<rangle>" "\<B>\<^sub>l s" "\<B>\<^sub>u s"]
       by (auto split: if_splits simp add: bound_compare''_defs)
 
     have "P (check ?s')"
       apply (rule check'_cases)
       using \<open>\<not> \<U> s\<close> \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close> \<open>\<lhd>\<^sub>l\<^sub>b (lt ?dir) (\<langle>\<V> s\<rangle> x\<^sub>i)  (LB ?dir s x\<^sub>i)\<close>
       using assms(3)[of ?dir x\<^sub>i]
       using assms(4)[of ?dir x\<^sub>i]
       using check.simps[of "set_unsat (_ :: 'i list) s"]
       using \<open>\<triangle> (\<T> s)\<close> \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>
       by (auto simp add:  bounds_consistent_def  curr_val_satisfies_no_lhs_def)
     then show ?thesis
       using \<open>\<not> \<U> s\<close> \<open>min_lvar_not_in_bounds s = Some x\<^sub>i\<close>
       using check.simps[of s]
       using \<open>\<triangle> (\<T> s)\<close> \<open>\<diamond> s\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>
       by auto
   qed
 qed
 
 
 lemma check_induct:
   fixes s :: "('i,'a) state"
   assumes *: "\<nabla> s" "\<triangle> (\<T> s)" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s"
   assumes **:
     "\<And> s. \<U> s \<Longrightarrow> P s s"
     "\<And> s. \<lbrakk>\<not> \<U> s; min_lvar_not_in_bounds s = None\<rbrakk> \<Longrightarrow> P s s"
     "\<And> s x\<^sub>i dir I. \<lbrakk>dir = Positive \<or> dir = Negative; \<not> \<U> s; min_lvar_not_in_bounds s = Some x\<^sub>i;
       \<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i); min_rvar_incdec dir s x\<^sub>i = Inl I\<rbrakk>
      \<Longrightarrow> P s (set_unsat I s)"
   assumes step': "\<And> s x\<^sub>i x\<^sub>j l\<^sub>i. \<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i)\<rbrakk> \<Longrightarrow> P s (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s)"
   assumes trans': "\<And> si sj sk. \<lbrakk>P si sj; P sj sk\<rbrakk> \<Longrightarrow> P si sk"
   shows "P s (check s)"
 proof-
   have "check_dom s"
     using *
     by (simp add: check_sat_terminates)
   then show ?thesis
     using *
   proof (induct s rule: check_dom.induct)
     case (step s')
     show ?case
     proof (rule check_cases)
       fix x\<^sub>i x\<^sub>j l\<^sub>i dir
       let ?dir = "if \<langle>\<V> s'\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s' x\<^sub>i then Positive else Negative"
       let ?s' = "check' dir x\<^sub>i s'"
       assume "\<not> \<U> s'" "min_lvar_not_in_bounds s' = Some x\<^sub>i" "min_rvar_incdec dir s' x\<^sub>i = Inr x\<^sub>j" "l\<^sub>i = the (LB dir s' x\<^sub>i)"
         "?s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'" "dir = ?dir"
       moreover
       then have "\<nabla> ?s'" "\<triangle> (\<T> ?s')" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s'" "\<diamond> ?s'"
         using \<open>\<nabla> s'\<close> \<open>\<triangle> (\<T> s')\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'\<close> \<open>\<diamond> s'\<close>
         using \<open>?s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'\<close>
         using pivotandupdate_check_precond[of dir s' x\<^sub>i x\<^sub>j l\<^sub>i]
         by auto
       ultimately
       have "P (check' dir x\<^sub>i s') (check (check' dir x\<^sub>i s'))"
         using step(2)[of x\<^sub>i] step(4)[of x\<^sub>i] \<open>\<triangle> (\<T> s')\<close> \<open>\<nabla> s'\<close>
         by auto
       then show "P s' (check (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'))"
         using \<open>?s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'\<close> \<open>\<triangle> (\<T> s')\<close> \<open>\<nabla> s'\<close>
         using \<open>min_lvar_not_in_bounds s' = Some x\<^sub>i\<close> \<open>min_rvar_incdec dir s' x\<^sub>i = Inr x\<^sub>j\<close>
         using step'[of s' x\<^sub>i x\<^sub>j l\<^sub>i]
         using trans'[of s' ?s' "check ?s'"]
         by (auto simp add: min_lvar_not_in_bounds_lvars  min_rvar_incdec_eq_Some_rvars)
     qed (simp_all add: \<open>\<nabla> s'\<close> \<open>\<triangle> (\<T> s')\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'\<close> \<open>\<diamond> s'\<close> **)
   qed
 qed
 
 lemma check_induct':
   fixes s :: "('i,'a) state"
   assumes "\<nabla> s" "\<triangle> (\<T> s)" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s"
   assumes "\<And> s x\<^sub>i dir I. \<lbrakk>dir = Positive \<or> dir = Negative; \<not> \<U> s; min_lvar_not_in_bounds s = Some x\<^sub>i;
   \<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i); min_rvar_incdec dir s x\<^sub>i = Inl I; P s\<rbrakk>
     \<Longrightarrow> P (set_unsat I s)"
   assumes "\<And> s x\<^sub>i x\<^sub>j l\<^sub>i. \<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_eq (eq_for_lvar (\<T> s) x\<^sub>i); P s\<rbrakk> \<Longrightarrow> P (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s)"
   assumes "P s"
   shows "P (check s)"
 proof-
   have "P s \<longrightarrow> P (check s)"
     by (rule check_induct) (simp_all add: assms)
   then show ?thesis
     using \<open>P s\<close>
     by simp
 qed
 
 lemma check_induct'':
   fixes s :: "('i,'a) state"
   assumes *: "\<nabla> s" "\<triangle> (\<T> s)" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s"
   assumes **:
     "\<U> s \<Longrightarrow> P s"
     "\<And> s. \<lbrakk>\<nabla> s; \<triangle> (\<T> s); \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<not> \<U> s; min_lvar_not_in_bounds s = None\<rbrakk> \<Longrightarrow> P s"
     "\<And> s x\<^sub>i dir I. \<lbrakk>dir = Positive \<or> dir = Negative; \<nabla> s; \<triangle> (\<T> s); \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s;  \<not> \<U> s;
     min_lvar_not_in_bounds s = Some x\<^sub>i; \<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x\<^sub>i) (LB dir s x\<^sub>i);
     min_rvar_incdec dir s x\<^sub>i = Inl I\<rbrakk>
       \<Longrightarrow> P (set_unsat I s)"
   shows "P (check s)"
 proof (cases "\<U> s")
   case True
   then show ?thesis
     using \<open>\<U> s \<Longrightarrow> P s\<close>
     by (simp add: check.simps)
 next
   case False
   have "check_dom s"
     using *
     by (simp add: check_sat_terminates)
   then show ?thesis
     using * False
   proof (induct s rule: check_dom.induct)
     case (step s')
     show ?case
     proof (rule check_cases)
       fix x\<^sub>i x\<^sub>j l\<^sub>i dir
       let ?dir = "if \<langle>\<V> s'\<rangle> x\<^sub>i <\<^sub>l\<^sub>b \<B>\<^sub>l s' x\<^sub>i then Positive else Negative"
       let ?s' = "check' dir x\<^sub>i s'"
       assume "\<not> \<U> s'" "min_lvar_not_in_bounds s' = Some x\<^sub>i" "min_rvar_incdec dir s' x\<^sub>i = Inr x\<^sub>j" "l\<^sub>i = the (LB dir s' x\<^sub>i)"
         "?s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'" "dir = ?dir"
       moreover
       then have "\<nabla> ?s'" "\<triangle> (\<T> ?s')" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s'" "\<diamond> ?s'" "\<not> \<U> ?s'"
         using \<open>\<nabla> s'\<close> \<open>\<triangle> (\<T> s')\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'\<close> \<open>\<diamond> s'\<close>
         using \<open>?s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'\<close>
         using pivotandupdate_check_precond[of dir s' x\<^sub>i x\<^sub>j l\<^sub>i]
         using pivotandupdate_unsat_id[of s' x\<^sub>i x\<^sub>j l\<^sub>i]
         by (auto simp add: min_lvar_not_in_bounds_lvars  min_rvar_incdec_eq_Some_rvars)
       ultimately
       have "P (check (check' dir x\<^sub>i s'))"
         using step(2)[of x\<^sub>i] step(4)[of x\<^sub>i] \<open>\<triangle> (\<T> s')\<close> \<open>\<nabla> s'\<close>
         by auto
       then show "P (check (pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'))"
         using \<open>?s' = pivot_and_update x\<^sub>i x\<^sub>j l\<^sub>i s'\<close>
         by simp
     qed (simp_all add: \<open>\<nabla> s'\<close> \<open>\<triangle> (\<T> s')\<close> \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'\<close> \<open>\<diamond> s'\<close> \<open>\<not> \<U> s'\<close> ** )
   qed
 qed
 
 
 end
 
 
 lemma poly_eval_update: "(p \<lbrace> v ( x := c :: 'a :: lrv) \<rbrace>) = (p \<lbrace> v \<rbrace>) + coeff p x *R (c - v x)" 
 proof (transfer, simp, goal_cases) 
   case (1 p v x c)
   hence fin: "finite {v. p v \<noteq> 0}" by simp
   have "(\<Sum>y\<in>{v. p v \<noteq> 0}. p y *R (if y = x then c else v y)) = 
     (\<Sum>y\<in>{v. p v \<noteq> 0} \<inter> {x}. p y *R (if y = x then c else v y))
     + (\<Sum>y\<in>{v. p v \<noteq> 0} \<inter> (UNIV - {x}). p y *R (if y = x then c else v y))"  (is "?l = ?a + ?b")
     by (subst sum.union_disjoint[symmetric], auto intro: sum.cong fin)
   also have "?a = (if p x = 0 then 0 else p x *R c)" by auto
   also have "\<dots> = p x *R c" by auto
   also have "?b = (\<Sum>y\<in>{v. p v \<noteq> 0} \<inter> (UNIV - {x}). p y *R v y)" (is "_ = ?c") by (rule sum.cong, auto)
   finally have l: "?l = p x *R c + ?c" .
   define r where "r = (\<Sum>y\<in>{v. p v \<noteq> 0}. p y *R v y) + p x *R (c - v x)" 
   have "r = (\<Sum>y\<in>{v. p v \<noteq> 0}. p y *R v y) + p x *R (c - v x)" by (simp add: r_def)
   also have "(\<Sum>y\<in>{v. p v \<noteq> 0}. p y *R v y) =
      (\<Sum>y\<in>{v. p v \<noteq> 0} \<inter> {x}. p y *R v y) + ?c" (is "_ = ?d + _") 
     by (subst sum.union_disjoint[symmetric], auto intro: sum.cong fin)
   also have "?d = (if p x = 0 then 0 else p x *R v x)" by auto
   also have "\<dots> = p x *R v x" by auto
   finally have "(p x *R (c - v x) + p x *R v x) + ?c = r" by simp
   also have "(p x *R (c - v x) + p x *R v x) = p x *R c" unfolding scaleRat_right_distrib[symmetric] by simp 
   finally have r: "p x *R c + ?c = r" .
   show ?case unfolding l r r_def ..
 qed
 
 context PivotUpdateMinVars
 begin
 context
   fixes rhs_eq_val :: "(var, 'a::lrv) mapping \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> eq \<Rightarrow> 'a" 
   assumes "RhsEqVal rhs_eq_val"
 begin
 
 lemma check_minimal_unsat_state_core:
   assumes *: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" "\<triangle> (\<T> s)" "\<nabla> s"
 shows "\<U> (check s) \<longrightarrow> minimal_unsat_state_core (check s)" 
   (is "?P (check s)")
 proof (rule check_induct'')
   fix s' :: "('i,'a) state" and x\<^sub>i dir I
   assume nolhs: "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'"
     and min_rvar: "min_rvar_incdec dir s' x\<^sub>i = Inl I"
     and sat: "\<not> \<U> s'"
     and min_lvar: "min_lvar_not_in_bounds s' = Some x\<^sub>i"
     and dir: "dir = Positive \<or> dir = Negative"
     and lt: "\<lhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s'\<rangle> x\<^sub>i) (LB dir s' x\<^sub>i)"
     and norm: "\<triangle> (\<T> s')" 
     and valuated: "\<nabla> s'" 
   let ?eq = "eq_for_lvar (\<T> s') x\<^sub>i" 
   have unsat_core: "set (the (\<U>\<^sub>c (set_unsat I s'))) = set I"
     by auto
 
   obtain l\<^sub>i where LB_Some: "LB dir s' x\<^sub>i = Some l\<^sub>i" and lt: "lt dir (\<langle>\<V> s'\<rangle> x\<^sub>i) l\<^sub>i"
     using lt by (cases "LB dir s' x\<^sub>i") (auto simp add: bound_compare_defs)
 
   from LB_Some dir obtain i where LBI: "look (LBI dir s') x\<^sub>i = Some (i,l\<^sub>i)" and LI: "LI dir s' x\<^sub>i = i"
     by (auto simp: simp: indexl_def indexu_def boundsl_def boundsu_def)
 
   from min_rvar_incdec_eq_None[OF min_rvar] dir
   have Is': "LI dir s' (lhs (eq_for_lvar (\<T> s') x\<^sub>i)) \<in> indices_state s' \<Longrightarrow> set I \<subseteq> indices_state s'" and
     reasable: "\<And> x. x \<in> rvars_eq ?eq \<Longrightarrow> \<not> reasable_var dir x ?eq s'" and
     setI: "set I =
         {LI dir s' (lhs ?eq)} \<union>
         {LI dir s' x |x. x \<in> rvars_eq ?eq \<and> coeff (rhs ?eq) x < 0} \<union>
         {UI dir s' x |x. x \<in> rvars_eq ?eq \<and> 0 < coeff (rhs ?eq) x}" (is "_ = ?L \<union> ?R1 \<union> ?R2")  by auto
   note setI also have id: "lhs ?eq = x\<^sub>i"
     by (simp add: EqForLVar.eq_for_lvar EqForLVar_axioms min_lvar min_lvar_not_in_bounds_lvars)
   finally have iI: "i \<in> set I" unfolding LI by auto
   note setI = setI[unfolded id]
   have "LI dir s' x\<^sub>i \<in> indices_state s'" using LBI LI
     unfolding indices_state_def using dir by force
   from Is'[unfolded id, OF this]
   have Is': "set I \<subseteq> indices_state s'" .
 
   have "x\<^sub>i \<in> lvars (\<T> s')"
     using min_lvar
     by (simp add: min_lvar_not_in_bounds_lvars)
   then have **: "?eq \<in> set (\<T> s')" "lhs ?eq = x\<^sub>i"
     by (auto simp add: eq_for_lvar)
 
   have Is': "set I \<subseteq> indices_state (set_unsat I s')"
     using Is' * unfolding indices_state_def by auto
 
   have "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'" and b: "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>b \<B> s' \<parallel> - lvars (\<T> s')" 
     using nolhs[unfolded curr_val_satisfies_no_lhs_def] by auto
   from norm[unfolded normalized_tableau_def]
   have lvars_rvars: "lvars (\<T> s') \<inter> rvars (\<T> s') = {}" by auto
   hence in_bnds: "x \<in> rvars (\<T> s') \<Longrightarrow> in_bounds x \<langle>\<V> s'\<rangle> (\<B> s')" for x
     by (intro b[unfolded satisfies_bounds_set.simps, rule_format, of x], auto)
   {      
     assume dist: "distinct_indices_state (set_unsat I s')" 
     hence "distinct_indices_state s'" unfolding distinct_indices_state_def by auto
     note dist = this[unfolded distinct_indices_state_def, rule_format]
     {
       fix x c i y
       assume c: "look (\<B>\<^sub>i\<^sub>l s') x = Some (i,c) \<or> look (\<B>\<^sub>i\<^sub>u s') x = Some (i,c)" 
         and y: "y \<in> rvars_eq ?eq" and
         coeff: "coeff (rhs ?eq) y < 0 \<and> i = LI dir s' y \<or> coeff (rhs ?eq) y > 0 \<and> i = UI dir s' y" 
       {
         assume coeff: "coeff (rhs ?eq) y < 0" and i: "i = LI dir s' y" 
         from reasable[OF y] coeff have not_gt: "\<not> (\<rhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s'\<rangle> y) (LB dir s' y))" by auto
         then obtain d where LB: "LB dir s' y = Some d" using dir by (cases "LB dir s' y", auto simp: bound_compare_defs)
         with not_gt have le: "le (lt dir) (\<langle>\<V> s'\<rangle> y) d" using dir by (auto simp: bound_compare_defs)
         from LB have "look (LBI dir s') y = Some (i, d)" unfolding i using dir
           by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         with c dist[of x i c y d] dir
         have yx: "y = x" "d = c" by auto
         from y[unfolded yx] have "x \<in> rvars (\<T> s')" using **(1) unfolding rvars_def by force
-        from in_bnds[OF this] le LB not_gt i have "\<langle>\<V> s'\<rangle> x = c" unfolding yx using dir by auto
+        from in_bnds[OF this] le LB not_gt i have "\<langle>\<V> s'\<rangle> x = c" unfolding yx using dir 
+          by (auto simp del: Simplex.bounds_lg)
         note yx(1) this
       }
       moreover
       {
         assume coeff: "coeff (rhs ?eq) y > 0" and i: "i = UI dir s' y" 
         from reasable[OF y] coeff have not_gt: "\<not> (\<lhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s'\<rangle> y) (UB dir s' y))" by auto
         then obtain d where UB: "UB dir s' y = Some d" using dir by (cases "UB dir s' y", auto simp: bound_compare_defs)
         with not_gt have le: "le (lt dir) d (\<langle>\<V> s'\<rangle> y)" using dir by (auto simp: bound_compare_defs)
         from UB have "look (UBI dir s') y = Some (i, d)" unfolding i using dir
           by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         with c dist[of x i c y d] dir
         have yx: "y = x" "d = c" by auto
         from y[unfolded yx] have "x \<in> rvars (\<T> s')" using **(1) unfolding rvars_def by force
-        from in_bnds[OF this] le UB not_gt i have "\<langle>\<V> s'\<rangle> x = c" unfolding yx using dir by auto
+        from in_bnds[OF this] le UB not_gt i have "\<langle>\<V> s'\<rangle> x = c" unfolding yx using dir 
+          by (auto simp del: Simplex.bounds_lg)
         note yx(1) this
       }
       ultimately have "y = x" "\<langle>\<V> s'\<rangle> x = c" using coeff by blast+
     } note x_vars_main = this
     {
       fix x c i
       assume c: "look (\<B>\<^sub>i\<^sub>l s') x = Some (i,c) \<or> look (\<B>\<^sub>i\<^sub>u s') x = Some (i,c)" and i: "i \<in> ?R1 \<union> ?R2" 
       from i obtain y where y: "y \<in> rvars_eq ?eq" and
         coeff: "coeff (rhs ?eq) y < 0 \<and> i = LI dir s' y \<or> coeff (rhs ?eq) y > 0 \<and> i = UI dir s' y" 
         by auto
       from x_vars_main[OF c y coeff] 
       have "y = x" "\<langle>\<V> s'\<rangle> x = c" using coeff by blast+
       with y have "x \<in> rvars_eq ?eq" "x \<in> rvars (\<T> s')" "\<langle>\<V> s'\<rangle> x = c" using **(1) unfolding rvars_def by force+       
     } note x_rvars = this
 
     have R1R2: "(?R1 \<union> ?R2, \<langle>\<V> s'\<rangle>) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s'" 
       unfolding satisfies_state_index'.simps
     proof (intro conjI)
       show "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'" by fact
       show "(?R1 \<union> ?R2, \<langle>\<V> s'\<rangle>) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e \<B>\<I> s'" 
         unfolding satisfies_bounds_index'.simps 
       proof (intro conjI impI allI)
         fix x c
         assume c: "\<B>\<^sub>l s' x = Some c" and i: "\<I>\<^sub>l s' x \<in> ?R1 \<union> ?R2" 
         from c have ci: "look (\<B>\<^sub>i\<^sub>l s') x = Some (\<I>\<^sub>l s' x, c)" unfolding boundsl_def indexl_def by auto
         from x_rvars[OF _ i] ci show "\<langle>\<V> s'\<rangle> x  = c" by auto
       next
         fix x c
         assume c: "\<B>\<^sub>u s' x = Some c" and i: "\<I>\<^sub>u s' x \<in> ?R1 \<union> ?R2" 
         from c have ci: "look (\<B>\<^sub>i\<^sub>u s') x = Some (\<I>\<^sub>u s' x, c)" unfolding boundsu_def indexu_def by auto
         from x_rvars[OF _ i] ci show "\<langle>\<V> s'\<rangle> x = c" by auto
       qed
     qed
 
     have id1: "set (the (\<U>\<^sub>c (set_unsat I s'))) = set I" 
       "\<And> x. x \<Turnstile>\<^sub>i\<^sub>s\<^sub>e set_unsat I s' \<longleftrightarrow> x \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s'" 
       by (auto simp: satisfies_state_index'.simps boundsl_def boundsu_def indexl_def indexu_def)
 
     have "subsets_sat_core (set_unsat I s')" unfolding subsets_sat_core_def id1
     proof (intro allI impI)
       fix J
       assume sub: "J \<subset> set I" 
       show "\<exists>v. (J, v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s'" 
       proof (cases "J \<subseteq> ?R1 \<union> ?R2")
         case True
         with R1R2 have "(J, \<langle>\<V> s'\<rangle>) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s'" 
           unfolding satisfies_state_index'.simps satisfies_bounds_index'.simps by blast
         thus ?thesis by blast
       next
         case False
         with sub obtain k where k: "k \<in> ?R1 \<union> ?R2" "k \<notin> J" "k \<in> set I" unfolding setI by auto
         from k(1) obtain y where y: "y \<in> rvars_eq ?eq" 
           and coeff: "coeff (rhs ?eq) y < 0 \<and> k = LI dir s' y \<or> coeff (rhs ?eq) y > 0 \<and> k = UI dir s' y" by auto
         hence cy0: "coeff (rhs ?eq) y \<noteq> 0" by auto        
         from y **(1) have ry: "y \<in> rvars (\<T> s')" unfolding rvars_def by force      
         hence yl: "y \<notin> lvars (\<T> s')" using lvars_rvars by blast
         interpret rev: RhsEqVal rhs_eq_val by fact
         note update = rev.update_valuation_nonlhs[THEN mp, OF norm valuated yl]
         define diff where "diff = l\<^sub>i - \<langle>\<V> s'\<rangle> x\<^sub>i" 
         have "\<langle>\<V> s'\<rangle> x\<^sub>i < l\<^sub>i \<Longrightarrow> 0 < l\<^sub>i - \<langle>\<V> s'\<rangle> x\<^sub>i" "l\<^sub>i < \<langle>\<V> s'\<rangle> x\<^sub>i \<Longrightarrow> l\<^sub>i - \<langle>\<V> s'\<rangle> x\<^sub>i < 0" 
           using minus_gt by (blast, insert minus_lt, blast)
-        with lt dir have diff: "lt dir 0 diff" by (auto simp: diff_def) 
+        with lt dir have diff: "lt dir 0 diff" by (auto simp: diff_def simp del: Simplex.bounds_lg) 
         define up where "up = inverse (coeff (rhs ?eq) y) *R diff" 
         define v where "v = \<langle>\<V> (rev.update y (\<langle>\<V> s'\<rangle> y + up) s')\<rangle>" 
         show ?thesis unfolding satisfies_state_index'.simps
         proof (intro exI[of _ v] conjI)
           show "v \<Turnstile>\<^sub>t \<T> s'" unfolding v_def 
             using rev.update_satisfies_tableau[OF norm valuated yl] \<open>\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'\<close> by auto
           with **(1) have "v \<Turnstile>\<^sub>e ?eq" unfolding satisfies_tableau_def by auto
           from this[unfolded satisfies_eq_def id]
           have v_xi: "v x\<^sub>i = (rhs ?eq \<lbrace> v \<rbrace>)" .  
           from \<open>\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'\<close> **(1) have "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>e ?eq" unfolding satisfies_tableau_def by auto
           hence V_xi: "\<langle>\<V> s'\<rangle> x\<^sub>i = (rhs ?eq \<lbrace> \<langle>\<V> s'\<rangle> \<rbrace>)" unfolding satisfies_eq_def id .
           have "v x\<^sub>i = \<langle>\<V> s'\<rangle> x\<^sub>i + coeff (rhs ?eq) y *R up" 
             unfolding v_xi unfolding v_def rev.update_valuate_rhs[OF **(1) norm] poly_eval_update V_xi by simp
           also have "\<dots> = l\<^sub>i" unfolding up_def diff_def scaleRat_scaleRat using cy0 by simp 
           finally have v_xi_l: "v x\<^sub>i = l\<^sub>i" .
 
           {
             assume both: "\<I>\<^sub>u s' y \<in> ?R1 \<union> ?R2" "\<B>\<^sub>u s' y \<noteq> None" "\<I>\<^sub>l s' y \<in> ?R1 \<union> ?R2" "\<B>\<^sub>l s' y \<noteq> None" 
               and diff: "\<I>\<^sub>l s' y \<noteq> \<I>\<^sub>u s' y"
             from both(1) dir obtain xu cu where 
               looku: "look (\<B>\<^sub>i\<^sub>l s') xu = Some (\<I>\<^sub>u s' y, cu) \<or> look (\<B>\<^sub>i\<^sub>u s') xu = Some (\<I>\<^sub>u s' y,cu)"
               by (smt Is' indices_state_def le_sup_iff mem_Collect_eq setI set_unsat_simps subsetCE)
             from both(1) obtain xu' where "xu' \<in> rvars_eq ?eq" "coeff (rhs ?eq) xu' < 0 \<and> \<I>\<^sub>u s' y = LI dir s' xu' \<or>
                    coeff (rhs ?eq) xu' > 0 \<and> \<I>\<^sub>u s' y = UI dir s' xu'" by blast
             with x_vars_main(1)[OF looku this] 
             have xu: "xu \<in> rvars_eq ?eq" "coeff (rhs ?eq) xu < 0 \<and> \<I>\<^sub>u s' y = LI dir s' xu \<or>
                    coeff (rhs ?eq) xu > 0 \<and> \<I>\<^sub>u s' y = UI dir s' xu" by auto
             {
               assume "xu \<noteq> y" 
               with dist[OF looku, of y] have "look (\<B>\<^sub>i\<^sub>u s') y = None" 
                 by (cases "look (\<B>\<^sub>i\<^sub>u s') y", auto simp: boundsu_def indexu_def, blast)
               with both(2) have False by (simp add: boundsu_def)
             }
             hence xu_y: "xu = y" by blast
             from both(3) dir obtain xl cl where 
               lookl: "look (\<B>\<^sub>i\<^sub>l s') xl = Some (\<I>\<^sub>l s' y, cl) \<or> look (\<B>\<^sub>i\<^sub>u s') xl = Some (\<I>\<^sub>l s' y,cl)"
               by (smt Is' indices_state_def le_sup_iff mem_Collect_eq setI set_unsat_simps subsetCE)
             from both(3) obtain xl' where "xl' \<in> rvars_eq ?eq" "coeff (rhs ?eq) xl' < 0 \<and> \<I>\<^sub>l s' y = LI dir s' xl' \<or>
                    coeff (rhs ?eq) xl' > 0 \<and> \<I>\<^sub>l s' y = UI dir s' xl'" by blast
             with x_vars_main(1)[OF lookl this] 
             have xl: "xl \<in> rvars_eq ?eq" "coeff (rhs ?eq) xl < 0 \<and> \<I>\<^sub>l s' y = LI dir s' xl \<or>
                    coeff (rhs ?eq) xl > 0 \<and> \<I>\<^sub>l s' y = UI dir s' xl" by auto
             {
               assume "xl \<noteq> y" 
               with dist[OF lookl, of y] have "look (\<B>\<^sub>i\<^sub>l s') y = None" 
                 by (cases "look (\<B>\<^sub>i\<^sub>l s') y", auto simp: boundsl_def indexl_def, blast)
               with both(4) have False by (simp add: boundsl_def)
             }
             hence xl_y: "xl = y" by blast
             from xu(2) xl(2) diff have diff: "xu \<noteq> xl" by auto
             with xu_y xl_y have False by simp
           } note both_y_False = this
           show "(J, v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e \<B>\<I> s'" unfolding satisfies_bounds_index'.simps
           proof (intro conjI allI impI)
             fix x c
             assume x: "\<B>\<^sub>l s' x = Some c" "\<I>\<^sub>l s' x \<in> J" 
             with k have not_k: "\<I>\<^sub>l s' x \<noteq> k" by auto
             from x have ci: "look (\<B>\<^sub>i\<^sub>l s') x = Some (\<I>\<^sub>l s' x, c)" unfolding boundsl_def indexl_def by auto
             show "v x = c" 
             proof (cases "\<I>\<^sub>l s' x = i")
               case False
               hence iR12: "\<I>\<^sub>l s' x \<in> ?R1 \<union> ?R2" using sub x unfolding setI LI by blast
               from x_rvars(2-3)[OF _ iR12] ci have xr: "x \<in> rvars (\<T> s')" and val: "\<langle>\<V> s'\<rangle> x = c" by auto
               with lvars_rvars have xl: "x \<notin> lvars (\<T> s')" by auto
               show ?thesis
               proof (cases "x = y")
                 case False
                 thus ?thesis using val unfolding v_def map2fun_def' update[OF xl] using val by auto
               next
                 case True
                 note coeff = coeff[folded True]
                 from coeff not_k dir ci have Iu: "\<I>\<^sub>u s' x = k" by auto
                 with ci Iu x(2) k sub False True
                 have both: "\<I>\<^sub>u s' y \<in> ?R1 \<union> ?R2" "\<I>\<^sub>l s' y \<in> ?R1 \<union> ?R2" and diff: "\<I>\<^sub>l s' y \<noteq> \<I>\<^sub>u s' y" 
                   unfolding setI LI by auto
                 have "\<B>\<^sub>l s' y \<noteq> None" using x True by simp
                 from both_y_False[OF both(1) _ both(2) this diff]
                 have "\<B>\<^sub>u s' y = None" by metis
                 with reasable[OF y] dir coeff True 
                 have "dir = Negative \<Longrightarrow> 0 < coeff (rhs ?eq) y" "dir = Positive \<Longrightarrow> 0 > coeff (rhs ?eq) y" by (auto simp: bound_compare_defs)
                 with dir coeff[unfolded True] have "k = \<I>\<^sub>l s' y" by auto
                 with diff Iu False True
                 have False by auto
                 thus ?thesis ..
               qed
             next
               case True
               from LBI ci[unfolded True] dir 
                 dist[unfolded distinct_indices_state_def, rule_format, of x i c x\<^sub>i l\<^sub>i]
               have xxi: "x = x\<^sub>i" and c: "c = l\<^sub>i" by auto
               have vxi: "v x = l\<^sub>i" unfolding xxi v_xi_l ..
               thus ?thesis unfolding c by simp
             qed
           next
             fix x c
             assume x: "\<B>\<^sub>u s' x = Some c" "\<I>\<^sub>u s' x \<in> J" 
             with k have not_k: "\<I>\<^sub>u s' x \<noteq> k" by auto
             from x have ci: "look (\<B>\<^sub>i\<^sub>u s') x = Some (\<I>\<^sub>u s' x, c)" unfolding boundsu_def indexu_def by auto
             show "v x = c" 
             proof (cases "\<I>\<^sub>u s' x = i")
               case False
               hence iR12: "\<I>\<^sub>u s' x \<in> ?R1 \<union> ?R2" using sub x unfolding setI LI by blast
               from x_rvars(2-3)[OF _ iR12] ci have xr: "x \<in> rvars (\<T> s')" and val: "\<langle>\<V> s'\<rangle> x = c" by auto
               with lvars_rvars have xl: "x \<notin> lvars (\<T> s')" by auto
               show ?thesis
               proof (cases "x = y")
                 case False
                 thus ?thesis using val unfolding v_def map2fun_def' update[OF xl] using val by auto
               next
                 case True
                 note coeff = coeff[folded True]
                 from coeff not_k dir ci have Iu: "\<I>\<^sub>l s' x = k" by auto
                 with ci Iu x(2) k sub False True
                 have both: "\<I>\<^sub>u s' y \<in> ?R1 \<union> ?R2" "\<I>\<^sub>l s' y \<in> ?R1 \<union> ?R2" and diff: "\<I>\<^sub>l s' y \<noteq> \<I>\<^sub>u s' y" 
                   unfolding setI LI by auto
                 have "\<B>\<^sub>u s' y \<noteq> None" using x True by simp
                 from both_y_False[OF both(1) this both(2) _ diff]
                 have "\<B>\<^sub>l s' y = None" by metis
                 with reasable[OF y] dir coeff True 
                 have "dir = Negative \<Longrightarrow> 0 > coeff (rhs ?eq) y" "dir = Positive \<Longrightarrow> 0 < coeff (rhs ?eq) y" by (auto simp: bound_compare_defs)
                 with dir coeff[unfolded True] have "k = \<I>\<^sub>u s' y" by auto
                 with diff Iu False True
                 have False by auto
                 thus ?thesis ..
               qed
             next
               case True
               from LBI ci[unfolded True] dir 
                 dist[unfolded distinct_indices_state_def, rule_format, of x i c x\<^sub>i l\<^sub>i]
               have xxi: "x = x\<^sub>i" and c: "c = l\<^sub>i" by auto
               have vxi: "v x = l\<^sub>i" unfolding xxi v_xi_l ..
               thus ?thesis unfolding c by simp
             qed
           qed
         qed
       qed
     qed
   } note minimal_core = this
 
   have unsat_core: "unsat_state_core (set_unsat I s')" 
     unfolding unsat_state_core_def unsat_core
   proof (intro impI conjI Is', clarify)
     fix v
     assume "(set I, v) \<Turnstile>\<^sub>i\<^sub>s set_unsat I s'"
     then have Iv: "(set I, v) \<Turnstile>\<^sub>i\<^sub>s s'"
       unfolding satisfies_state_index.simps
       by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
     from Iv have vt: "v \<Turnstile>\<^sub>t \<T> s'" and Iv: "(set I, v) \<Turnstile>\<^sub>i\<^sub>b \<B>\<I> s'"
       unfolding satisfies_state_index.simps by auto
 
     have lt_le_eq: "\<And> x y :: 'a. (x < y) \<longleftrightarrow> (x \<le> y \<and> x \<noteq> y)" by auto
     from Iv dir
     have lb: "\<And> x i c l. look (LBI dir s') x = Some (i,l) \<Longrightarrow> i \<in> set I \<Longrightarrow> le (lt dir) l (v x)"
       unfolding satisfies_bounds_index.simps
       by (auto simp: lt_le_eq indexl_def indexu_def boundsl_def boundsu_def)
 
     from lb[OF LBI iI] have li_x: "le (lt dir) l\<^sub>i (v x\<^sub>i)" .
 
     have "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>e ?eq"
       using nolhs \<open>?eq \<in> set (\<T> s')\<close>
       unfolding curr_val_satisfies_no_lhs_def
       by (simp add: satisfies_tableau_def)
     then have "\<langle>\<V> s'\<rangle> x\<^sub>i = (rhs ?eq) \<lbrace> \<langle>\<V> s'\<rangle> \<rbrace>"
       using \<open>lhs ?eq = x\<^sub>i\<close>
       by (simp add: satisfies_eq_def)
 
     moreover
 
     have "v \<Turnstile>\<^sub>e ?eq"
       using vt \<open>?eq \<in> set (\<T> s')\<close>
       by (simp add: satisfies_state_def satisfies_tableau_def)
     then have "v x\<^sub>i = (rhs ?eq) \<lbrace> v \<rbrace>"
       using \<open>lhs ?eq = x\<^sub>i\<close>
       by (simp add: satisfies_eq_def)
 
     moreover
 
     have "\<unrhd>\<^sub>l\<^sub>b (lt dir) (v x\<^sub>i) (LB dir s' x\<^sub>i)"
       using li_x dir unfolding LB_Some by (auto simp: bound_compare'_defs)
 
     moreover
 
     from min_rvar_incdec_eq_None'[rule_format, OF dir min_rvar refl Iv]
     have "le (lt dir) (rhs (?eq) \<lbrace>v\<rbrace>) (rhs (?eq) \<lbrace> \<langle>\<V> s'\<rangle> \<rbrace>)" .
 
     ultimately
 
     show False
       using dir lt LB_Some
       by (auto simp add: bound_compare_defs)
   qed
 
   thus "\<U> (set_unsat I s') \<longrightarrow> minimal_unsat_state_core (set_unsat I s')" using minimal_core
     by (auto simp: minimal_unsat_state_core_def) 
 qed (simp_all add: *)
 
 lemma Check_check: "Check check" 
 proof
   fix s :: "('i,'a) state"
   assume "\<U> s"
   then show "check s = s"
     by (simp add: check.simps)
 next
   fix s :: "('i,'a) state" and v :: "'a valuation"
   assume *: "\<nabla> s" "\<triangle> (\<T> s)" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s"
   then have "v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> (check s)"
     by (rule check_induct, simp_all add: pivotandupdate_tableau_equiv)
   moreover
   have "\<triangle> (\<T> (check s))"
     by (rule check_induct', simp_all add: * pivotandupdate_tableau_normalized)
   moreover
   have "\<nabla> (check s)"
   proof (rule check_induct', simp_all add: * pivotandupdate_tableau_valuated)
     fix s I
     show "\<nabla> s \<Longrightarrow> \<nabla> (set_unsat I s)"
       by (simp add: tableau_valuated_def)
   qed
   ultimately
   show "let s' = check s in v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> s' \<and> \<triangle> (\<T> s') \<and> \<nabla> s'"
     by (simp add: Let_def)
 next
   fix s :: "('i,'a) state"
   assume *: "\<nabla> s" "\<triangle> (\<T> s)" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s"
   from * show "\<B>\<^sub>i (check s) = \<B>\<^sub>i s"
     by (rule check_induct, simp_all add: pivotandupdate_bounds_id)
 next
   fix s :: "('i,'a) state"
   assume *: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" "\<triangle> (\<T> s)" "\<nabla> s"
   have "\<not> \<U> (check s) \<longrightarrow> \<Turnstile> (check s)"
   proof (rule check_induct'', simp_all add: *)
     fix s
     assume "min_lvar_not_in_bounds s = None" "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
     then show " \<Turnstile> s"
       using min_lvar_not_in_bounds_None[of s]
       unfolding curr_val_satisfies_state_def satisfies_state_def
       unfolding curr_val_satisfies_no_lhs_def
       by (auto simp add: satisfies_bounds_set.simps satisfies_bounds.simps)
   qed
   then show "\<not> \<U> (check s) \<Longrightarrow> \<Turnstile> (check s)" by blast
 next
   fix s :: "('i,'a) state"
   assume *: "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" "\<triangle> (\<T> s)" "\<nabla> s"
   have "\<U> (check s) \<longrightarrow> minimal_unsat_state_core (check s)"
     by (rule check_minimal_unsat_state_core[OF *])
   then show "\<U> (check s) \<Longrightarrow> minimal_unsat_state_core (check s)" by blast
 qed
 end
 end
 
 subsection\<open>Symmetries\<close>
 
 text\<open>\label{sec:symmetries} Simplex algorithm exhibits many
 symmetric cases. For example, \<open>assert_bound\<close> treats atoms
 \<open>Leq x c\<close> and \<open>Geq x c\<close> in a symmetric manner, \<open>check_inc\<close> and \<open>check_dec\<close> are symmetric, etc. These
 symmetric cases differ only in several aspects: order relations
 between numbers (\<open><\<close> vs \<open>>\<close> and \<open>\<le>\<close> vs \<open>\<ge>\<close>), the role of lower and upper bounds (\<open>\<B>\<^sub>l\<close> vs
 \<open>\<B>\<^sub>u\<close>) and their updating functions, comparisons with bounds
 (e.g., \<open>\<ge>\<^sub>u\<^sub>b\<close> vs \<open>\<le>\<^sub>l\<^sub>b\<close> or
 \<open><\<^sub>l\<^sub>b\<close> vs \<open>>\<^sub>u\<^sub>b\<close>), and atom constructors (\<open>Leq\<close>
 and \<open>Geq\<close>). These can be attributed to two different
 orientations (positive and negative) of rational axis. To avoid
 duplicating definitions and proofs, \<open>assert_bound\<close> definition
 cases for \<open>Leq\<close> and \<open>Geq\<close> are replaced by a call to a
 newly introduced function parametrized by a \<open>Direction\<close> --- a
 record containing minimal set of aspects listed above that differ in
 two definition cases such that other aspects can be derived from them
 (e.g., only \<open><\<close> need to be stored while \<open>\<le>\<close> can be
 derived from it). Two constants of the type \<open>Direction\<close> are
 defined: \<open>Positive\<close> (with \<open><\<close>, \<open>\<le>\<close> orders,
 \<open>\<B>\<^sub>l\<close> for lower and \<open>\<B>\<^sub>u\<close> for upper bounds and their
 corresponding updating functions, and \<open>Leq\<close> constructor) and
 \<open>Negative\<close> (completely opposite from the previous
 one). Similarly, \<open>check_inc\<close> and \<open>check_dec\<close> are
 replaced by a new function \<open>check_incdec\<close> parametrized by a
 \<open>Direction\<close>. All lemmas, previously repeated for each
 symmetric instance, were replaced by a more abstract one, again
 parametrized by a \<open>Direction\<close> parameter.
 \vspace{-3mm}
 \<close>
 
 (*-------------------------------------------------------------------------- *)
 subsection\<open>Concrete implementation\<close>
   (*-------------------------------------------------------------------------- *)
 
 (* -------------------------------------------------------------------------- *)
 (* Init init_state *)
 (* -------------------------------------------------------------------------- *)
 
 text\<open>It is easy to give a concrete implementation of the initial
 state constructor, which satisfies the specification of the @{term
 Init} locale.  For example:\<close>
 definition init_state :: "_ \<Rightarrow> ('i,'a :: zero)state" where
   "init_state t = State t Mapping.empty Mapping.empty (Mapping.tabulate (vars_list t) (\<lambda> v. 0)) False None"
 
 interpretation Init "init_state :: _ \<Rightarrow> ('i,'a :: lrv)state"
 proof
   fix t
   let ?init = "init_state t :: ('i,'a)state"
   show "\<langle>\<V> ?init\<rangle> \<Turnstile>\<^sub>t t"
     unfolding satisfies_tableau_def satisfies_eq_def
   proof (safe)
     fix l r
     assume "(l, r) \<in> set t"
     then have "l \<in> set (vars_list t)" "vars r \<subseteq> set (vars_list t)"
       by (auto simp: set_vars_list) (transfer, force)
     then have *: "vars r \<subseteq> lhs ` set t \<union> (\<Union>x\<in>set t. rvars_eq x)" by (auto simp: set_vars_list)
     have "\<langle>\<V> ?init\<rangle> l = (0::'a)"
       using \<open>l \<in> set (vars_list t)\<close>
       unfolding init_state_def by (auto simp: map2fun_def lookup_tabulate)
     moreover
     have "r \<lbrace> \<langle>\<V> ?init\<rangle> \<rbrace> = (0::'a)" using *
     proof (transfer fixing: t, goal_cases)
       case (1 r)
       {
         fix x
         assume "x\<in>{v. r v \<noteq> 0}"
         then have "r x *R \<langle>\<V> ?init\<rangle> x = (0::'a)"
           using 1
           unfolding init_state_def
           by (auto simp add: map2fun_def lookup_tabulate comp_def restrict_map_def set_vars_list Abstract_Linear_Poly.vars_def)
       }
       then show ?case by auto
     qed
     ultimately
     show "\<langle>\<V> ?init\<rangle> (lhs (l, r)) = rhs (l, r) \<lbrace> \<langle>\<V> ?init\<rangle> \<rbrace>"
       by auto
   qed
 next
   fix t
   show "\<nabla> (init_state t)"
     unfolding init_state_def
     by (auto simp add: lookup_tabulate tableau_valuated_def comp_def restrict_map_def set_vars_list lvars_def rvars_def)
 qed (simp_all add: init_state_def add: boundsl_def boundsu_def indexl_def indexu_def)
 
 
 (* -------------------------------------------------------------------------- *)
 (* MinVars min_lvar_not_in_bounds min_rvar_incdec_eq *)
 (* -------------------------------------------------------------------------- *)
 definition min_lvar_not_in_bounds :: "('i,'a::{linorder,zero}) state \<Rightarrow> var option" where
   "min_lvar_not_in_bounds s \<equiv>
       min_satisfying  (\<lambda> x. \<not> in_bounds x (\<langle>\<V> s\<rangle>) (\<B> s)) (map lhs (\<T> s))"
 
 interpretation MinLVarNotInBounds "min_lvar_not_in_bounds :: ('i,'a::lrv) state \<Rightarrow> _"
 proof
   fix s::"('i,'a) state"
   show "min_lvar_not_in_bounds s = None \<longrightarrow>
         (\<forall>x\<in>lvars (\<T> s). in_bounds x (\<langle>\<V> s\<rangle>) (\<B> s))"
     unfolding min_lvar_not_in_bounds_def lvars_def
     using min_satisfying_None
     by blast
 next
   fix s x\<^sub>i
   show "min_lvar_not_in_bounds s = Some x\<^sub>i \<longrightarrow> 
             x\<^sub>i \<in> lvars (\<T> s) \<and>
             \<not> in_bounds x\<^sub>i \<langle>\<V> s\<rangle> (\<B> s) \<and>
             (\<forall>x\<in>lvars (\<T> s). x < x\<^sub>i \<longrightarrow> in_bounds x \<langle>\<V> s\<rangle> (\<B> s))"
     unfolding min_lvar_not_in_bounds_def lvars_def
     using min_satisfying_Some
     by blast+
 qed
 
 \<comment> \<open>all variables in vs have either a positive or a negative coefficient, so no equal-zero test required.\<close>
 definition unsat_indices :: "('i,'a :: linorder) Direction \<Rightarrow> ('i,'a) state \<Rightarrow> var list \<Rightarrow> eq \<Rightarrow> 'i list" where
   "unsat_indices dir s vs eq = (let r = rhs eq; li = LI dir s; ui = UI dir s in
        remdups (li (lhs eq) # map (\<lambda> x. if coeff r x < 0 then li x else ui x) vs))"
 
 definition min_rvar_incdec_eq :: "('i,'a) Direction \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> eq \<Rightarrow> 'i list + var" where
   "min_rvar_incdec_eq dir s eq = (let rvars = Abstract_Linear_Poly.vars_list (rhs eq)
       in case min_satisfying (\<lambda> x. reasable_var dir x eq s) rvars of
          None \<Rightarrow> Inl (unsat_indices dir s rvars eq)
       | Some x\<^sub>j \<Rightarrow> Inr x\<^sub>j)"
 
 interpretation MinRVarsEq "min_rvar_incdec_eq :: ('i,'a :: lrv) Direction \<Rightarrow> _"
 proof
   fix s eq "is" and dir :: "('i,'a) Direction"
   let ?min = "min_satisfying (\<lambda> x. reasable_var dir x eq s) (Abstract_Linear_Poly.vars_list (rhs eq))"
   let ?vars = "Abstract_Linear_Poly.vars_list (rhs eq)"
   {
     assume "min_rvar_incdec_eq dir s eq = Inl is"
     from this[unfolded min_rvar_incdec_eq_def Let_def, simplified]
     have "?min = None" and I: "set is = set (unsat_indices dir s ?vars eq)" by (cases ?min, auto)+
     from this min_satisfying_None set_vars_list
     have 1: "\<And> x. x \<in> rvars_eq eq \<Longrightarrow> \<not> reasable_var dir x eq s" by blast
     {
       fix i
       assume "i \<in> set is" and dir: "dir = Positive \<or> dir = Negative" and lhs_eq: "LI dir s (lhs eq) \<in> indices_state s"
       from this[unfolded I unsat_indices_def Let_def]
       consider (lhs) "i = LI dir s (lhs eq)"
         | (LI_rhs) x where "i = LI dir s x" "x \<in> rvars_eq eq" "coeff (rhs eq) x < 0"
         | (UI_rhs) x where "i = UI dir s x" "x \<in> rvars_eq eq" "coeff (rhs eq) x \<ge> 0"
         by (auto split: if_splits simp: set_vars_list)
       then have "i \<in> indices_state s"
       proof cases
         case lhs
         show ?thesis unfolding lhs using lhs_eq by auto
       next
         case LI_rhs
         from 1[OF LI_rhs(2)] LI_rhs(3)
         have "\<not> (\<rhd>\<^sub>l\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (LB dir s x))" by auto
         then show ?thesis unfolding LI_rhs(1) unfolding indices_state_def using dir
           by (auto simp: bound_compare'_defs boundsl_def boundsu_def indexl_def indexu_def
               split: option.splits intro!: exI[of _ x]) auto
       next
         case UI_rhs
         from UI_rhs(2) have "coeff (rhs eq) x \<noteq> 0"
           by (simp add: coeff_zero)
         with UI_rhs(3) have "0 < coeff (rhs eq) x" by auto
         from 1[OF UI_rhs(2)] this have "\<not> (\<lhd>\<^sub>u\<^sub>b (lt dir) (\<langle>\<V> s\<rangle> x) (UB dir s x))" by auto
         then show ?thesis unfolding UI_rhs(1) unfolding indices_state_def using dir
           by (auto simp: bound_compare'_defs boundsl_def boundsu_def indexl_def indexu_def
               split: option.splits intro!: exI[of _ x]) auto
       qed
     }
     then have 2: "dir = Positive \<or> dir = Negative \<Longrightarrow> LI dir s (lhs eq) \<in> indices_state s \<Longrightarrow>
       set is \<subseteq> indices_state s" by auto
     show "
     (\<forall> x \<in> rvars_eq eq. \<not> reasable_var dir x eq s) \<and> set is =
        {LI dir s (lhs eq)} \<union> {LI dir s x |x. x \<in> rvars_eq eq \<and> 
          coeff (rhs eq) x < 0} \<union> {UI dir s x |x. x \<in> rvars_eq eq \<and> 0 < coeff (rhs eq) x} \<and>
        (dir = Positive \<or> dir = Negative \<longrightarrow> LI dir s (lhs eq) \<in> indices_state s \<longrightarrow> set is \<subseteq> indices_state s)"
     proof (intro conjI impI 2, goal_cases)
       case 2
       have "set is = {LI dir s (lhs eq)} \<union> LI dir s ` (rvars_eq eq \<inter> {x. coeff (rhs eq) x < 0}) \<union> UI dir s ` (rvars_eq eq \<inter> {x. \<not> coeff (rhs eq) x < 0})" 
         unfolding I unsat_indices_def Let_def 
         by (auto simp add: set_vars_list) 
       also have "\<dots> = {LI dir s (lhs eq)} \<union> LI dir s ` {x. x \<in> rvars_eq eq \<and> coeff (rhs eq) x < 0} 
        \<union> UI dir s ` { x. x \<in> rvars_eq eq \<and> 0 < coeff (rhs eq) x}"
       proof (intro arg_cong2[of _ _ _ _ "(\<union>)"] arg_cong[of _ _ "\<lambda> x. _ ` x"] refl, goal_cases)
         case 2
         {
           fix x
           assume "x \<in> rvars_eq eq"
           hence "coeff (rhs eq) x \<noteq> 0" 
             by (simp add: coeff_zero)
           hence or: "coeff (rhs eq) x < 0 \<or> coeff (rhs eq) x > 0" by auto
           assume "\<not> coeff (rhs eq) x < 0" 
           hence "coeff (rhs eq) x > 0" using or by simp
         } note [dest] = this
         show ?case by auto
       qed auto
       finally
       show "set is = {LI dir s (lhs eq)} \<union> {LI dir s x |x. x \<in> rvars_eq eq \<and> coeff (rhs eq) x < 0} 
        \<union> {UI dir s x |x. x \<in> rvars_eq eq \<and> 0 < coeff (rhs eq) x}" by auto
     qed (insert 1, auto)
   }
   fix x\<^sub>j
   assume "min_rvar_incdec_eq dir s eq = Inr x\<^sub>j"
   from this[unfolded min_rvar_incdec_eq_def Let_def]
   have "?min = Some x\<^sub>j" by (cases ?min, auto)
   then show "x\<^sub>j \<in> rvars_eq eq" "reasable_var dir x\<^sub>j eq s"
     "(\<forall> x' \<in> rvars_eq eq. x' < x\<^sub>j \<longrightarrow> \<not> reasable_var dir x' eq s)"
     using min_satisfying_Some set_vars_list by blast+
 qed
 
 (* -------------------------------------------------------------------------- *)
 (* EqForLVar eq_idx_for_lvar *)
 (* -------------------------------------------------------------------------- *)
 
 primrec eq_idx_for_lvar_aux :: "tableau \<Rightarrow> var \<Rightarrow> nat \<Rightarrow> nat" where
   "eq_idx_for_lvar_aux [] x i = i"
 | "eq_idx_for_lvar_aux (eq # t) x i =
      (if lhs eq = x then i else eq_idx_for_lvar_aux t x (i+1))"
 
 definition eq_idx_for_lvar where
   "eq_idx_for_lvar t x \<equiv> eq_idx_for_lvar_aux t x 0"
 
 lemma eq_idx_for_lvar_aux:
   assumes "x \<in> lvars t"
   shows "let idx = eq_idx_for_lvar_aux t x i in
             i \<le> idx \<and> idx < i + length t \<and> lhs (t ! (idx - i)) = x"
   using assms
 proof (induct t arbitrary: i)
   case Nil
   then show ?case
     by (simp add: lvars_def)
 next
   case (Cons eq t)
   show ?case
     using Cons(1)[of "i+1"] Cons(2)
     by (cases "x = lhs eq") (auto simp add: Let_def lvars_def nth_Cons')
 qed
 
 global_interpretation EqForLVarDefault: EqForLVar eq_idx_for_lvar
   defines eq_for_lvar_code = EqForLVarDefault.eq_for_lvar
 proof (unfold_locales)
   fix x t
   assume "x \<in> lvars t"
   then show "eq_idx_for_lvar t x < length t \<and>
           lhs (t ! eq_idx_for_lvar t x) = x"
     using eq_idx_for_lvar_aux[of x t 0]
     by (simp add: Let_def  eq_idx_for_lvar_def)
 qed
 
 (* -------------------------------------------------------------------------- *)
 (* PivotEq pivot_eq *)
 (* -------------------------------------------------------------------------- *)
 
 definition pivot_eq :: "eq \<Rightarrow> var \<Rightarrow> eq" where
   "pivot_eq e y \<equiv> let cy = coeff (rhs e) y in
      (y, (-1/cy) *R ((rhs e) - cy *R (Var y)) + (1/cy) *R (Var (lhs e)))"
 
 lemma pivot_eq_satisfies_eq:
   assumes "y \<in> rvars_eq e"
   shows "v \<Turnstile>\<^sub>e e = v \<Turnstile>\<^sub>e pivot_eq e y"
   using assms
   using scaleRat_right_distrib[of "1 / Rep_linear_poly (rhs e) y" "- (rhs e \<lbrace> v \<rbrace>)" "v (lhs e)"]
   using Groups.group_add_class.minus_unique[of "- ((rhs e) \<lbrace> v \<rbrace>)" "v (lhs e)"]
   unfolding coeff_def vars_def
   by (simp add: coeff_def vars_def Let_def pivot_eq_def satisfies_eq_def)
     (auto simp add: rational_vector.scale_right_diff_distrib valuate_add valuate_minus valuate_uminus valuate_scaleRat valuate_Var)
 
 lemma pivot_eq_rvars:
   assumes "x \<in> vars (rhs (pivot_eq e v))" "x \<noteq> lhs e" "coeff (rhs e) v \<noteq> 0" "v \<noteq> lhs e"
   shows "x \<in> vars (rhs e)"
 proof-
   have "v \<notin> vars ((1 / coeff (rhs e) v) *R (rhs e - coeff (rhs e) v *R Var v))"
     using coeff_zero
     by force
   then have "x \<noteq> v"
     using assms(1) assms(3) assms(4)
     using vars_plus[of "(-1 / coeff (rhs e) v) *R (rhs e - coeff (rhs e) v *R Var v)" "(1 / coeff (rhs e) v) *R Var (lhs e)"]
     by (auto simp add: Let_def vars_scaleRat pivot_eq_def)
   then show ?thesis
     using assms
     using vars_plus[of "(-1 / coeff (rhs e) v) *R (rhs e - coeff (rhs e) v *R Var v)" "(1 / coeff (rhs e) v) *R Var (lhs e)"]
     using vars_minus[of "rhs e" "coeff (rhs e) v *R Var v"]
     by (auto simp add: vars_scaleRat Let_def pivot_eq_def)
 qed
 
 interpretation PivotEq pivot_eq
 proof
   fix eq x\<^sub>j
   assume "x\<^sub>j \<in> rvars_eq eq" "lhs eq \<notin> rvars_eq eq"
   have "lhs (pivot_eq eq x\<^sub>j) = x\<^sub>j"
     unfolding pivot_eq_def
     by (simp add: Let_def)
   moreover
   have "rvars_eq (pivot_eq eq x\<^sub>j) =
           {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})"
   proof
     show "rvars_eq (pivot_eq eq x\<^sub>j) \<subseteq> {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})"
     proof
       fix x
       assume "x \<in> rvars_eq (pivot_eq eq x\<^sub>j)"
       have *: "coeff (rhs (pivot_eq eq x\<^sub>j)) x\<^sub>j = 0"
         using \<open>x\<^sub>j \<in> rvars_eq eq\<close> \<open>lhs eq \<notin> rvars_eq eq\<close>
         using coeff_Var2[of "lhs eq" x\<^sub>j]
         by (auto simp add: Let_def pivot_eq_def)
       have "coeff (rhs eq) x\<^sub>j \<noteq> 0"
         using \<open>x\<^sub>j \<in> rvars_eq eq\<close>
         using coeff_zero
         by (cases eq) (auto simp add:)
       then show "x \<in> {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})"
         using pivot_eq_rvars[of x eq x\<^sub>j]
         using \<open>x \<in> rvars_eq (pivot_eq eq x\<^sub>j)\<close> \<open>x\<^sub>j \<in> rvars_eq eq\<close> \<open>lhs eq \<notin> rvars_eq eq\<close>
         using coeff_zero *
         by auto
     qed
     show "{lhs eq} \<union> (rvars_eq eq - {x\<^sub>j}) \<subseteq> rvars_eq (pivot_eq eq x\<^sub>j)"
     proof
       fix x
       assume "x \<in> {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})"
       have *: "coeff (rhs eq) (lhs eq) = 0"
         using coeff_zero
         using \<open>lhs eq \<notin> rvars_eq eq\<close>
         by auto
       have **: "coeff (rhs eq) x\<^sub>j \<noteq> 0"
         using \<open>x\<^sub>j \<in> rvars_eq eq\<close>
         by (simp add: coeff_zero)
       have ***: "x \<in> rvars_eq eq \<Longrightarrow> coeff (Var (lhs eq)) x = 0"
         using \<open>lhs eq \<notin> rvars_eq eq\<close>
         using coeff_Var2[of "lhs eq" x]
         by auto
       have "coeff (Var x\<^sub>j) (lhs eq) = 0"
         using \<open>x\<^sub>j \<in> rvars_eq eq\<close> \<open>lhs eq \<notin> rvars_eq eq\<close>
         using coeff_Var2[of x\<^sub>j "lhs eq"]
         by auto
       then have "coeff (rhs (pivot_eq eq x\<^sub>j)) x \<noteq> 0"
         using \<open>x \<in> {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})\<close> * ** ***
         using coeff_zero[of "rhs eq" x]
         by (auto simp add: Let_def coeff_Var2 pivot_eq_def)
       then show "x \<in> rvars_eq (pivot_eq eq x\<^sub>j)"
         by (simp add: coeff_zero)
     qed
   qed
   ultimately
   show "let eq' = pivot_eq eq x\<^sub>j in lhs eq' = x\<^sub>j \<and> rvars_eq eq' = {lhs eq} \<union> (rvars_eq eq - {x\<^sub>j})"
     by (simp add: Let_def)
 next
   fix v eq x\<^sub>j
   assume "x\<^sub>j \<in> rvars_eq eq"
   then show "v \<Turnstile>\<^sub>e pivot_eq eq x\<^sub>j = v \<Turnstile>\<^sub>e eq"
     using pivot_eq_satisfies_eq
     by blast
 qed
 
 (* -------------------------------------------------------------------------- *)
 (* SubstVar subst_var  *)
 (* -------------------------------------------------------------------------- *)
 
 definition subst_var:: "var \<Rightarrow> linear_poly \<Rightarrow> linear_poly \<Rightarrow> linear_poly" where
   "subst_var v lp' lp \<equiv> lp + (coeff lp v) *R lp' - (coeff lp v) *R (Var v)"
 
 definition "subst_var_eq_code = SubstVar.subst_var_eq subst_var"
 
 global_interpretation SubstVar subst_var rewrites
   "SubstVar.subst_var_eq subst_var = subst_var_eq_code"
 proof (unfold_locales)
   fix x\<^sub>j lp' lp
   have *: "\<And>x. \<lbrakk>x \<in> vars (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j); x \<notin> vars lp'\<rbrakk> \<Longrightarrow> x \<in> vars lp"
   proof-
     fix x
     assume "x \<in> vars (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j)"
     then have "coeff (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j) x \<noteq> 0"
       using coeff_zero
       by force
     assume "x \<notin> vars lp'"
     then have "coeff lp' x = 0"
       using coeff_zero
       by auto
     show "x \<in> vars lp"
     proof(rule ccontr)
       assume "x \<notin> vars lp"
       then have "coeff lp x = 0"
         using coeff_zero
         by auto
       then show False
         using \<open>coeff (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j) x \<noteq> 0\<close>
         using \<open>coeff lp' x = 0\<close>
         by (cases "x = x\<^sub>j") (auto simp add: coeff_Var2)
     qed
   qed
   have "vars (subst_var x\<^sub>j lp' lp) \<subseteq> (vars lp - {x\<^sub>j}) \<union> vars lp'"
     unfolding subst_var_def
     using coeff_zero[of "lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j" x\<^sub>j]
     using coeff_zero[of lp' x\<^sub>j]
     using *
     by auto
   moreover
   have "\<And>x. \<lbrakk>x \<notin> vars (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j); x \<in> vars lp; x \<notin> vars lp'\<rbrakk> \<Longrightarrow> x = x\<^sub>j"
   proof-
     fix x
     assume "x \<in> vars lp" "x \<notin> vars lp'"
     then have "coeff lp x \<noteq> 0" "coeff lp' x = 0"
       using coeff_zero
       by auto
     assume "x \<notin> vars (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j)"
     then have "coeff (lp + coeff lp x\<^sub>j *R lp' - coeff lp x\<^sub>j *R Var x\<^sub>j) x = 0"
       using coeff_zero
       by force
     then show "x = x\<^sub>j"
       using \<open>coeff lp x \<noteq> 0\<close> \<open>coeff lp' x = 0\<close>
       by (cases "x = x\<^sub>j") (auto simp add: coeff_Var2)
   qed
   then have "vars lp - {x\<^sub>j} - vars lp' \<subseteq> vars (subst_var x\<^sub>j lp' lp)"
     by (auto simp add: subst_var_def)
   ultimately show "vars lp - {x\<^sub>j} - vars lp' \<subseteq>s vars (subst_var x\<^sub>j lp' lp)
        \<subseteq>s vars lp - {x\<^sub>j} \<union> vars lp'"
     by simp
 next
   fix v x\<^sub>j lp' lp
   show "v x\<^sub>j = lp' \<lbrace> v \<rbrace> \<longrightarrow> lp \<lbrace> v \<rbrace> = (subst_var x\<^sub>j lp' lp) \<lbrace> v \<rbrace>"
     unfolding subst_var_def
     using valuate_minus[of "lp + coeff lp x\<^sub>j *R lp'" "coeff lp x\<^sub>j *R Var x\<^sub>j" v]
     using valuate_add[of lp "coeff lp x\<^sub>j *R lp'" v]
     using valuate_scaleRat[of "coeff lp x\<^sub>j" lp' v] valuate_scaleRat[of "coeff lp x\<^sub>j" "Var x\<^sub>j" v]
     using valuate_Var[of x\<^sub>j v]
     by auto
 next
   fix x\<^sub>j lp lp'
   assume "x\<^sub>j \<notin> vars lp" 
   hence 0: "coeff lp x\<^sub>j = 0" using coeff_zero by blast
   show "subst_var x\<^sub>j lp' lp = lp" 
     unfolding subst_var_def 0 by simp
 next
   fix x\<^sub>j lp x lp'
   assume "x\<^sub>j \<in> vars lp" "x \<in> vars lp' - vars lp" 
   hence x: "x \<noteq> x\<^sub>j" and 0: "coeff lp x = 0" and no0: "coeff lp x\<^sub>j \<noteq> 0" "coeff lp' x \<noteq> 0" 
     using coeff_zero by blast+
   from x have 00: "coeff (Var x\<^sub>j) x = 0" using coeff_Var2 by auto
   show "x \<in> vars (subst_var x\<^sub>j lp' lp)" 
     unfolding subst_var_def coeff_zero[symmetric]
     by (simp add: 0 00 no0)
 qed (simp_all add: subst_var_eq_code_def)
 
 (* -------------------------------------------------------------------------- *)
 (* Update update  *)
 (* -------------------------------------------------------------------------- *)
 
 definition rhs_eq_val where
   "rhs_eq_val v x\<^sub>i c e \<equiv> let x\<^sub>j = lhs e; a\<^sub>i\<^sub>j = coeff (rhs e) x\<^sub>i in
       \<langle>v\<rangle> x\<^sub>j + a\<^sub>i\<^sub>j *R (c - \<langle>v\<rangle> x\<^sub>i)"
 
 definition "update_code = RhsEqVal.update rhs_eq_val"
 definition "assert_bound'_code = Update.assert_bound' update_code"
 definition "assert_bound_code = Update.assert_bound update_code"
 
 global_interpretation RhsEqValDefault': RhsEqVal rhs_eq_val
   rewrites
     "RhsEqVal.update rhs_eq_val = update_code" and
     "Update.assert_bound update_code = assert_bound_code" and
     "Update.assert_bound' update_code = assert_bound'_code"
 proof unfold_locales
   fix v x c e
   assume "\<langle>v\<rangle> \<Turnstile>\<^sub>e e"
   then show "rhs_eq_val v x c e = rhs e \<lbrace> \<langle>v\<rangle>(x := c) \<rbrace>"
     unfolding rhs_eq_val_def Let_def
     using valuate_update_x[of "rhs e" x "\<langle>v\<rangle>" "\<langle>v\<rangle>(x := c)"]
     by (auto simp add: satisfies_eq_def)
 qed (auto simp: update_code_def assert_bound'_code_def assert_bound_code_def)
 
 sublocale PivotUpdateMinVars < Check check
 proof (rule Check_check)
   show "RhsEqVal rhs_eq_val" ..
 qed
 
 definition "pivot_code = Pivot'.pivot eq_idx_for_lvar pivot_eq subst_var"
 definition "pivot_tableau_code = Pivot'.pivot_tableau eq_idx_for_lvar pivot_eq subst_var"
 
 global_interpretation Pivot'Default: Pivot' eq_idx_for_lvar pivot_eq subst_var
   rewrites
     "Pivot'.pivot eq_idx_for_lvar pivot_eq subst_var = pivot_code" and
     "Pivot'.pivot_tableau eq_idx_for_lvar pivot_eq subst_var = pivot_tableau_code" and
     "SubstVar.subst_var_eq subst_var = subst_var_eq_code"
   by (unfold_locales, auto simp: pivot_tableau_code_def pivot_code_def subst_var_eq_code_def)
 
 definition "pivot_and_update_code = PivotUpdate.pivot_and_update pivot_code update_code"
 
 global_interpretation PivotUpdateDefault: PivotUpdate eq_idx_for_lvar pivot_code update_code
   rewrites
     "PivotUpdate.pivot_and_update pivot_code update_code = pivot_and_update_code"
   by (unfold_locales, auto simp: pivot_and_update_code_def)
 
 sublocale Update < AssertBoundNoLhs assert_bound
 proof (rule update_to_assert_bound_no_lhs)
   show "Pivot eq_idx_for_lvar pivot_code" ..
 qed
 
 definition "check_code = PivotUpdateMinVars.check eq_idx_for_lvar min_lvar_not_in_bounds min_rvar_incdec_eq pivot_and_update_code"
 definition "check'_code = PivotUpdateMinVars.check' eq_idx_for_lvar min_rvar_incdec_eq pivot_and_update_code"
 
 global_interpretation PivotUpdateMinVarsDefault: PivotUpdateMinVars eq_idx_for_lvar min_lvar_not_in_bounds min_rvar_incdec_eq pivot_and_update_code
   rewrites
     "PivotUpdateMinVars.check eq_idx_for_lvar min_lvar_not_in_bounds min_rvar_incdec_eq pivot_and_update_code = check_code" and
     "PivotUpdateMinVars.check' eq_idx_for_lvar min_rvar_incdec_eq pivot_and_update_code = check'_code"
   by (unfold_locales) (simp_all add: check_code_def check'_code_def)
 
 
 definition "assert_code = Assert'.assert assert_bound_code check_code"
 
 global_interpretation Assert'Default: Assert' assert_bound_code check_code
   rewrites
     "Assert'.assert assert_bound_code check_code = assert_code"
   by (unfold_locales, auto simp: assert_code_def)
 
 definition "assert_bound_loop_code = AssertAllState''.assert_bound_loop assert_bound_code"
 definition "assert_all_state_code = AssertAllState''.assert_all_state init_state assert_bound_code check_code"
 definition "assert_all_code = AssertAllState.assert_all assert_all_state_code"
 
 global_interpretation AssertAllStateDefault: AssertAllState'' init_state assert_bound_code check_code
   rewrites
     "AssertAllState''.assert_bound_loop assert_bound_code = assert_bound_loop_code" and
     "AssertAllState''.assert_all_state init_state assert_bound_code check_code = assert_all_state_code" and
     "AssertAllState.assert_all assert_all_state_code = assert_all_code"
   by unfold_locales (simp_all add: assert_bound_loop_code_def assert_all_state_code_def assert_all_code_def)
 
 (* -------------------------------------------------------------------------- *)
 (* Preprocess preprocess  *)
 (* -------------------------------------------------------------------------- *)
 
 primrec
   monom_to_atom:: "QDelta ns_constraint \<Rightarrow> QDelta atom" where
   "monom_to_atom (LEQ_ns l r) = (if (monom_coeff l < 0) then
                                                 (Geq (monom_var l) (r /R monom_coeff l))
                                             else
                                                 (Leq (monom_var l) (r /R monom_coeff l)))"
 | "monom_to_atom (GEQ_ns l r) = (if (monom_coeff l < 0) then
                                                 (Leq (monom_var l) (r /R monom_coeff l))
                                             else
                                                 (Geq (monom_var l) (r /R monom_coeff l)))"
 
 primrec
   qdelta_constraint_to_atom:: "QDelta ns_constraint \<Rightarrow> var \<Rightarrow> QDelta atom" where
   "qdelta_constraint_to_atom (LEQ_ns l r) v = (if (is_monom l) then (monom_to_atom (LEQ_ns l r)) else (Leq v r))"
 | "qdelta_constraint_to_atom (GEQ_ns l r) v = (if (is_monom l) then (monom_to_atom (GEQ_ns l r)) else (Geq v r))"
 
 primrec
   qdelta_constraint_to_atom':: "QDelta ns_constraint \<Rightarrow> var \<Rightarrow> QDelta atom" where
   "qdelta_constraint_to_atom' (LEQ_ns l r) v = (Leq v r)"
 | "qdelta_constraint_to_atom' (GEQ_ns l r) v = (Geq v r)"
 
 fun linear_poly_to_eq:: "linear_poly \<Rightarrow> var \<Rightarrow> eq" where
   "linear_poly_to_eq p v = (v, p)"
 
 datatype 'i istate = IState
   (FirstFreshVariable: var)
   (Tableau: tableau)
   (Atoms: "('i,QDelta) i_atom list")
   (Poly_Mapping: "linear_poly \<rightharpoonup> var")
   (UnsatIndices: "'i list")
 
 primrec zero_satisfies :: "'a :: lrv ns_constraint \<Rightarrow> bool" where
   "zero_satisfies (LEQ_ns l r) \<longleftrightarrow> 0 \<le> r"
 | "zero_satisfies (GEQ_ns l r) \<longleftrightarrow> 0 \<ge> r"
 
  
 lemma zero_satisfies: "poly c = 0 \<Longrightarrow> zero_satisfies c \<Longrightarrow> v \<Turnstile>\<^sub>n\<^sub>s c" 
   by (cases c, auto simp: valuate_zero)
 
 lemma not_zero_satisfies: "poly c = 0 \<Longrightarrow> \<not> zero_satisfies c \<Longrightarrow> \<not> v \<Turnstile>\<^sub>n\<^sub>s c" 
   by (cases c, auto simp: valuate_zero)
 
 fun
   preprocess' :: "('i,QDelta) i_ns_constraint list \<Rightarrow> var \<Rightarrow> 'i istate" where
   "preprocess' [] v = IState v [] [] (\<lambda> p. None) []"
 | "preprocess' ((i,h) # t) v = (let s' = preprocess' t v; p = poly h; is_monom_h = is_monom p;
                          v' = FirstFreshVariable s';
                          t' = Tableau s';
                          a' = Atoms s';
                          m' = Poly_Mapping s';
                          u' = UnsatIndices s' in
                          if is_monom_h then IState v' t'
                            ((i,qdelta_constraint_to_atom h v') # a') m' u'
                          else if p = 0 then
                            if zero_satisfies h then s' else 
                               IState v' t' a' m' (i # u')
                          else (case m' p of Some v \<Rightarrow>
                             IState v' t' ((i,qdelta_constraint_to_atom h v) # a') m' u'
                           | None \<Rightarrow> IState (v' + 1) (linear_poly_to_eq p v' # t')
                            ((i,qdelta_constraint_to_atom h v') # a') (m' (p \<mapsto> v')) u')
 )"
 
 lemma preprocess'_simps: "preprocess' ((i,h) # t) v = (let s' = preprocess' t v; p = poly h; is_monom_h = is_monom p;
                          v' = FirstFreshVariable s';
                          t' = Tableau s';
                          a' = Atoms s';
                          m' = Poly_Mapping s';
                          u' = UnsatIndices s' in
                          if is_monom_h then IState v' t'
                            ((i,monom_to_atom h) # a') m' u'
                          else if p = 0 then
                            if zero_satisfies h then s' else 
                               IState v' t' a' m' (i # u')
                          else (case m' p of Some v \<Rightarrow>
                             IState v' t' ((i,qdelta_constraint_to_atom' h v) # a') m' u'
                           | None \<Rightarrow> IState (v' + 1) (linear_poly_to_eq p v' # t')
                            ((i,qdelta_constraint_to_atom' h v') # a') (m' (p \<mapsto> v')) u')
     )" by (cases h, auto simp add: Let_def split: option.splits)
 
 lemmas preprocess'_code = preprocess'.simps(1) preprocess'_simps
 declare preprocess'_code[code]
 
 text \<open>Normalization of constraints helps to identify same polynomials, e.g., 
   the constraints $x + y \leq 5$ and $-2x-2y \leq -12$ will be normalized
   to $x + y \leq 5$ and $x + y \geq 6$, so that only one slack-variable will
   be introduced for the polynomial $x+y$, and not another one for $-2x-2y$.
   Normalization will take care that the max-var of the polynomial in the constraint
   will have coefficient 1 (if the polynomial is non-zero)\<close>
 
 fun normalize_ns_constraint :: "'a :: lrv ns_constraint \<Rightarrow> 'a ns_constraint" where
   "normalize_ns_constraint (LEQ_ns l r) = (let v = max_var l; c = coeff l v in 
      if c = 0 then LEQ_ns l r else 
      let ic = inverse c in if c < 0 then GEQ_ns (ic *R l) (scaleRat ic r) else LEQ_ns (ic *R l) (scaleRat ic r))" 
 | "normalize_ns_constraint (GEQ_ns l r) = (let v = max_var l; c = coeff l v in 
      if c = 0 then GEQ_ns l r else 
      let ic = inverse c in if c < 0 then LEQ_ns (ic *R l) (scaleRat ic r) else GEQ_ns (ic *R l) (scaleRat ic r))" 
 
 lemma normalize_ns_constraint[simp]: "v \<Turnstile>\<^sub>n\<^sub>s (normalize_ns_constraint c) \<longleftrightarrow> v \<Turnstile>\<^sub>n\<^sub>s (c :: 'a :: lrv ns_constraint)" 
 proof -
   let ?c = "coeff (poly c) (max_var (poly c))" 
   consider (0) "?c = 0" | (pos) "?c > 0" | (neg) "?c < 0" by linarith
   thus ?thesis
   proof cases
     case 0
     thus ?thesis by (cases c, auto)
   next
     case pos
     from pos have id: "a /R ?c \<le> b /R ?c \<longleftrightarrow> (a :: 'a) \<le> b" for a b 
       using scaleRat_leq1 by fastforce
     show ?thesis using pos id by (cases c, auto simp: Let_def valuate_scaleRat id)
   next
     case neg
     from neg have id: "a /R ?c \<le> b /R ?c \<longleftrightarrow> (a :: 'a) \<ge> b" for a b 
       using scaleRat_leq2 by fastforce
     show ?thesis using neg id by (cases c, auto simp: Let_def valuate_scaleRat id)
   qed
 qed
     
 declare normalize_ns_constraint.simps[simp del]
 
 lemma i_satisfies_normalize_ns_constraint[simp]: "Iv \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s (map_prod id normalize_ns_constraint ` cs)
   \<longleftrightarrow> Iv \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s cs" 
   by (cases Iv, force)
 
 
 abbreviation max_var:: "QDelta ns_constraint \<Rightarrow> var" where
   "max_var C \<equiv> Abstract_Linear_Poly.max_var (poly C)"
 
 fun
   start_fresh_variable :: "('i,QDelta) i_ns_constraint list \<Rightarrow> var" where
   "start_fresh_variable [] = 0"
 | "start_fresh_variable ((i,h)#t) = max (max_var h + 1) (start_fresh_variable t)"
 
 
 definition
   preprocess_part_1  :: "('i,QDelta) i_ns_constraint list \<Rightarrow> tableau \<times> (('i,QDelta) i_atom list) \<times> 'i list" where
   "preprocess_part_1 l \<equiv> let start = start_fresh_variable l; is = preprocess' l start in (Tableau is, Atoms is, UnsatIndices is)"
 
 lemma lhs_linear_poly_to_eq [simp]:
   "lhs (linear_poly_to_eq h v) = v"
   by (cases h) auto
 
 lemma rvars_eq_linear_poly_to_eq [simp]:
   "rvars_eq (linear_poly_to_eq h v) = vars h"
   by simp
 
 lemma fresh_var_monoinc:
   "FirstFreshVariable (preprocess' cs start) \<ge> start"
   by (induct cs) (auto simp add: Let_def split: option.splits)
 
 abbreviation vars_constraints where
   "vars_constraints cs \<equiv> \<Union> (set (map vars (map poly cs)))"
 
 lemma start_fresh_variable_fresh:
   "\<forall> var \<in> vars_constraints (flat_list cs). var < start_fresh_variable cs"
   using max_var_max
   by (induct cs, auto simp add: max_def) force+
 
 lemma vars_tableau_vars_constraints:
   "rvars (Tableau (preprocess' cs start)) \<subseteq> vars_constraints (flat_list cs)"
   by (induct cs start rule: preprocess'.induct) (auto simp add: rvars_def Let_def split: option.splits)
 
 lemma lvars_tableau_ge_start:
   "\<forall> var \<in> lvars (Tableau (preprocess' cs start)). var \<ge> start"
   by (induct cs start rule: preprocess'.induct) (auto simp add: Let_def lvars_def fresh_var_monoinc split: option.splits)
 
 lemma rhs_no_zero_tableau_start:
   "0 \<notin> rhs ` set (Tableau (preprocess' cs start))"
   by (induct cs start rule: preprocess'.induct, auto simp add: Let_def rvars_def fresh_var_monoinc split: option.splits)
 
 lemma first_fresh_variable_not_in_lvars:
   "\<forall>var \<in> lvars (Tableau (preprocess' cs start)). FirstFreshVariable (preprocess' cs start) > var"
   by (induct cs start rule: preprocess'.induct) (auto simp add: Let_def lvars_def split: option.splits)
 
 lemma sat_atom_sat_eq_sat_constraint_non_monom:
   assumes "v \<Turnstile>\<^sub>a qdelta_constraint_to_atom h var" "v \<Turnstile>\<^sub>e linear_poly_to_eq (poly h) var" "\<not> is_monom (poly h)"
   shows "v \<Turnstile>\<^sub>n\<^sub>s h"
   using assms
   by (cases h) (auto simp add: satisfies_eq_def split: if_splits)
 
 lemma qdelta_constraint_to_atom_monom:
   assumes "is_monom (poly h)"
   shows "v \<Turnstile>\<^sub>a qdelta_constraint_to_atom h var \<longleftrightarrow> v \<Turnstile>\<^sub>n\<^sub>s h"
 proof (cases h)
   case (LEQ_ns l a)
   then show ?thesis
     using assms
     using monom_valuate[of _ v]
     apply auto
     using scaleRat_leq2[of "a /R monom_coeff l" "v (monom_var l)" "monom_coeff l"]
     using divide_leq1[of "monom_coeff l" "v (monom_var l)" a]
        apply (force, simp add: divide_rat_def)
     using scaleRat_leq1[of "v (monom_var l)" "a /R monom_coeff l" "monom_coeff l"]
     using is_monom_monom_coeff_not_zero[of l]
     using divide_leq[of "monom_coeff l" "v (monom_var l)" a]
     using is_monom_monom_coeff_not_zero[of l]
     by (simp_all add: divide_rat_def)
 next
   case (GEQ_ns l a)
   then show ?thesis
     using assms
     using monom_valuate[of _ v]
     apply auto
     using scaleRat_leq2[of "v (monom_var l)" "a /R monom_coeff l" "monom_coeff l"]
     using divide_geq1[of a "monom_coeff l" "v (monom_var l)"]
        apply (force, simp add: divide_rat_def)
     using scaleRat_leq1[of "a /R monom_coeff l" "v (monom_var l)" "monom_coeff l"]
     using is_monom_monom_coeff_not_zero[of l]
     using divide_geq[of a "monom_coeff l" "v (monom_var l)"]
     using is_monom_monom_coeff_not_zero[of l]
     by (simp_all add: divide_rat_def)
 qed
 
 lemma preprocess'_Tableau_Poly_Mapping_None: "(Poly_Mapping (preprocess' cs start)) p = None
   \<Longrightarrow> linear_poly_to_eq p v \<notin> set (Tableau (preprocess' cs start))"
   by (induct cs start rule: preprocess'.induct, auto simp: Let_def split: option.splits if_splits)
 
 lemma preprocess'_Tableau_Poly_Mapping_Some: "(Poly_Mapping (preprocess' cs start)) p = Some v
   \<Longrightarrow> linear_poly_to_eq p v \<in> set (Tableau (preprocess' cs start))"
   by (induct cs start rule: preprocess'.induct, auto simp: Let_def split: option.splits if_splits)
 
 lemma preprocess'_Tableau_Poly_Mapping_Some': "(Poly_Mapping (preprocess' cs start)) p = Some v
   \<Longrightarrow> \<exists> h. poly h = p \<and> \<not> is_monom (poly h) \<and> qdelta_constraint_to_atom h v \<in> flat (set (Atoms (preprocess' cs start)))"
   by (induct cs start rule: preprocess'.induct, auto simp: Let_def split: option.splits if_splits)
 
 lemma not_one_le_zero_qdelta: "\<not> (1 \<le> (0 :: QDelta))" by code_simp
 
 lemma one_zero_contra[dest,consumes 2]: "1 \<le> x \<Longrightarrow> (x :: QDelta) \<le> 0 \<Longrightarrow> False" 
   using order.trans[of 1 x 0] not_one_le_zero_qdelta by simp
 
 lemma i_preprocess'_sat:
   assumes "(I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set (Atoms (preprocess' s start))" "v \<Turnstile>\<^sub>t Tableau (preprocess' s start)" 
     "I \<inter> set (UnsatIndices (preprocess' s start)) = {}" 
   shows "(I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set s"
   using assms
   by (induct s start rule: preprocess'.induct)
     (auto simp add: Let_def satisfies_atom_set_def satisfies_tableau_def qdelta_constraint_to_atom_monom
       sat_atom_sat_eq_sat_constraint_non_monom 
       split: if_splits option.splits dest!: preprocess'_Tableau_Poly_Mapping_Some zero_satisfies)
 
 lemma preprocess'_sat:
   assumes "v \<Turnstile>\<^sub>a\<^sub>s flat (set (Atoms (preprocess' s start)))" "v \<Turnstile>\<^sub>t Tableau (preprocess' s start)" "set (UnsatIndices (preprocess' s start)) = {}" 
   shows "v \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set s)"
   using i_preprocess'_sat[of UNIV v s start] assms by simp
 
 lemma sat_constraint_valuation:
   assumes "\<forall> var \<in> vars (poly c). v1 var = v2 var"
   shows "v1 \<Turnstile>\<^sub>n\<^sub>s c \<longleftrightarrow> v2 \<Turnstile>\<^sub>n\<^sub>s c"
   using assms
   using valuate_depend
   by (cases c) (force)+
 
 lemma atom_var_first:
   assumes "a \<in> flat (set (Atoms (preprocess' cs start)))" "\<forall> var \<in> vars_constraints (flat_list cs). var < start"
   shows "atom_var a < FirstFreshVariable (preprocess' cs start)"
   using assms
 proof(induct cs arbitrary: a)
   case (Cons hh t a)
   obtain i h where hh: "hh = (i,h)" by force
   let ?s = "preprocess' t start"
   show ?case
   proof(cases "a \<in> flat (set (Atoms ?s))")
     case True
     then show ?thesis
       using Cons(1)[of a] Cons(3) hh
       by (auto simp add: Let_def split: option.splits)
   next
     case False
     consider (monom) "is_monom (poly h)" | (normal) "\<not> is_monom (poly h)" "poly h \<noteq> 0" "(Poly_Mapping ?s) (poly h) = None"
       | (old) var where "\<not> is_monom (poly h)" "poly h \<noteq> 0" "(Poly_Mapping ?s) (poly h) = Some var"
       | (zero) "\<not> is_monom (poly h)" "poly h = 0" 
       by auto
     then show ?thesis
     proof cases
       case monom
       from Cons(3) monom_var_in_vars hh monom
       have "monom_var (poly h) < start" by auto
       moreover from False have "a = qdelta_constraint_to_atom h (FirstFreshVariable (preprocess' t start))"
         using Cons(2) hh monom by (auto simp: Let_def)
       ultimately show ?thesis
         using fresh_var_monoinc[of start t] hh monom
         by (cases a; cases h) (auto simp add: Let_def )
     next
       case normal
       have "a = qdelta_constraint_to_atom h (FirstFreshVariable (preprocess' t start))"
         using False normal Cons(2) hh by (auto simp: Let_def)
       then show ?thesis using hh normal
         by (cases a; cases h) (auto simp add: Let_def )
     next
       case (old var)
       from preprocess'_Tableau_Poly_Mapping_Some'[OF old(3)]
       obtain h' where "poly h' = poly h" "qdelta_constraint_to_atom h' var \<in> flat (set (Atoms ?s))"
         by blast
       from Cons(1)[OF this(2)] Cons(3) this(1) old(1)
       have var: "var < FirstFreshVariable ?s" by (cases h', auto)
       have "a = qdelta_constraint_to_atom h var"
         using False old Cons(2) hh by (auto simp: Let_def)
       then have a: "atom_var a = var" using old by (cases a; cases h; auto simp: Let_def)
       show ?thesis unfolding a hh by (simp add: old Let_def var)
     next
       case zero
       from False show ?thesis using Cons(2) hh zero by (auto simp: Let_def split: if_splits)
     qed
   qed
 qed simp
 
 lemma satisfies_tableau_satisfies_tableau:
   assumes "v1 \<Turnstile>\<^sub>t t" "\<forall> var \<in> tvars t. v1 var = v2 var"
   shows "v2 \<Turnstile>\<^sub>t t"
   using assms
   using valuate_depend[of _ v1 v2]
   by (force simp add: lvars_def rvars_def satisfies_eq_def satisfies_tableau_def)
 
 lemma preprocess'_unsat_indices:
   assumes "i \<in> set (UnsatIndices (preprocess' s start))" 
   shows "\<not> ({i},v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set s" 
   using assms
 proof (induct s start rule: preprocess'.induct)
   case (2 j h t v)
   then show ?case by (auto simp: Let_def not_zero_satisfies split: if_splits option.splits)
 qed simp
 
 lemma preprocess'_unsat:
   assumes "(I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set s" "vars_constraints (flat_list s) \<subseteq> V" "\<forall>var \<in> V. var < start"
   shows "\<exists>v'. (\<forall>var \<in> V. v var = v' var)
     \<and> v' \<Turnstile>\<^sub>a\<^sub>s restrict_to I (set (Atoms (preprocess' s start)))
     \<and> v' \<Turnstile>\<^sub>t Tableau (preprocess' s start)"
   using assms
 proof(induct s)
   case Nil
   show ?case
     by (auto simp add: satisfies_atom_set_def satisfies_tableau_def)
 next
   case (Cons hh t)
   obtain i h where hh: "hh = (i,h)" by force
   from Cons hh obtain v' where
     var: "(\<forall>var\<in>V. v var = v' var)"
     and v'_as: "v' \<Turnstile>\<^sub>a\<^sub>s restrict_to I (set (Atoms (preprocess' t start)))"
     and v'_t: "v' \<Turnstile>\<^sub>t Tableau (preprocess' t start)"
     and vars_h: "vars_constraints [h] \<subseteq> V"
     by auto
   from Cons(2)[unfolded hh]
   have i: "i \<in> I \<Longrightarrow> v \<Turnstile>\<^sub>n\<^sub>s h" by auto
   have "\<forall> var \<in> vars (poly h). v var = v' var"
     using \<open>(\<forall>var\<in>V. v var = v' var)\<close> Cons(3) hh
     by auto
   then have vh_v'h: "v \<Turnstile>\<^sub>n\<^sub>s h \<longleftrightarrow> v' \<Turnstile>\<^sub>n\<^sub>s h"
     by (rule sat_constraint_valuation)
   show ?case
   proof(cases "is_monom (poly h)")
     case True
     then have id: "is_monom (poly h) = True" by simp
     show ?thesis
       unfolding hh preprocess'.simps Let_def id if_True istate.simps istate.sel
     proof (intro exI[of _ v'] conjI v'_t var satisifies_atom_restrict_to_Cons[OF v'_as])
       assume "i \<in> I"
       from i[OF this] var vh_v'h
       show "v' \<Turnstile>\<^sub>a qdelta_constraint_to_atom h (FirstFreshVariable (preprocess' t start))"
         unfolding qdelta_constraint_to_atom_monom[OF True] by auto
     qed
   next
     case False
     then have id: "is_monom (poly h) = False" by simp
     let ?s = "preprocess' t start"
     let ?x = "FirstFreshVariable ?s"
     show ?thesis
     proof (cases "poly h = 0")
       case zero: False
       hence id': "(poly h = 0) = False" by simp
       let ?look = "(Poly_Mapping ?s) (poly h)"
       show ?thesis
       proof (cases ?look)
         case None
         let ?y = "poly h \<lbrace> v'\<rbrace>"
         let ?v' = "v'(?x:=?y)"
         show ?thesis unfolding preprocess'.simps hh Let_def id id' if_False istate.simps istate.sel None option.simps
         proof (rule exI[of _ ?v'], intro conjI satisifies_atom_restrict_to_Cons satisfies_tableau_Cons)
           show vars': "(\<forall>var\<in>V. v var = ?v' var)"
             using \<open>(\<forall>var\<in>V. v var = v' var)\<close>
             using fresh_var_monoinc[of start t]
             using Cons(4)
             by auto
           {
             assume "i \<in> I"
             from vh_v'h i[OF this] False
             show "?v' \<Turnstile>\<^sub>a qdelta_constraint_to_atom h (FirstFreshVariable (preprocess' t start))"
               by (cases h, auto)
           }
           let ?atoms = "restrict_to I (set (Atoms (preprocess' t start)))"
           show "?v' \<Turnstile>\<^sub>a\<^sub>s ?atoms"
             unfolding satisfies_atom_set_def
           proof
             fix a
             assume "a \<in> ?atoms"
             then have "v' \<Turnstile>\<^sub>a a"
               using \<open>v' \<Turnstile>\<^sub>a\<^sub>s ?atoms\<close> hh by (force simp add: satisfies_atom_set_def)
             then show "?v' \<Turnstile>\<^sub>a a"
               using \<open>a \<in> ?atoms\<close> atom_var_first[of a t start]
               using Cons(3) Cons(4)
               by (cases a) auto
           qed
           show "?v' \<Turnstile>\<^sub>e linear_poly_to_eq (poly h) (FirstFreshVariable (preprocess' t start))"
             using Cons(3) Cons(4)
             using valuate_depend[of "poly h" v' "v'(FirstFreshVariable (preprocess' t start) := (poly h) \<lbrace> v' \<rbrace>)"]
             using fresh_var_monoinc[of start t] hh
             by (cases h) (force simp add: satisfies_eq_def)+
           have "FirstFreshVariable (preprocess' t start) \<notin> tvars (Tableau (preprocess' t start))"
             using first_fresh_variable_not_in_lvars[of t start]
             using Cons(3) Cons(4)
             using vars_tableau_vars_constraints[of t start]
             using fresh_var_monoinc[of start t]
             by force
           then show "?v' \<Turnstile>\<^sub>t Tableau (preprocess' t start)"
             using \<open>v' \<Turnstile>\<^sub>t Tableau (preprocess' t start)\<close>
             using satisfies_tableau_satisfies_tableau[of v' "Tableau (preprocess' t start)" ?v']
             by auto
         qed
       next
         case (Some var)
         from preprocess'_Tableau_Poly_Mapping_Some[OF Some]
         have "linear_poly_to_eq (poly h) var \<in> set (Tableau ?s)" by auto
         with v'_t[unfolded satisfies_tableau_def]
         have v'_h_var: "v' \<Turnstile>\<^sub>e linear_poly_to_eq (poly h) var" by auto
         show ?thesis unfolding preprocess'.simps hh Let_def id id' if_False istate.simps istate.sel Some option.simps
         proof (intro exI[of _ v'] conjI var v'_t satisifies_atom_restrict_to_Cons satisfies_tableau_Cons v'_as)
           assume "i \<in> I"
           from vh_v'h i[OF this] False v'_h_var
           show "v' \<Turnstile>\<^sub>a qdelta_constraint_to_atom h var"
             by (cases h, auto simp: satisfies_eq_iff)
         qed
       qed
     next
       case zero: True
       hence id': "(poly h = 0) = True" by simp
       show ?thesis
       proof (cases "zero_satisfies h") 
         case True
         hence id'': "zero_satisfies h = True" by simp
         show ?thesis
           unfolding hh preprocess'.simps Let_def id id' id'' if_True if_False istate.simps istate.sel
           by (intro exI[of _ v'] conjI v'_t var v'_as)
       next
         case False
         hence id'': "zero_satisfies h = False" by simp
         { 
           assume "i \<in> I"
           from i[OF this] not_zero_satisfies[OF zero False] have False by simp
         } note no_I = this
         show ?thesis
           unfolding hh preprocess'.simps Let_def id id' id'' if_True if_False istate.simps istate.sel
         proof (rule Cons(1)[OF _ _ Cons(4)])
           show "(I, v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set t" using Cons(2) by auto
           show "vars_constraints (map snd t) \<subseteq> V" using Cons(3) by force
         qed
       qed
     qed
   qed
 qed
 
 lemma lvars_distinct:
   "distinct (map lhs (Tableau (preprocess' cs start)))"
   using first_fresh_variable_not_in_lvars[where ?'a = 'a]
   by (induct cs, auto simp add: Let_def lvars_def) (force split: option.splits)
 
 lemma normalized_tableau_preprocess': "\<triangle> (Tableau (preprocess' cs (start_fresh_variable cs)))"
 proof -
   let ?s = "start_fresh_variable cs"
   show ?thesis
     using lvars_distinct[of cs ?s]
     using lvars_tableau_ge_start[of cs ?s]
     using vars_tableau_vars_constraints[of cs ?s]
     using start_fresh_variable_fresh[of cs] 
     unfolding normalized_tableau_def Let_def
     by (smt disjoint_iff_not_equal inf.absorb_iff2 inf.strict_order_iff rhs_no_zero_tableau_start subsetD)
 qed
 
 
 text \<open>Improved preprocessing: Deletion. An equation x = p can be deleted from the tableau,
   if x does not occur in the atoms.\<close>
 
 lemma delete_lhs_var: assumes norm: "\<triangle> t" and t: "t = t1 @ (x,p) # t2"
   and t': "t' = t1 @ t2"
   and tv: "tv = (\<lambda> v. upd x (p \<lbrace> \<langle>v\<rangle> \<rbrace>) v)"
   and x_as: "x \<notin> atom_var ` snd ` set as"
 shows "\<triangle> t'" \<comment> \<open>new tableau is normalized\<close>
   "\<langle>w\<rangle> \<Turnstile>\<^sub>t t' \<Longrightarrow> \<langle>tv w\<rangle> \<Turnstile>\<^sub>t t" \<comment> \<open>solution of new tableau is translated to solution of old tableau\<close>
   "(I, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> (I, \<langle>tv w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" \<comment> \<open>solution translation also works for bounds\<close>
   "v \<Turnstile>\<^sub>t t \<Longrightarrow> v \<Turnstile>\<^sub>t t'" \<comment> \<open>solution of old tableau is also solution for new tableau\<close>
 proof -
   have tv: "\<langle>tv w\<rangle> = \<langle>w\<rangle> (x := p \<lbrace> \<langle>w\<rangle> \<rbrace>)" unfolding tv map2fun_def' by auto
   from norm
   show "\<triangle> t'" unfolding t t' normalized_tableau_def by (auto simp: lvars_def rvars_def)
   show "v \<Turnstile>\<^sub>t t \<Longrightarrow> v \<Turnstile>\<^sub>t t'" unfolding t t' satisfies_tableau_def by auto
   from norm have dist: "distinct (map lhs t)" "lvars t \<inter> rvars t = {}"
     unfolding normalized_tableau_def by auto
   from x_as have x_as: "x \<notin> atom_var ` snd ` (set as \<inter> I \<times> UNIV)" by auto
   have "(I, \<langle>tv w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<longleftrightarrow> (I, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" unfolding i_satisfies_atom_set.simps
       satisfies_atom_set_def
   proof (intro ball_cong[OF refl])
     fix a
     assume "a \<in> snd ` (set as \<inter> I \<times> UNIV)"
     with x_as have "x \<noteq> atom_var a" by auto
     then show "\<langle>tv w\<rangle> \<Turnstile>\<^sub>a a = \<langle>w\<rangle> \<Turnstile>\<^sub>a a" unfolding tv
       by (cases a, auto)
   qed
   then show "(I, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> (I, \<langle>tv w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" by blast
   assume w: "\<langle>w\<rangle> \<Turnstile>\<^sub>t t'"
   from dist(2)[unfolded t] have xp: "x \<notin> vars p"
     unfolding lvars_def rvars_def by auto
   {
     fix eq
     assume mem: "eq \<in> set t1 \<union> set t2"
     then have "eq \<in> set t'" unfolding t' by auto
     with w have w: "\<langle>w\<rangle> \<Turnstile>\<^sub>e eq" unfolding satisfies_tableau_def by auto
     obtain y q where eq: "eq = (y,q)" by force
     from mem[unfolded eq] dist(1)[unfolded t] have xy: "x \<noteq> y" by force
     from mem[unfolded eq] dist(2)[unfolded t] have xq: "x \<notin> vars q"
       unfolding lvars_def rvars_def by auto
     from w have "\<langle>tv w\<rangle> \<Turnstile>\<^sub>e eq" unfolding tv eq satisfies_eq_iff using xy xq
       by (auto intro!: valuate_depend)
   }
   moreover
   have "\<langle>tv w\<rangle> \<Turnstile>\<^sub>e (x,p)" unfolding satisfies_eq_iff tv using xp
     by (auto intro!: valuate_depend)
   ultimately
   show "\<langle>tv w\<rangle> \<Turnstile>\<^sub>t t" unfolding t satisfies_tableau_def by auto
 qed
 
 definition pivot_tableau_eq :: "tableau \<Rightarrow> eq \<Rightarrow> tableau \<Rightarrow> var \<Rightarrow> tableau \<times> eq \<times> tableau" where
   "pivot_tableau_eq t1 eq t2 x \<equiv> let eq' = pivot_eq eq x; m = map (\<lambda> e. subst_var_eq x (rhs eq') e) in
     (m t1, eq', m t2)"
 
 lemma pivot_tableau_eq: assumes t: "t = t1 @ eq # t2" "t' = t1' @ eq' # t2'"
   and x: "x \<in> rvars_eq eq" and norm: "\<triangle> t" and pte: "pivot_tableau_eq t1 eq t2 x = (t1',eq',t2')"
 shows "\<triangle> t'" "lhs eq' = x" "(v :: 'a :: lrv valuation) \<Turnstile>\<^sub>t t' \<longleftrightarrow> v \<Turnstile>\<^sub>t t"
 proof -
   let ?s = "\<lambda> t. State t undefined undefined undefined undefined undefined"
   let ?y = "lhs eq"
   have yl: "?y \<in> lvars t" unfolding t lvars_def by auto
   from norm have eq_t12: "?y \<notin> lhs ` (set t1 \<union> set t2)"
     unfolding normalized_tableau_def t lvars_def by auto
   have eq: "eq_for_lvar_code t ?y = eq"
     by (metis (mono_tags, lifting) EqForLVarDefault.eq_for_lvar Un_insert_right eq_t12
         image_iff insert_iff list.set(2) set_append t(1) yl)
   have *: "(?y, b) \<in> set t1 \<Longrightarrow> ?y \<in> lhs ` (set t1)" for b t1
     by (metis image_eqI lhs.simps)
   have pivot: "pivot_tableau_code ?y x t = t'"
     unfolding Pivot'Default.pivot_tableau_def Let_def eq using pte[symmetric]
     unfolding t pivot_tableau_eq_def Let_def using eq_t12 by (auto dest!: *)
   note thms = Pivot'Default.pivot_vars' Pivot'Default.pivot_tableau
   note thms = thms[unfolded Pivot'Default.pivot_def, of "?s t", simplified,
       OF norm yl, unfolded eq, OF x, unfolded pivot]
   from thms(1) thms(2)[of v] show "\<triangle> t'" "v \<Turnstile>\<^sub>t t' \<longleftrightarrow> v \<Turnstile>\<^sub>t t" by auto
   show "lhs eq' = x" using pte[symmetric]
     unfolding t pivot_tableau_eq_def Let_def pivot_eq_def by auto
 qed
 
 function preprocess_opt :: "var set \<Rightarrow> tableau \<Rightarrow> tableau \<Rightarrow> tableau \<times> ((var,'a :: lrv)mapping \<Rightarrow> (var,'a)mapping)" where
   "preprocess_opt X t1 [] = (t1,id)"
 | "preprocess_opt X t1 ((x,p) # t2) = (if x \<notin> X then
     case preprocess_opt X t1 t2 of (t,tv) \<Rightarrow> (t, (\<lambda> v. upd x (p \<lbrace> \<langle>v\<rangle> \<rbrace>) v) o tv)
     else case find (\<lambda> x. x \<notin> X) (Abstract_Linear_Poly.vars_list p) of
      None \<Rightarrow> preprocess_opt X ((x,p) # t1) t2
    | Some y \<Rightarrow> case pivot_tableau_eq t1 (x,p) t2 y of
       (tt1,(z,q),tt2) \<Rightarrow> case preprocess_opt X tt1 tt2 of (t,tv) \<Rightarrow> (t, (\<lambda> v. upd z (q \<lbrace> \<langle>v\<rangle> \<rbrace>) v) o tv))"
   by pat_completeness auto
 
 termination by (relation "measure (\<lambda> (X,t1,t2). length t2)", auto simp: pivot_tableau_eq_def Let_def)
 
 lemma preprocess_opt: assumes "X = atom_var ` snd ` set as"
   "preprocess_opt X t1 t2 = (t',tv)" "\<triangle> t" "t = rev t1 @ t2"
 shows "\<triangle> t'"
   "(\<langle>w\<rangle> :: 'a :: lrv valuation) \<Turnstile>\<^sub>t t' \<Longrightarrow> \<langle>tv w\<rangle> \<Turnstile>\<^sub>t t"
   "(I, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> (I, \<langle>tv w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as"
   "v \<Turnstile>\<^sub>t t \<Longrightarrow> (v :: 'a valuation) \<Turnstile>\<^sub>t t'"
   using assms
 proof (atomize(full), induct X t1 t2 arbitrary: t tv w rule: preprocess_opt.induct)
   case (1 X t1 t tv)
   then show ?case by (auto simp: normalized_tableau_def lvars_def rvars_def satisfies_tableau_def
         simp flip: rev_map)
 next
   case (2 X t1 x p t2 t tv w)
   note IH = 2(1-3)
   note X = 2(4)
   note res = 2(5)
   have norm: "\<triangle> t" by fact
   have t: "t = rev t1 @ (x, p) # t2" by fact
   show ?case
   proof (cases "x \<in> X")
     case False
     with res obtain tv' where res: "preprocess_opt X t1 t2 = (t', tv')" and
       tv: "tv = (\<lambda>v. Mapping.update x (p \<lbrace> \<langle>v\<rangle> \<rbrace>) v) o tv'"
       by (auto split: prod.splits)
     note delete = delete_lhs_var[OF norm t refl refl False[unfolded X]]
     note IH = IH(1)[OF False X res delete(1) refl]
     from delete(2)[of "tv' w"] delete(3)[of I "tv' w"] delete(4)[of v] IH[of w]
     show ?thesis unfolding tv o_def
       by auto
   next
     case True
     then have "\<not> x \<notin> X" by simp
     note IH = IH(2-3)[OF this]
     show ?thesis
     proof (cases "find (\<lambda>x. x \<notin> X) (Abstract_Linear_Poly.vars_list p)")
       case None
       with res True have pre: "preprocess_opt X ((x, p) # t1) t2 = (t', tv)" by auto
       from t have t: "t = rev ((x, p) # t1) @ t2" by simp
       from IH(1)[OF None X pre norm t]
       show ?thesis .
     next
       case (Some z)
       from Some[unfolded find_Some_iff] have zX: "z \<notin> X" and "z \<in> set (Abstract_Linear_Poly.vars_list p)"
         unfolding set_conv_nth by auto
       then have z: "z \<in> rvars_eq (x, p)" by (simp add: set_vars_list)
       obtain tt1 z' q tt2 where pte: "pivot_tableau_eq t1 (x, p) t2 z = (tt1,(z',q),tt2)"
         by (cases "pivot_tableau_eq t1 (x, p) t2 z", auto)
       then have pte_rev: "pivot_tableau_eq (rev t1) (x, p) t2 z = (rev tt1,(z',q),tt2)"
         unfolding pivot_tableau_eq_def Let_def by (auto simp: rev_map)
       note eq = pivot_tableau_eq[OF t refl z norm pte_rev]
       then have z': "z' = z" by auto
       note eq = eq(1,3)[unfolded z']
       note pte = pte[unfolded z']
       note pte_rev = pte_rev[unfolded z']
       note delete = delete_lhs_var[OF eq(1) refl refl refl zX[unfolded X]]
       from res[unfolded preprocess_opt.simps Some option.simps pte] True
       obtain tv' where res: "preprocess_opt X tt1 tt2 = (t', tv')" and
         tv: "tv = (\<lambda>v. Mapping.update z (q \<lbrace> \<langle>v\<rangle> \<rbrace>) v) o tv'"
         by (auto split: prod.splits)
       note IH = IH(2)[OF Some, unfolded pte, OF refl refl refl X res delete(1) refl]
       from IH[of w] delete(2)[of "tv' w"] delete(3)[of I "tv' w"] delete(4)[of v] show ?thesis
         unfolding tv o_def eq(2) by auto
     qed
   qed
 qed
 
 definition "preprocess_part_2 as t = preprocess_opt (atom_var ` snd ` set as) [] t"
 
 lemma preprocess_part_2: assumes "preprocess_part_2 as t = (t',tv)" "\<triangle> t"
   shows "\<triangle> t'"
     "(\<langle>w\<rangle> :: 'a :: lrv valuation) \<Turnstile>\<^sub>t t' \<Longrightarrow> \<langle>tv w\<rangle> \<Turnstile>\<^sub>t t"
     "(I, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> (I, \<langle>tv w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as"
     "v \<Turnstile>\<^sub>t t \<Longrightarrow> (v :: 'a valuation) \<Turnstile>\<^sub>t t'"
   using preprocess_opt[OF refl assms(1)[unfolded preprocess_part_2_def] assms(2)] by auto
 
 definition preprocess :: "('i,QDelta) i_ns_constraint list \<Rightarrow> _ \<times> _ \<times> (_ \<Rightarrow> (var,QDelta)mapping) \<times> 'i list" where
   "preprocess l = (case preprocess_part_1 (map (map_prod id normalize_ns_constraint) l) of 
      (t,as,ui) \<Rightarrow> case preprocess_part_2 as t of (t,tv) \<Rightarrow> (t,as,tv,ui))"
 
 lemma preprocess: 
   assumes id: "preprocess cs = (t, as, trans_v, ui)"
   shows "\<triangle> t" 
   "fst ` set as \<union> set ui \<subseteq> fst ` set cs" 
   "distinct_indices_ns (set cs) \<Longrightarrow> distinct_indices_atoms (set as)" 
   "I \<inter> set ui = {} \<Longrightarrow> (I, \<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow>
        \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<Longrightarrow> (I, \<langle>trans_v v\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set cs" 
   "i \<in> set ui \<Longrightarrow> \<nexists>v. ({i}, v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set cs"
   "\<exists> v. (I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs \<Longrightarrow> \<exists>v'. (I,v') \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<and> v' \<Turnstile>\<^sub>t t" 
 proof -
   define ncs where "ncs = map (map_prod id normalize_ns_constraint) cs" 
   have ncs: "fst ` set ncs = fst ` set cs" "\<And> Iv. Iv \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set ncs \<longleftrightarrow> Iv \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs"
     unfolding ncs_def by force auto
   from id obtain t1 where part1: "preprocess_part_1 ncs = (t1,as,ui)"
     unfolding preprocess_def by (auto simp: ncs_def split: prod.splits)
   from id[unfolded preprocess_def part1 split ncs_def[symmetric]]
   have part_2: "preprocess_part_2 as t1 = (t,trans_v)" 
     by (auto split: prod.splits)
   have norm: "\<triangle> t1" using normalized_tableau_preprocess' part1
     by (auto simp: preprocess_part_1_def Let_def)
   note part_2 = preprocess_part_2[OF part_2 norm]
   show "\<triangle> t" by fact
   have unsat: "(I,\<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t1 \<Longrightarrow> I \<inter> set ui = {} \<Longrightarrow> (I,\<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set ncs" for v 
     using part1[unfolded preprocess_part_1_def Let_def, simplified] i_preprocess'_sat[of I] by blast
   with part_2(2,3) show "I \<inter> set ui = {} \<Longrightarrow> (I,\<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<Longrightarrow> (I,\<langle>trans_v v\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" 
     by (auto simp: ncs)
   from part1[unfolded preprocess_part_1_def Let_def] obtain var where
     as: "as = Atoms (preprocess' ncs var)" and ui: "ui = UnsatIndices (preprocess' ncs var)" by auto
   note min_defs = distinct_indices_atoms_def distinct_indices_ns_def
   have min1: "(distinct_indices_ns (set ncs) \<longrightarrow> (\<forall> k a. (k,a) \<in> set as \<longrightarrow> (\<exists> v p. a = qdelta_constraint_to_atom p v \<and> (k,p) \<in> set ncs
     \<and> (\<not> is_monom (poly p) \<longrightarrow> Poly_Mapping (preprocess' ncs var) (poly p) = Some v)  ))) 
     \<and> fst ` set as \<union> set ui \<subseteq> fst ` set ncs" 
     unfolding as ui
   proof (induct ncs var rule: preprocess'.induct)
     case (2 i h t v)
     hence sub: "fst ` set (Atoms (preprocess' t v)) \<union> set (UnsatIndices (preprocess' t v)) \<subseteq> fst ` set t" by auto
     show ?case 
     proof (intro conjI impI allI, goal_cases)
       show "fst ` set (Atoms (preprocess' ((i, h) # t) v)) \<union> set (UnsatIndices (preprocess' ((i,h) #t) v)) \<subseteq> fst ` set ((i, h) # t)" 
         using sub by (auto simp: Let_def split: option.splits)
     next
       case (1 k a)
       hence min': "distinct_indices_ns (set t)" unfolding min_defs list.simps by blast
       note IH = 2[THEN conjunct1, rule_format, OF min']
       show ?case
       proof (cases "(k,a) \<in> set (Atoms (preprocess' t v))")
         case True
         from IH[OF this] show ?thesis  
           by (force simp: Let_def split: option.splits if_split) 
       next
         case new: False
         with 1(2) have ki: "k = i" by (auto simp: Let_def split: if_splits option.splits)
         show ?thesis 
         proof (cases "is_monom (poly h)")
           case True
           thus ?thesis using new 1(2) by (auto simp: Let_def True intro!: exI)
         next    
           case no_monom: False
           thus ?thesis using new 1(2) by (auto simp: Let_def no_monom split: option.splits if_splits intro!: exI)
         qed
       qed
     qed
   qed (auto simp: min_defs)
   then show "fst ` set as \<union> set ui \<subseteq> fst ` set cs" by (auto simp: ncs)
   {
     assume mini: "distinct_indices_ns (set cs)" 
     have mini: "distinct_indices_ns (set ncs)" unfolding distinct_indices_ns_def
     proof (intro impI allI, goal_cases)
       case (1 n1 n2 i)
       from 1(1) obtain c1 where c1: "(i,c1) \<in> set cs" and n1: "n1 = normalize_ns_constraint c1" 
         unfolding ncs_def by auto
       from 1(2) obtain c2 where c2: "(i,c2) \<in> set cs" and n2: "n2 = normalize_ns_constraint c2" 
         unfolding ncs_def by auto
       from mini[unfolded distinct_indices_ns_def, rule_format, OF c1 c2]
       show ?case unfolding n1 n2 
         by (cases c1; cases c2; auto simp: normalize_ns_constraint.simps Let_def)
     qed
     note min = min1[THEN conjunct1, rule_format, OF this]
     show "distinct_indices_atoms (set as)" 
       unfolding distinct_indices_atoms_def
     proof (intro allI impI)
       fix i a b 
       assume a: "(i,a) \<in> set as" and b: "(i,b) \<in> set as" 
       from min[OF a] obtain v p where aa: "a = qdelta_constraint_to_atom p v" "(i, p) \<in> set ncs" 
         "\<not> is_monom (poly p) \<Longrightarrow> Poly_Mapping (preprocess' ncs var) (poly p) = Some v"
         by auto
       from min[OF b] obtain w q where bb: "b = qdelta_constraint_to_atom q w" "(i, q) \<in> set ncs" 
         "\<not> is_monom (poly q) \<Longrightarrow> Poly_Mapping (preprocess' ncs var) (poly q) = Some w"
         by auto
       from mini[unfolded distinct_indices_ns_def, rule_format, OF aa(2) bb(2)]
       have *: "poly p = poly q" "ns_constraint_const p = ns_constraint_const q" by auto
       show "atom_var a = atom_var b \<and> atom_const a = atom_const b" 
       proof (cases "is_monom (poly q)")
         case True
         thus ?thesis unfolding aa(1) bb(1) using * by (cases p; cases q, auto)
       next
         case False
         thus ?thesis unfolding aa(1) bb(1) using * aa(3) bb(3) by (cases p; cases q, auto)
       qed
     qed 
   }
   show "i \<in> set ui \<Longrightarrow> \<nexists>v. ({i}, v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set cs" 
     using preprocess'_unsat_indices[of i ncs] part1 unfolding preprocess_part_1_def Let_def 
     by (auto simp: ncs)
   assume "\<exists> w. (I,w) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" 
   then obtain w where "(I,w) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" by blast
   hence "(I,w) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set ncs" unfolding ncs .
   from preprocess'_unsat[OF this _  start_fresh_variable_fresh, of ncs]
   have "\<exists>v'. (I,v') \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<and> v' \<Turnstile>\<^sub>t t1"
     using part1
     unfolding preprocess_part_1_def Let_def by auto
   then show "\<exists>v'. (I,v') \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<and> v' \<Turnstile>\<^sub>t t"
     using part_2(4) by auto
 qed
 
 interpretation PreprocessDefault: Preprocess preprocess
   by (unfold_locales; rule preprocess, auto)
 
 global_interpretation Solve_exec_ns'Default: Solve_exec_ns' preprocess assert_all_code
   defines solve_exec_ns_code = Solve_exec_ns'Default.solve_exec_ns
   by unfold_locales
 
 (* -------------------------------------------------------------------------- *)
 (* To_ns to_ns from_ns  *)
 (* -------------------------------------------------------------------------- *)
 
 primrec
   constraint_to_qdelta_constraint:: "constraint \<Rightarrow> QDelta ns_constraint list" where
   "constraint_to_qdelta_constraint (LT l r) = [LEQ_ns l (QDelta.QDelta r (-1))]"
 | "constraint_to_qdelta_constraint (GT l r) = [GEQ_ns l (QDelta.QDelta r 1)]"
 | "constraint_to_qdelta_constraint (LEQ l r) = [LEQ_ns l (QDelta.QDelta r 0)]"
 | "constraint_to_qdelta_constraint (GEQ l r) = [GEQ_ns l (QDelta.QDelta r 0)]"
 | "constraint_to_qdelta_constraint (EQ l r) = [LEQ_ns l (QDelta.QDelta r 0), GEQ_ns l (QDelta.QDelta r 0)]"
 | "constraint_to_qdelta_constraint (LTPP l1 l2) = [LEQ_ns (l1 - l2) (QDelta.QDelta 0 (-1))]"
 | "constraint_to_qdelta_constraint (GTPP l1 l2) = [GEQ_ns (l1 - l2) (QDelta.QDelta 0 1)]"
 | "constraint_to_qdelta_constraint (LEQPP l1 l2) = [LEQ_ns (l1 - l2) 0]"
 | "constraint_to_qdelta_constraint (GEQPP l1 l2) = [GEQ_ns (l1 - l2) 0]"
 | "constraint_to_qdelta_constraint (EQPP l1 l2) = [LEQ_ns (l1 - l2) 0, GEQ_ns (l1 - l2) 0]"
 
 primrec
   i_constraint_to_qdelta_constraint:: "'i i_constraint \<Rightarrow> ('i,QDelta) i_ns_constraint list" where
   "i_constraint_to_qdelta_constraint (i,c) = map (Pair i) (constraint_to_qdelta_constraint c)"
 
 definition
   to_ns :: "'i i_constraint list \<Rightarrow> ('i,QDelta) i_ns_constraint list" where
   "to_ns l \<equiv> concat (map i_constraint_to_qdelta_constraint l)"
 
 primrec
   \<delta>0_val :: "QDelta ns_constraint \<Rightarrow> QDelta valuation \<Rightarrow> rat" where
   "\<delta>0_val (LEQ_ns lll rrr) vl = \<delta>0 lll\<lbrace>vl\<rbrace> rrr"
 | "\<delta>0_val (GEQ_ns lll rrr) vl = \<delta>0 rrr lll\<lbrace>vl\<rbrace>"
 
 primrec
   \<delta>0_val_min :: "QDelta ns_constraint list \<Rightarrow> QDelta valuation \<Rightarrow> rat" where
   "\<delta>0_val_min [] vl = 1"
 | "\<delta>0_val_min (h#t) vl = min (\<delta>0_val_min t vl) (\<delta>0_val h vl)"
 
 abbreviation vars_list_constraints where
   "vars_list_constraints cs \<equiv> remdups (concat (map Abstract_Linear_Poly.vars_list (map poly cs)))"
 
 definition
   from_ns ::"(var, QDelta) mapping \<Rightarrow> QDelta ns_constraint list \<Rightarrow> (var, rat) mapping" where
   "from_ns vl cs \<equiv> let \<delta> = \<delta>0_val_min cs \<langle>vl\<rangle> in
       Mapping.tabulate (vars_list_constraints cs) (\<lambda> var. val (\<langle>vl\<rangle> var) \<delta>)"
 
 global_interpretation SolveExec'Default: SolveExec' to_ns from_ns solve_exec_ns_code
   defines solve_exec_code = SolveExec'Default.solve_exec
     and solve_code = SolveExec'Default.solve
 proof unfold_locales
   {
     fix ics :: "'i i_constraint list" and v' and I
     let ?to_ns = "to_ns ics"
     let ?flat = "set ?to_ns"
     assume sat: "(I,\<langle>v'\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s ?flat"
     define cs where "cs = map snd (filter (\<lambda> ic. fst ic \<in> I) ics)"
     define to_ns' where to_ns: "to_ns' = (\<lambda> l. concat (map constraint_to_qdelta_constraint l))"
     show "(I,\<langle>from_ns v' (flat_list ?to_ns)\<rangle>) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set ics"  unfolding i_satisfies_cs.simps
     proof
       let ?listf = "map (\<lambda>C. case C of (LEQ_ns l r) \<Rightarrow> (l\<lbrace>\<langle>v'\<rangle>\<rbrace>, r)
                                     | (GEQ_ns l r) \<Rightarrow> (r, l\<lbrace>\<langle>v'\<rangle>\<rbrace>)
                        )"
       let ?to_ns = "\<lambda> ics. to_ns' (map snd (filter (\<lambda>ic. fst ic \<in> I) ics))"
       let ?list = "?listf (to_ns' cs)"              (* index-filtered list *)
       let ?f_list = "flat_list (to_ns ics)"
       let ?flist = "?listf ?f_list" (* full list *)
       obtain i_list where i_list: "?list = i_list" by force
       obtain f_list where f_list: "?flist = f_list" by force
       have if_list: "set i_list \<subseteq> set f_list" unfolding
           i_list[symmetric] f_list[symmetric] to_ns_def to_ns set_map set_concat cs_def
         by (intro image_mono, force)
       have "\<And> qd1 qd2. (qd1, qd2) \<in> set ?list \<Longrightarrow> qd1 \<le> qd2"
       proof-
         fix qd1 qd2
         assume "(qd1, qd2) \<in> set ?list"
         then show "qd1 \<le> qd2"
           using sat unfolding cs_def
         proof(induct ics)
           case Nil
           then show ?case
             by (simp add: to_ns)
         next
           case (Cons h t)
           obtain i c where h: "h = (i,c)" by force
           from Cons(2) consider (ic) "(qd1,qd2) \<in> set (?listf (?to_ns [(i,c)]))"
             | (t) "(qd1,qd2) \<in> set (?listf (?to_ns t))"
             unfolding to_ns h set_map set_concat by fastforce
           then show ?case
           proof cases
             case t
             from Cons(1)[OF this] Cons(3) show ?thesis unfolding to_ns_def by auto
           next
             case ic
             note ic = ic[unfolded to_ns, simplified]
             from ic have i: "(i \<in> I) = True" by (cases "i \<in> I", auto)
             note ic = ic[unfolded i if_True, simplified]
             from Cons(3)[unfolded h] i have "\<langle>v'\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s set (to_ns' [c])"
               unfolding i_satisfies_ns_constraints.simps unfolding to_ns to_ns_def by force
             with ic show ?thesis by (induct c) (auto simp add: to_ns)
           qed
         qed
       qed
       then have l1: "\<epsilon> > 0 \<Longrightarrow> \<epsilon> \<le> (\<delta>_min ?list) \<Longrightarrow> \<forall>qd1 qd2. (qd1, qd2) \<in> set ?list \<longrightarrow> val qd1 \<epsilon> \<le> val qd2 \<epsilon>" for \<epsilon>
         unfolding i_list
         by (simp add: delta_gt_zero delta_min[of i_list])
       have "\<delta>_min ?flist \<le> \<delta>_min ?list" unfolding f_list i_list
         by (rule delta_min_mono[OF if_list])
       from l1[OF delta_gt_zero this]
       have l1: "\<forall>qd1 qd2. (qd1, qd2) \<in> set ?list \<longrightarrow> val qd1 (\<delta>_min f_list) \<le> val qd2 (\<delta>_min f_list)"
         unfolding f_list .
       have "\<delta>0_val_min (flat_list (to_ns ics)) \<langle>v'\<rangle> = \<delta>_min f_list" unfolding f_list[symmetric]
       proof(induct ics)
         case Nil
         show ?case
           by (simp add: to_ns_def)
       next
         case (Cons h t)
         then show ?case
           by (cases h; cases "snd h") (auto simp add: to_ns_def)
       qed
       then have l2: "from_ns v' ?f_list = Mapping.tabulate (vars_list_constraints ?f_list) (\<lambda> var. val (\<langle>v'\<rangle> var) (\<delta>_min f_list))"
         by (auto simp add: from_ns_def)
       fix c
       assume "c \<in> restrict_to I (set ics)"
       then obtain i where i: "i \<in> I" and mem: "(i,c) \<in> set ics" by auto
       from mem show "\<langle>from_ns v' ?f_list\<rangle> \<Turnstile>\<^sub>c c"
       proof (induct c)
         case (LT lll rrr)
         then have "(lll\<lbrace>\<langle>v'\<rangle>\<rbrace>, (QDelta.QDelta rrr (-1))) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)
         then have "val (lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<le> val (QDelta.QDelta rrr (-1)) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "lll\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars lll"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using LT
             by (auto simp add: comp_def lookup_tabulate restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<le> (val (QDelta.QDelta rrr (-1)) (\<delta>_min f_list))"
           by (auto simp add: valuate_rat_valuate)
         then show ?case
           using delta_gt_zero[of f_list]
           by (simp add: val_def)
       next
         case (GT lll rrr)
         then have "((QDelta.QDelta rrr 1), lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)
         then have "val (lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<ge> val (QDelta.QDelta rrr 1) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "lll\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars lll"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using GT
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<ge> val (QDelta.QDelta rrr 1) (\<delta>_min f_list)"
           using l2
           by (simp add: valuate_rat_valuate)
         then show ?case
           using delta_gt_zero[of f_list]
           by (simp add: val_def)
       next
         case (LEQ lll rrr)
         then have "(lll\<lbrace>\<langle>v'\<rangle>\<rbrace>, (QDelta.QDelta rrr 0) ) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)
         then have "val (lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<le> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "lll\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars lll"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using LEQ
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<le> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)"
           using l2
           by (simp add: valuate_rat_valuate)
         then show ?case
           by (simp add: val_def)
       next
         case (GEQ lll rrr)
         then have "((QDelta.QDelta rrr 0), lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)
         then have "val (lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<ge> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "lll\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars lll"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using GEQ
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<ge> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)"
           using l2
           by (simp add: valuate_rat_valuate)
         then show ?case
           by (simp add: val_def)
       next
         case (EQ lll rrr)
         then have "((QDelta.QDelta rrr 0), lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) \<in> set ?list" and
           "(lll\<lbrace>\<langle>v'\<rangle>\<rbrace>, (QDelta.QDelta rrr 0) ) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)+
         then have "val (lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<ge> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)" and
           "val (lll\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<le> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)"
           using l1
           by simp_all
         moreover
         have "lll\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars lll"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using EQ
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<ge> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)" and
           "lll\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<le> val (QDelta.QDelta rrr 0) (\<delta>_min f_list)"
           using l1
           by (auto simp add: valuate_rat_valuate)
         then show ?case
           by (simp add: val_def)
       next
         case (LTPP ll1 ll2)
         then have "((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>, (QDelta.QDelta 0 (-1)) ) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)
         then have "val ((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<le> val (QDelta.QDelta 0 (-1)) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "(ll1-ll2)\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               (ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars (ll1 - ll2)"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using LTPP
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "(ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<le> val (QDelta.QDelta 0 (-1)) (\<delta>_min f_list)"
           using l1
           by (simp add: valuate_rat_valuate)
         then show ?case
           using delta_gt_zero[of f_list]
           by (simp add: val_def valuate_minus)
       next
         case (GTPP ll1 ll2)
         then have "((QDelta.QDelta 0 1), (ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns)
         then have "val ((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<ge> val (QDelta.QDelta 0 1) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "(ll1-ll2)\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               (ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars (ll1 - ll2)"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using GTPP
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "(ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<ge> val (QDelta.QDelta 0 1) (\<delta>_min f_list)"
           using l1
           by (simp add: valuate_rat_valuate)
         then show ?case
           using delta_gt_zero[of f_list]
           by (simp add: val_def valuate_minus)
       next
         case (LEQPP ll1 ll2)
         then have "((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>, (QDelta.QDelta 0 0) ) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns zero_QDelta_def)
         then have "val ((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<le> val (QDelta.QDelta 0 0) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "(ll1-ll2)\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               (ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars (ll1 - ll2)"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using LEQPP
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "(ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<le> val (QDelta.QDelta 0 0) (\<delta>_min f_list)"
           using l1
           by (simp add: valuate_rat_valuate)
         then show ?case
           using delta_gt_zero[of f_list]
           by (simp add: val_def valuate_minus)
       next
         case (GEQPP ll1 ll2)
         then have "((QDelta.QDelta 0 0), (ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns zero_QDelta_def)
         then have "val ((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<ge> val (QDelta.QDelta 0 0) (\<delta>_min f_list)"
           using l1
           by simp
         moreover
         have "(ll1-ll2)\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               (ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars (ll1 - ll2)"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using GEQPP
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "(ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<ge> val (QDelta.QDelta 0 0) (\<delta>_min f_list)"
           using l1
           by (simp add: valuate_rat_valuate)
         then show ?case
           using delta_gt_zero[of f_list]
           by (simp add: val_def valuate_minus)
       next
         case (EQPP ll1 ll2)
         then have "((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>, (QDelta.QDelta 0 0) ) \<in> set ?list" and
           "((QDelta.QDelta 0 0), (ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) \<in> set ?list" using i unfolding cs_def
           by (force simp add: to_ns zero_QDelta_def)+
         then have "val ((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<ge> val (QDelta.QDelta 0 0) (\<delta>_min f_list)" and
           "val ((ll1-ll2)\<lbrace>\<langle>v'\<rangle>\<rbrace>) (\<delta>_min f_list) \<le> val (QDelta.QDelta 0 0) (\<delta>_min f_list)"
           using l1
           by simp_all
         moreover
         have "(ll1-ll2)\<lbrace>(\<lambda>x. val (\<langle>v'\<rangle> x) (\<delta>_min f_list))\<rbrace> =
               (ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace>"
         proof (rule valuate_depend, rule)
           fix x
           assume "x \<in> vars (ll1 - ll2)"
           then show "val (\<langle>v'\<rangle> x) (\<delta>_min f_list) = \<langle>from_ns v' ?f_list\<rangle> x"
             using l2
             using EQPP
             by (auto simp add: lookup_tabulate comp_def restrict_map_def set_vars_list to_ns_def map2fun_def')
         qed
         ultimately
         have "(ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<ge> val (QDelta.QDelta 0 0) (\<delta>_min f_list)" and
           "(ll1-ll2)\<lbrace>\<langle>from_ns v' ?f_list\<rangle>\<rbrace> \<le> val (QDelta.QDelta 0 0) (\<delta>_min f_list)"
           using l1
           by (auto simp add: valuate_rat_valuate)
         then show ?case
           by (simp add: val_def valuate_minus)
       qed
     qed
   } note sat = this
   fix cs :: "('i \<times> constraint) list" 
   have set_to_ns: "set (to_ns cs) = { (i,n) | i n c. (i,c) \<in> set cs \<and> n \<in> set (constraint_to_qdelta_constraint c)}" 
     unfolding to_ns_def by auto
   show indices: "fst ` set (to_ns cs) = fst ` set cs" 
   proof 
     show "fst ` set (to_ns cs) \<subseteq> fst ` set cs" 
       unfolding set_to_ns by force
     {
       fix i
       assume "i \<in> fst ` set cs" 
       then obtain c where "(i,c) \<in> set cs" by force
       hence "i \<in> fst ` set (to_ns cs)" unfolding set_to_ns by (cases c; force)
     }
     thus "fst ` set cs \<subseteq> fst ` set (to_ns cs)" by blast
   qed
   {
     assume dist: "distinct_indices cs" 
     show "distinct_indices_ns (set (to_ns cs))" unfolding distinct_indices_ns_def
     proof (intro allI impI conjI notI)
       fix n1 n2 i 
       assume "(i,n1) \<in> set (to_ns cs)" "(i,n2) \<in> set (to_ns cs)" 
       then obtain c1 c2 where i: "(i,c1) \<in> set cs" "(i,c2) \<in> set cs" 
         and n: "n1 \<in> set (constraint_to_qdelta_constraint c1)" "n2 \<in> set (constraint_to_qdelta_constraint c2)" 
         unfolding set_to_ns by auto
       from dist 
       have "distinct (map fst cs)" unfolding distinct_indices_def by auto
       with i have c12: "c1 = c2" by (metis eq_key_imp_eq_value) 
       note n = n[unfolded c12]
       show "poly n1 = poly n2" using n by (cases c2, auto)
       show "ns_constraint_const n1 = ns_constraint_const n2" using n by (cases c2, auto)
     qed
   } note mini = this
   fix I mode
   assume unsat: "minimal_unsat_core_ns I (set (to_ns cs))"
   note unsat = unsat[unfolded minimal_unsat_core_ns_def indices]
   hence indices: "I \<subseteq> fst ` set cs" by auto
   show "minimal_unsat_core I cs"
     unfolding minimal_unsat_core_def
   proof (intro conjI indices impI allI, clarify)
     fix v
     assume v: "(I,v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs"
     let ?v = "\<lambda>var. QDelta.QDelta (v var) 0"
     have "(I,?v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s (set (to_ns cs))" using v
     proof(induct cs)
       case (Cons ic cs)
       obtain i c where ic: "ic = (i,c)" by force
       from Cons(2-) ic
       have rec: "(I,v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs" and c: "i \<in> I \<Longrightarrow> v \<Turnstile>\<^sub>c c" by auto
       {
         fix jn
         assume i: "i \<in> I" and "jn \<in> set (to_ns [(i,c)])"
         then have "jn \<in> set (i_constraint_to_qdelta_constraint (i,c))"
           unfolding to_ns_def by auto
         then obtain n where n: "n \<in> set (constraint_to_qdelta_constraint c)"
           and jn: "jn = (i,n)" by force
         from c[OF i] have c: "v \<Turnstile>\<^sub>c c" by force
         from c n jn have "?v \<Turnstile>\<^sub>n\<^sub>s snd jn"
           by (cases c) (auto simp add: less_eq_QDelta_def to_ns_def valuate_valuate_rat valuate_minus zero_QDelta_def)
       } note main = this
       from Cons(1)[OF rec] have IH: "(I,?v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set (to_ns cs)" .
       show ?case unfolding i_satisfies_ns_constraints.simps
       proof (intro ballI)
         fix x
         assume "x \<in> snd ` (set (to_ns (ic # cs)) \<inter> I \<times> UNIV)"
         then consider (1) "x \<in> snd ` (set (to_ns cs) \<inter> I \<times> UNIV)"
           | (2) "x \<in> snd ` (set (to_ns [(i,c)]) \<inter> I \<times> UNIV)"
           unfolding ic to_ns_def by auto
         then show "?v \<Turnstile>\<^sub>n\<^sub>s x"
         proof cases
           case 1
           then show ?thesis using IH by auto
         next
           case 2
           then obtain jn where x: "snd jn = x" and "jn \<in> set (to_ns [(i,c)]) \<inter> I \<times> UNIV"
             by auto
           with main[of jn] show ?thesis unfolding to_ns_def by auto
         qed
       qed
     qed (simp add: to_ns_def)
     with unsat show False unfolding minimal_unsat_core_ns_def by simp blast
   next
     fix J
     assume *: "distinct_indices cs" "J \<subset> I" 
     hence "distinct_indices_ns (set (to_ns cs))" 
       using mini by auto
     with * unsat obtain v where model: "(J, v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set (to_ns cs)" by blast
     define w where "w = Mapping.Mapping (\<lambda> x. Some (v x))"
     have "v = \<langle>w\<rangle>" unfolding w_def map2fun_def
       by (intro ext, transfer, auto)
     with model have model: "(J, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set (to_ns cs)" by auto
     from sat[OF this]
     show " \<exists>v. (J, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs" by blast
   qed
 qed
 
 (* cleanup *)
 
 hide_const (open) le lt LE GE LB UB LI UI LBI UBI UBI_upd le_rat
   inv zero Var add flat flat_list restrict_to look upd
 
 
 
 (* -------------------------------------------------------------------------- *)
 (* Main soundness lemma and executability *)
 (* -------------------------------------------------------------------------- *)
 
 text \<open>Simplex version with indexed constraints as input\<close>
 
 definition simplex_index :: "'i i_constraint list \<Rightarrow> 'i list + (var, rat) mapping" where
   "simplex_index = solve_exec_code"
 
 lemma simplex_index:
   "simplex_index cs = Unsat I \<Longrightarrow> set I \<subseteq> fst ` set cs \<and> \<not> (\<exists> v. (set I, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs) \<and> 
      (distinct_indices cs \<longrightarrow> (\<forall> J \<subset> set I. (\<exists> v. (J, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs)))" \<comment> \<open>minimal unsat core\<close>
   "simplex_index cs = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s (snd ` set cs)" \<comment> \<open>satisfying assingment\<close>
 proof (unfold simplex_index_def)
   assume "solve_exec_code cs = Unsat I"
   from SolveExec'Default.simplex_unsat0[OF this]
   have core: "minimal_unsat_core (set I) cs" by auto
   then show "set I \<subseteq> fst ` set cs \<and> \<not> (\<exists> v. (set I, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs) \<and>
     (distinct_indices cs \<longrightarrow> (\<forall>J\<subset>set I. \<exists>v. (J, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs))"
     unfolding minimal_unsat_core_def by auto
 next
   assume "solve_exec_code cs = Sat v"
   from SolveExec'Default.simplex_sat0[OF this]
   show "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s (snd ` set cs)" .
 qed
 
 text \<open>Simplex version where indices will be created\<close>
 
 definition simplex where "simplex cs = simplex_index (zip [0..<length cs] cs)"
 
 lemma simplex:
   "simplex cs = Unsat I \<Longrightarrow> \<not> (\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s set cs)" \<comment> \<open>unsat of original constraints\<close>
   "simplex cs = Unsat I \<Longrightarrow> set I \<subseteq> {0..<length cs} \<and> \<not> (\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i | i. i \<in> set I})
     \<and> (\<forall>J\<subset>set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i |i. i \<in> J})" \<comment> \<open>minimal unsat core\<close>
   "simplex cs = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set cs"  \<comment> \<open>satisfying assignment\<close>
 proof (unfold simplex_def)
   let ?cs = "zip [0..<length cs] cs"
   assume "simplex_index ?cs = Unsat I"
   from simplex_index(1)[OF this]
   have index: "set I \<subseteq> {0 ..< length cs}" and
     core: "\<nexists>v. v \<Turnstile>\<^sub>c\<^sub>s (snd ` (set ?cs \<inter> set I \<times> UNIV))" 
     "(distinct_indices (zip [0..<length cs] cs) \<longrightarrow> (\<forall> J \<subset> set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s (snd ` (set ?cs \<inter> J \<times> UNIV))))" 
     by (auto simp flip: set_map)
   note core(2)
   also have "distinct_indices (zip [0..<length cs] cs)" 
     unfolding distinct_indices_def set_zip by (auto simp: set_conv_nth)
   also have "(\<forall> J \<subset> set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s (snd ` (set ?cs \<inter> J \<times> UNIV))) =
     (\<forall> J \<subset> set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s { cs ! i | i.  i \<in> J})" using index
     by (intro all_cong1 imp_cong ex_cong1 arg_cong[of _ _ "\<lambda> x. _ \<Turnstile>\<^sub>c\<^sub>s x"] refl, force simp: set_zip)
   finally have core': "(\<forall>J\<subset>set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i |i. i \<in> J}) " .
   note unsat = unsat_mono[OF core(1)]
   show "\<not> (\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s set cs)"
     by (rule unsat, auto simp: set_zip)
   show "set I \<subseteq> {0..<length cs} \<and> \<not> (\<exists> v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i | i. i \<in> set I})
     \<and> (\<forall>J\<subset>set I. \<exists>v. v \<Turnstile>\<^sub>c\<^sub>s {cs ! i |i. i \<in> J})"
     by (intro conjI index core', rule unsat, auto simp: set_zip)
 next
   assume "simplex_index (zip [0..<length cs] cs) = Sat v"
   from simplex_index(2)[OF this]
   show "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set cs" by (auto simp flip: set_map)
 qed
 
 text \<open>check executability\<close>
 
 lemma "case simplex [LTPP (lp_monom 2 1) (lp_monom 3 2 - lp_monom 3 0), GT (lp_monom 1 1) 5]
    of Sat _ \<Rightarrow> True | Unsat _ \<Rightarrow> False"
   by eval
 
 text \<open>check unsat core\<close>
 
 lemma
   "case simplex_index [
     (1 :: int, LT (lp_monom 1 1) 4),
     (2, GTPP (lp_monom 2 1) (lp_monom 1 2)),
     (3, EQPP (lp_monom 1 1) (lp_monom 2 2)),
     (4, GT (lp_monom 2 2) 5),
     (5, GT (lp_monom 3 0) 7)]
     of Sat _ \<Rightarrow> False | Unsat I \<Rightarrow> set I = {1,3,4}" \<comment> \<open>Constraints 1,3,4 are unsat core\<close>
   by eval
 
 end
\ No newline at end of file
diff --git a/thys/Types_Tableaus_and_Goedels_God/AndersonProof.thy b/thys/Types_Tableaus_and_Goedels_God/AndersonProof.thy
--- a/thys/Types_Tableaus_and_Goedels_God/AndersonProof.thy
+++ b/thys/Types_Tableaus_and_Goedels_God/AndersonProof.thy
@@ -1,243 +1,243 @@
 (*<*)
 theory AndersonProof  
 imports IHOML
 begin
-nitpick_params[user_axioms=true, show_all, expect=genuine, format = 4,  atoms e = a b c d]
+nitpick_params[user_axioms=true, show_all, expect=genuine, format = 4,  atoms e = a b c d, timeout=60]
 sledgehammer_params[verbose=true]
 (*>*)
   
 section \<open>Anderson's Alternative\<close>
   
 text\<open> In this final section, we verify Anderson's emendation of G\"odel's argument, as it is presented in the last
 part of the textbook by Fitting (pp. 169-171). \<close>
   
 subsection \<open>General Definitions\<close>
  
 abbreviation existencePredicate::"\<up>\<langle>\<zero>\<rangle>" ("E!") 
   where "E! x  \<equiv> \<lambda>w. (\<^bold>\<exists>\<^sup>Ey. y\<^bold>\<approx>x) w"
   
 consts positiveProperty::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>" ("\<P>")
   
 abbreviation God::"\<up>\<langle>\<zero>\<rangle>" ("G\<^sup>A") where "G\<^sup>A \<equiv> \<lambda>x. \<^bold>\<forall>Y. (\<P> Y) \<^bold>\<leftrightarrow> \<^bold>\<box>(Y x)"
   
 abbreviation Entailment::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<zero>\<rangle>\<rangle>" (infix "\<Rrightarrow>" 60) where
   "X \<Rrightarrow> Y \<equiv>  \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. X z \<^bold>\<rightarrow> Y z)"
   
 subsection \<open>Part I - God's Existence is Possible\<close>  
   
 axiomatization where
   A1a:"\<lfloor>\<^bold>\<forall>X. \<P> (\<^bold>\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X) \<rfloor>" and          \<comment> \<open>Axiom 11.3A\<close>
   A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and   \<comment> \<open>Axiom 11.5\<close>
   T2: "\<lfloor>\<P> G\<^sup>A\<rfloor>"                                 \<comment> \<open>Proposition 11.16\<close>
         
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: axioms are consistent\<close>
     
 theorem T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" 
   using A1a A2 by blast  \<comment> \<open>positive properties are possibly instantiated\<close>  
 theorem T3: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" using T1 T2 by simp  \<comment> \<open>God exists possibly\<close>  
     
     
 subsection \<open>Part II - God's Existence is Necessary if Possible\<close>
         
 text\<open>  \<open>\<P>\<close> now satisfies only one of the stability conditions. But since the argument uses an \emph{S5} logic, 
 the other stability condition is implied. Therefore \<open>\<P>\<close> becomes rigid (see p. 124).  \<close>
 axiomatization where
   A4a: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X)\<rfloor>"      \<comment> \<open>axiom 11.11\<close>
       
 text\<open>  We again postulate our \emph{S5} axioms: \<close>
 axiomatization where
  refl: "reflexive aRel" and
  tran: "transitive aRel" and
  symm: "symmetric aRel"
  
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms consistent\<close>
  
 abbreviation rigidPred::"('t\<Rightarrow>io)\<Rightarrow>io" where
  "rigidPred \<tau> \<equiv> (\<lambda>\<beta>. \<^bold>\<box>((\<lambda>z. \<beta> \<^bold>\<approx> z) \<^bold>\<down>\<tau>)) \<^bold>\<down>\<tau>"
 
 lemma A4b: "\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<not>(\<P> X)\<rfloor>" 
   using A4a symm by auto \<comment> \<open>symmetry is needed (which corresponds to \emph{B} axiom)\<close>
 lemma "\<lfloor>rigidPred \<P>\<rfloor>" 
   using A4a A4b by blast \<comment> \<open>@{text "\<P>"} is therefore rigid in a \emph{B} logic\<close>
 
 text\<open>  Essence, Anderson Version (Definition 11.34) \<close>
 abbreviation essenceOf::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<zero>\<rangle>" ("\<E>\<^sup>A") where
   "\<E>\<^sup>A Y x \<equiv> (\<^bold>\<forall>Z. \<^bold>\<box>(Z x) \<^bold>\<leftrightarrow> Y \<Rrightarrow> Z)"
 
       
 text\<open>  Necessary Existence, Anderson Version (Definition 11.35)  \<close>  
 abbreviation necessaryExistencePred::"\<up>\<langle>\<zero>\<rangle>" ("NE\<^sup>A") 
   where "NE\<^sup>A x  \<equiv> (\<lambda>w. (\<^bold>\<forall>Y.  \<E>\<^sup>A Y x \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E Y) w)"
     
 text\<open>  Theorem 11.36 - If g is God-like, then the property of being God-like is the essence of g. \<close>
 
 text\<open> As shown before, this theorem's proof could be completely automatized for G\"odel's and Fitting's variants.
 For Anderson's version however, we had to provide Isabelle with some help based on the corresponding natural-language proof 
 given by Anderson (see @{cite "anderson90:_some_emend_of_goedel_ontol_proof"} Theorem 2*, p. 296) \<close>
 (*Anderson's Proof: Suppose that g is God-like* and necessarily has a property Q. Then
 by definition (of "God-like*"), that property is positive. But necessarily, if
 Q is positive, then if anything is God-like*, then it has Q -again by the
 definition of "God-like* ," together with the fact that if something has a
 property necessarily, then it has the property. But if a property is positive,
 then it is necessarily positive (Axiom 4). Hence, if Q is positive, then it is
 entailed by being God-like* (by modal logic-as in the original Theorem 2).
 But Q is positive and hence is entailed by being God-like*. Thus we have
 proved that if an entity is God-like* and has a property essentially, then that
 property is entailed by the property of being God-like*.
 Suppose a property Q is entailed by the property of being God-like*. Then
 Q is positive by Axioms 2 and 3* and therefore, since g is God-like*, g has
 Q necessarily (by the definition of "God-like*"). Hence, if something is
 God-like*, it has a property essentially if and only if that property is entailed
 by being God-like-i.e., God-likeness* is an essence* of that thing.
 Q.E.D.*)
 theorem GodIsEssential: "\<lfloor>\<^bold>\<forall>x. G\<^sup>A x \<^bold>\<rightarrow> (\<E>\<^sup>A G\<^sup>A x)\<rfloor>"
 proof -
 {
   fix w
   {
     fix g
     {
       assume "G\<^sup>A g w"
       hence 1: "\<forall>Y. (\<P> Y w) \<longleftrightarrow> (\<^bold>\<box>(Y g)) w" by simp
       {
         fix Q
         from 1 have 2: "(\<P> Q w) \<longleftrightarrow> (\<^bold>\<box>(Q g)) w" by (rule allE)
         have  "(\<^bold>\<box>(Q g)) w \<longleftrightarrow> (G\<^sup>A \<Rrightarrow> Q) w" \<comment> \<open>we need to prove @{text "\<rightarrow>"} and @{text "\<leftarrow>"}\<close>
         proof
             assume "(\<^bold>\<box>(Q g)) w" \<comment> \<open>suppose g is God-like and necessarily has Q\<close>
             hence 3: "(\<P> Q w)" using 2 by simp \<comment> \<open>then Q is positive\<close>
             
             {
               fix u
               have "(\<P> Q u) \<longrightarrow> (\<forall>x. G\<^sup>A x u \<longrightarrow> (\<^bold>\<box>(Q x)) u)" 
                 by auto \<comment> \<open>using the definition of God-like\<close>
               have "(\<P> Q u) \<longrightarrow> (\<forall>x. G\<^sup>A x u \<longrightarrow> ((Q x)) u)" 
                 using refl by auto \<comment> \<open>and using @{text "\<box>(\<phi> x) \<longrightarrow> \<phi> x"}\<close>
             }    
             hence "\<forall>z. (\<P> Q z) \<longrightarrow> (\<forall>x. G\<^sup>A x z \<longrightarrow> Q x z)" by (rule allI)
             hence "\<lfloor>\<P> Q \<^bold>\<rightarrow> (\<^bold>\<forall>x. G\<^sup>A x \<^bold>\<rightarrow> Q x)\<rfloor>"
               by auto \<comment> \<open>if Q is positive, then whatever is God-like has Q\<close>
             hence "\<lfloor>\<^bold>\<box>(\<P> Q \<^bold>\<rightarrow> (\<^bold>\<forall>x. G\<^sup>A x \<^bold>\<rightarrow> Q x))\<rfloor>" by (rule NEC) 
             
             hence "\<lfloor>(\<^bold>\<box>(\<P> Q)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. G\<^sup>A x \<^bold>\<rightarrow> Q x)\<rfloor>" using K by auto
             hence "\<lfloor>(\<^bold>\<box>(\<P> Q)) \<^bold>\<rightarrow> G\<^sup>A \<Rrightarrow> Q\<rfloor>" by simp
             hence "((\<^bold>\<box>(\<P> Q)) \<^bold>\<rightarrow> G\<^sup>A \<Rrightarrow> Q) w" by (rule allE)
             hence 4: "(\<^bold>\<box>(\<P> Q)) w \<longrightarrow> (G\<^sup>A \<Rrightarrow> Q) w" by simp (*if a property is necessarily positive, then it is entailed by being God-like*)
             have "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X)\<rfloor>" by (rule A4a) \<comment> \<open>using axiom 4\<close>
             hence "(\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> (\<^bold>\<box>(\<P> X))) w" by (rule allE)
             hence "\<P> Q w \<longrightarrow> (\<^bold>\<box>(\<P> Q)) w" by (rule allE)
             hence "\<P> Q w \<longrightarrow> (G\<^sup>A \<Rrightarrow> Q) w" using 4 by simp (*if Q is positive, then it is entailed by being God-like*)
             thus "(G\<^sup>A \<Rrightarrow> Q) w" using 3 by (rule mp) \<comment> \<open>@{text "\<rightarrow>"} direction\<close>
          next
            assume 5: "(G\<^sup>A \<Rrightarrow> Q) w" \<comment> \<open>suppose Q is entailed by being God-like\<close>
            have "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" by (rule A2)
            hence "(\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y) w" by (rule allE)
            hence "\<forall>X Y. (\<P> X w \<and> (X \<Rrightarrow> Y) w) \<longrightarrow> \<P> Y w" by simp
            hence "\<forall>Y. (\<P> G\<^sup>A w \<and> (G\<^sup>A \<Rrightarrow> Y) w) \<longrightarrow> \<P> Y w" by (rule allE)
            hence 6: "(\<P> G\<^sup>A w \<and> (G\<^sup>A \<Rrightarrow> Q) w) \<longrightarrow> \<P> Q w" by (rule allE)
            have "\<lfloor>\<P> G\<^sup>A\<rfloor>" by (rule T2)
            hence "\<P> G\<^sup>A w" by (rule allE)
            hence "\<P> G\<^sup>A w \<and> (G\<^sup>A \<Rrightarrow> Q) w" using 5 by (rule conjI)
            from 6 this have "\<P> Q w" by (rule mp) \<comment> \<open>Q is positive by A2 and T2\<close>
            thus "(\<^bold>\<box>(Q g)) w" using 2 by simp (*@{text "\<leftarrow>"} direction *)
          qed    
      } 
      hence  "\<forall>Z. (\<^bold>\<box>(Z g)) w \<longleftrightarrow> (G\<^sup>A \<Rrightarrow> Z) w" by (rule allI)
      hence "(\<^bold>\<forall>Z. \<^bold>\<box>(Z g) \<^bold>\<leftrightarrow>  G\<^sup>A \<Rrightarrow> Z) w" by simp
      hence "\<E>\<^sup>A G\<^sup>A g w" by simp
     }
     hence "G\<^sup>A g w  \<longrightarrow> \<E>\<^sup>A G\<^sup>A g w " by (rule impI)
   }
   hence "\<forall>x. G\<^sup>A x w  \<longrightarrow> \<E>\<^sup>A G\<^sup>A x w "  by (rule allI)
 }
  thus ?thesis by (rule allI) 
 qed
 
 text\<open>  Axiom 11.37 (Anderson's version of 11.25) \<close>
 axiomatization where 
  A5: "\<lfloor>\<P> NE\<^sup>A\<rfloor>"
  
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms consistent\<close>
  
 text\<open>  Theorem 11.38 - Possibilist existence of God implies necessary actualist existence:  \<close> 
 theorem GodExistenceImpliesNecExistence: "\<lfloor>\<^bold>\<exists> G\<^sup>A \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>"
 proof -
 {
   fix w 
   {
     assume "\<exists>x. G\<^sup>A x w"
     then obtain g where 1: "G\<^sup>A g w" ..
     hence "NE\<^sup>A g w" using A5 by blast                  \<comment> \<open>axiom 11.25\<close>
     hence "\<forall>Y. (\<E>\<^sup>A Y g w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E Y) w" by simp
     hence 2: "(\<E>\<^sup>A G\<^sup>A g w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A) w" by (rule allE)
     have  "(\<^bold>\<forall>x. G\<^sup>A x \<^bold>\<rightarrow> (\<E>\<^sup>A G\<^sup>A x)) w" using GodIsEssential
       by (rule allE) \<comment> \<open>GodIsEssential follows from Axioms 11.11 and 11.3B\<close>
     hence  "(G\<^sup>A g \<^bold>\<rightarrow> (\<E>\<^sup>A G\<^sup>A g)) w" by (rule allE)
     hence  "G\<^sup>A g w \<longrightarrow> \<E>\<^sup>A G\<^sup>A g w"  by blast
     from this 1 have 3: "\<E>\<^sup>A G\<^sup>A g w" by (rule mp)
     from 2 3 have "(\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A) w" by (rule mp)
   }
   hence "(\<exists>x. G\<^sup>A x w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A) w" by (rule impI)
   hence "((\<^bold>\<exists>x. G\<^sup>A x) \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A) w" by simp
 }
  thus ?thesis by (rule allI) 
 qed
     
 text\<open>  Some useful rules: \<close>    
 lemma modal_distr: "\<lfloor>\<^bold>\<box>(\<phi> \<^bold>\<rightarrow> \<psi>)\<rfloor> \<Longrightarrow> \<lfloor>(\<^bold>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<psi>)\<rfloor>" by blast
 lemma modal_trans: "(\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<rfloor> \<and> \<lfloor>\<psi> \<^bold>\<rightarrow> \<chi>\<rfloor>) \<Longrightarrow> \<lfloor>\<phi> \<^bold>\<rightarrow> \<chi>\<rfloor>" by simp
 
 text\<open>  Anderson's version of Theorem 11.27  \<close> 
 theorem possExistenceImpliesNecEx: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" \<comment> \<open>local consequence\<close>
 proof -
   have "\<lfloor>\<^bold>\<exists> G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" using GodExistenceImpliesNecExistence 
     by simp \<comment> \<open>follows from Axioms 11.11, 11.25 and 11.3B\<close>
   hence "\<lfloor>\<^bold>\<box>(\<^bold>\<exists> G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A)\<rfloor>" using NEC by simp
   hence 1: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" by (rule modal_distr)
   have 2: "\<lfloor>\<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" using symm tran by metis
   from 1 2 have "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor> \<and> \<lfloor>\<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" by simp
   thus ?thesis by (rule modal_trans)
 qed
 
 lemma T4: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G\<^sup>A\<rfloor> \<longrightarrow> \<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" using possExistenceImpliesNecEx 
     by (rule localImpGlobalCons) \<comment> \<open>global consequence\<close>
   
 text\<open>  Conclusion - Necessary (actualist) existence of God:  \<close>    
 lemma GodNecExists: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<^sup>A\<rfloor>" using T3 T4 by metis    
     
 subsection \<open>Modal Collapse\<close>
   
 text\<open>  Modal collapse is countersatisfiable  \<close>
 lemma "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" nitpick oops
     
 text\<open>  \pagebreak \<close>
     
 section \<open>Conclusion\<close>
 text\<open>  We presented a shallow semantical embedding in Isabelle/HOL for an intensional higher-order modal logic
 (a successor of Montague/Gallin intensional logics) as introduced by M. Fitting in his textbook \emph{Types, Tableaus and 
 G\"odel's God} @{cite "Fitting"}. 
 We subsequently employed this logic to formalise and verify all results (theorems, examples and exercises) relevant 
 to the discussion of G\"odel's ontological argument in the last part of Fitting's book. Three different versions of
 the ontological argument have been considered: the first one by G\"odel himself (respectively, Scott), the second 
 one by Fitting and the last one by Anderson. \<close>
   
 text\<open> By employing an interactive theorem-prover like Isabelle, we were not only able to verify Fitting's results,
 but also to guarantee consistency. We could prove even stronger versions
 of many of the theorems and find better countermodels (i.e. with smaller cardinality) than the ones presented in the book.
 Another interesting aspect was the possibility to explore the implications of alternative formalisations
 for definitions and theorems which shed light on interesting philosophical issues concerning entailment,
 essentialism and free will, which are currently the subject of some follow-up analysis. \<close>
 
 text\<open> The latest developments in \emph{automated theorem proving} allow us to engage in much more experimentation
 during the formalisation and assessment of arguments than ever before. The potential reduction (of several orders of magnitude)
 in the time needed for proving or disproving theorems (compared to pen-and-paper proofs), results in almost real-time
 feedback about the suitability of our speculations. The practical benefits of computer-supported argumentation go beyond
 mere quantitative (easier, faster and more reliable proofs). The advantages are also qualitative, since it fosters a
 different approach to argumentation: We can now work iteratively (by `trial-and-error') on an argument
 by making gradual adjustments to its definitions, axioms and theorems. This allows us to continuously expose and revise 
 the assumptions we indirectly commit ourselves everytime we opt for some particular formalisation.
 \pagebreak
  \<close>
 (*<*)
 end
 (*>*)
diff --git a/thys/Types_Tableaus_and_Goedels_God/FittingProof.thy b/thys/Types_Tableaus_and_Goedels_God/FittingProof.thy
--- a/thys/Types_Tableaus_and_Goedels_God/FittingProof.thy
+++ b/thys/Types_Tableaus_and_Goedels_God/FittingProof.thy
@@ -1,184 +1,184 @@
 (*<*)
 theory FittingProof  
 imports IHOML
 begin
-nitpick_params[user_axioms=true, show_all, expect=genuine, format = 4,  atoms e = a b c d]
+nitpick_params[user_axioms=true, show_all, expect=genuine, format = 4,  atoms e = a b c d, timeout=60]
 sledgehammer_params[verbose=true]
 (*>*)
   
 section \<open>Fitting's Solution\<close>
   
 text\<open> In this section we consider Fitting's solution to the objections raised in his discussion of G\"odel's Argument pp. 164-9, 
 especially the problem of \emph{modal collapse}, which has been metaphysically interpreted as implying a rejection of free will.
 Since we are generally commited to the existence of free will (in a pre-theoretical sense), such a result is
 philosophically unappealing and rather seen as a problem in the argument's formalisation. \<close>
 text\<open> This part of the book still leaves several details unspecified and the reader is thus compelled to fill in the gaps.
 As a result, we came across some premises and theorems allowing for different formalisations and therefore leading to disparate implications.
 Only some of those cases are shown here for illustrative purposes. The options we have chosen here are such that
 they indeed validate the argument (and we assume that they correspond to Fitting's intention. \<close>
   
 subsection \<open>General Definitions\<close>
 
 text\<open>  The following is an existence predicate for our object-language. (We have previously shown it is equivalent to its
  meta-logical counterpart.) \<close>  
 abbreviation existencePredicate::"\<up>\<langle>\<zero>\<rangle>" ("E!") where
   "E! x  \<equiv> (\<lambda>w. (\<^bold>\<exists>\<^sup>Ey. y\<^bold>\<approx>x) w)"
   
 text\<open> Reminder: The `\<open>\<lparr>_\<rparr>\<close>' parenthesis are used to convert an extensional object into its `rigid'
 intensional counterpart (e.g. \<open>\<lparr>\<phi>\<rparr> \<equiv> \<lambda>w. \<phi>\<close>). \<close>
   
 consts positiveProperty::"\<up>\<langle>\<langle>\<zero>\<rangle>\<rangle>" ("\<P>")
 abbreviation God::"\<up>\<langle>\<zero>\<rangle>" ("G") where "G \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> \<lparr>Y x\<rparr>)"
 abbreviation God_star::"\<up>\<langle>\<zero>\<rangle>" ("G*") where "G* \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<leftrightarrow> \<lparr>Y x\<rparr>)"
 
 abbreviation Entailment::"\<up>\<langle>\<langle>\<zero>\<rangle>,\<langle>\<zero>\<rangle>\<rangle>" (infix "\<Rrightarrow>" 60) where
   "X \<Rrightarrow> Y \<equiv>  \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. \<lparr>X z\<rparr> \<^bold>\<rightarrow> \<lparr>Y z\<rparr>)"
   
 subsection \<open>Part I - God's Existence is Possible\<close>  
   
 axiomatization where
   A1a:"\<lfloor>\<^bold>\<forall>X. \<P> (\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X) \<rfloor>" and        \<comment> \<open>axiom 11.3A\<close>
   A1b:"\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<rightharpoondown>X)\<rfloor>" and         \<comment> \<open>axiom 11.3B\<close>
   A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and  \<comment> \<open>axiom 11.5\<close>
   T2: "\<lfloor>\<P> \<down>G\<rfloor>"                               \<comment> \<open>proposition 11.16 (modified)\<close>
         
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: axioms are consistent\<close>
     
 lemma "\<lfloor>D\<rfloor>"  using A1a A1b A2 by blast \<comment> \<open>axioms already imply \emph{D} axiom\<close>
     
 lemma GodDefsAreEquivalent: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<leftrightarrow> G* x\<rfloor>" using A1b by fastforce
 text\<open> \bigbreak \<close>  
 text\<open>  \emph{T1} (Positive properties are possibly instantiated) can be formalised in two different ways: \<close>    
 theorem T1a: "\<lfloor>\<^bold>\<forall>X::\<langle>\<zero>\<rangle>. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>Ez. \<lparr>X z\<rparr>)\<rfloor>" 
   using A1a A2 by blast \<comment> \<open>this is the one used in the book\<close>
 theorem T1b: "\<lfloor>\<^bold>\<forall>X::\<up>\<langle>\<zero>\<rangle>. \<P> \<down>X \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>Ez. X z)\<rfloor>" 
   nitpick oops \<comment> \<open>this one is also possible but not valid so we won't use it\<close>
     
 text\<open>  Some interesting (non-)equivalences: \<close>
 lemma "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E (Q::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<leftrightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<^bold>\<down>Q)\<rfloor>" by simp
 lemma "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E (Q::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<leftrightarrow> ((\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) Q)\<rfloor>"  by simp
 lemma "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E (Q::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<leftrightarrow> ((\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>X) Q)\<rfloor>" by simp
 lemma "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E (Q::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<leftrightarrow> ((\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>Q)\<rfloor>" nitpick oops \<comment> \<open>not equivalent!\<close>
 
     
 text\<open>  \emph{T3} (God exists possibly) can be formalised in two different ways, using a \emph{de re} or a \emph{de dicto} reading. \<close>
 theorem T3_deRe: "\<lfloor>(\<lambda>X. \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G\<rfloor>" using T1a T2 by simp 
 theorem T3_deDicto: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>" nitpick oops    \<comment> \<open>countersatisfiable\<close>      
 
 text\<open>  From the last two theorems, we think \<open>T3_deRe\<close> should be the version originally implied in the book,
  since \<open>T3_deDicto\<close> is not valid (\emph{T1b} were valid but it isn't) \<close>
 lemma assumes T1b: "\<lfloor>\<^bold>\<forall>X. \<P> \<down>X \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>Ez. X z)\<rfloor>" 
    shows T3_deDicto: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>" using assms T2 by simp
     
 subsection \<open>Part II - God's Existence is Necessary if Possible\<close>
   
 text\<open>  In this variant \<open>\<P>\<close> also designates rigidly, as shown in the last section. \<close>
 axiomatization where
       A4a: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X)\<rfloor>"      \<comment> \<open>axiom 11.11\<close>
 lemma A4b: "\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<not>(\<P> X)\<rfloor>" using A1a A1b A4a by blast
     
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms consistent\<close>
 
 abbreviation essenceOf::"\<up>\<langle>\<langle>\<zero>\<rangle>,\<zero>\<rangle>" ("\<E>") where
   "\<E> Y x \<equiv> \<lparr>Y x\<rparr> \<^bold>\<and> (\<^bold>\<forall>Z::\<langle>\<zero>\<rangle>. \<lparr>Z x\<rparr> \<^bold>\<rightarrow> Y \<Rrightarrow> Z)"
   
 text\<open>  Theorem 11.20 - Informal Proposition 5  \<close>
 theorem GodIsEssential: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> ((\<E> \<down>\<^sub>1G) x)\<rfloor>" using A1b by metis
 text\<open>  Theorem 11.21  \<close>
 theorem God_starIsEssential: "\<lfloor>\<^bold>\<forall>x. G* x \<^bold>\<rightarrow> ((\<E> \<down>\<^sub>1G*) x)\<rfloor>" by meson
     
 abbreviation necExistencePred:: "\<up>\<langle>\<zero>\<rangle>" ("NE") where
   "NE x  \<equiv> \<lambda>w. (\<^bold>\<forall>Y.  \<E> Y x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>Ez. \<lparr>Y z\<rparr>)) w"
 text\<open> \bigbreak \<close>
 text\<open>  Informal Axiom 5 \<close>
 axiomatization where
  A5: "\<lfloor>\<P> \<down>NE\<rfloor>"
     
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms consistent\<close>
 
 text\<open>  Reminder: We use \<open>\<down>G\<close> instead of \<open>G\<close> because it is more explicit. See (non-)equivalences above. \<close>
 lemma "\<lfloor>\<^bold>\<exists> G \<^bold>\<leftrightarrow> \<^bold>\<exists> \<^bold>\<down>G\<rfloor>" by simp       
 lemma "\<lfloor>\<^bold>\<exists>\<^sup>E G \<^bold>\<leftrightarrow> \<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>" by simp    
 lemma "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G \<^bold>\<leftrightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>" by simp    
     
 text\<open>  Theorem 11.26 (Informal Proposition 7) - (possibilist) existence of God implies necessary (actualist) existence.  \<close>
 text\<open>  There are two different ways of formalising this theorem. Both of them are proven valid: \<close>
 
 text\<open>  First version: \<close>
 theorem GodExImpliesNecEx_v1: "\<lfloor>\<^bold>\<exists> \<^bold>\<down>G \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>" 
 proof -
 {
   fix w 
   {
     assume "\<exists>x. G x w"
     then obtain g where 1: "G g w" ..
     hence "NE g w" using A5 by auto
     hence "\<forall>Y. (\<E> Y g w) \<longrightarrow> (\<^bold>\<box>(\<^bold>\<exists>\<^sup>Ez. \<lparr>Y z\<rparr>)) w" by simp
     hence "(\<E> (\<lambda>x. G x w) g w) \<longrightarrow> (\<^bold>\<box>(\<^bold>\<exists>\<^sup>Ez. \<lparr>(\<lambda>x. G x w) z\<rparr>)) w" by (rule allE)
     hence 2: "((\<E> \<down>\<^sub>1G) g w) \<longrightarrow> (\<^bold>\<box>(\<^bold>\<exists>\<^sup>E G)) w" using A4b by meson
     have  "(\<^bold>\<forall>x. G x \<^bold>\<rightarrow> ((\<E> \<down>\<^sub>1G) x)) w" using GodIsEssential by (rule allE)
     hence  "(G g \<^bold>\<rightarrow> ((\<E> \<down>\<^sub>1G) g)) w" by (rule allE)
     hence  "G g w \<longrightarrow> (\<E> \<down>\<^sub>1G) g w" by simp
     from this 1 have 3: "(\<E> \<down>\<^sub>1G) g w" by (rule mp)
     from 2 3 have "(\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule mp)
   }
   hence "(\<exists>x. G x w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule impI)
   hence "((\<^bold>\<exists>x. G x) \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by simp
 }
  thus ?thesis by (rule allI) 
 qed
   
 text\<open>  Second version (which can be proven directly by automated tools using the previous version): \<close>
 theorem GodExImpliesNecEx_v2: "\<lfloor>\<^bold>\<exists> \<^bold>\<down>G \<^bold>\<rightarrow> ((\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G)\<rfloor>"
   using A4a GodExImpliesNecEx_v1 by metis
     
     
 text\<open>  In contrast to G\"odel's argument (as presented by Fitting), the following theorems can be proven in logic \emph{K}
  (the \emph{S5} axioms are no longer needed):  \<close>
 
 text\<open>  Theorem 11.27 - Informal Proposition 8  \<close> 
 theorem possExImpliesNecEx_v1: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> \<^bold>\<down>G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>"
   using GodExImpliesNecEx_v1 T3_deRe  by metis
 theorem possExImpliesNecEx_v2: "\<lfloor>(\<lambda>X. \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G \<^bold>\<rightarrow> ((\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G)\<rfloor>"
   using GodExImpliesNecEx_v2 by blast
 
 text\<open>  Corollaries:  \<close>    
 lemma T4_v1:  "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> \<^bold>\<down>G\<rfloor> \<longrightarrow> \<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>"
   using possExImpliesNecEx_v1 by simp
 lemma T4_v2:  "\<lfloor>(\<lambda>X. \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G\<rfloor> \<longrightarrow> \<lfloor>(\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G\<rfloor>"
   using possExImpliesNecEx_v2 by simp
     
     
 subsection \<open>Conclusion (\emph{De Re} and \emph{De Dicto} Reading)\<close>        
     
 text\<open>  Version I - Necessary Existence of God (\emph{de dicto}):  \<close>    
 lemma GodNecExists_v1: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G\<rfloor>"
   using GodExImpliesNecEx_v1 T3_deRe by fastforce \<comment> \<open>corollary 11.28\<close>
 lemma God_starNecExists_v1: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E \<^bold>\<down>G*\<rfloor>"
   using GodNecExists_v1 GodDefsAreEquivalent by simp
 lemma "\<lfloor>\<^bold>\<box>(\<lambda>X. \<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G*\<rfloor>"
   using God_starNecExists_v1 by simp \<comment> \<open>\emph{de dicto} shown here explicitly\<close>
     
 text\<open>  Version II - Necessary Existence of God (\emph{de re})  \<close>    
 lemma GodNecExists_v2: "\<lfloor>(\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G\<rfloor>"
   using T3_deRe T4_v2 by blast
 lemma God_starNecExists_v2: "\<lfloor>(\<lambda>X. \<^bold>\<box>\<^bold>\<exists>\<^sup>E X) \<^bold>\<down>G*\<rfloor>"
   using GodNecExists_v2 GodDefsAreEquivalent by simp
 
 subsection \<open>Modal Collapse\<close>
 text\<open>  Modal collapse is countersatisfiable even in \emph{S5}. Note that countermodels with a cardinality of one 
 for the domain of individuals are found by \emph{Nitpick} (the countermodel shown in the book has cardinality of two). \<close>
     
 lemma "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" 
   nitpick[card 't=1, card i=2] oops \<comment> \<open>countermodel found in \emph{K}\<close>
     
 axiomatization where
    S5: "equivalence aRel" \<comment> \<open>assume \emph{S5} logic\<close>
    
 lemma "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" 
   nitpick[card 't=1, card i=2] oops \<comment> \<open>countermodel also found in \emph{S5}\<close>
 
 text\<open>  \pagebreak \<close>
 (*<*)
 end
 (*>*)
diff --git a/thys/Types_Tableaus_and_Goedels_God/GoedelProof_P2.thy b/thys/Types_Tableaus_and_Goedels_God/GoedelProof_P2.thy
--- a/thys/Types_Tableaus_and_Goedels_God/GoedelProof_P2.thy
+++ b/thys/Types_Tableaus_and_Goedels_God/GoedelProof_P2.thy
@@ -1,298 +1,298 @@
 (*<*)
 theory GoedelProof_P2
 imports IHOML
 begin
-nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
+nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d, timeout=60]
 sledgehammer_params[verbose=true]
 (*>*)
   
 subsection \<open>Part II - God's Existence is Necessary if Possible\<close>
   
 text\<open>  We show here that God's necessary existence follows from its possible existence by adding some
  additional (potentially controversial) assumptions including an \emph{essentialist} premise 
  and the \emph{S5} axioms.
  Further results like monotheism and the rejection of free will (\emph{modal collapse}) are also proved.
   \<close>
 
 subsubsection \<open>General Definitions\<close>
   
 abbreviation existencePredicate::"\<up>\<langle>\<zero>\<rangle>" ("E!") where
   "E! x  \<equiv> (\<lambda>w. (\<^bold>\<exists>\<^sup>Ey. y\<^bold>\<approx>x) w)" 
   
 consts positiveProperty::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>" ("\<P>")
   
 abbreviation God::"\<up>\<langle>\<zero>\<rangle>" ("G") where "G \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> Y x)"
 abbreviation God_star::"\<up>\<langle>\<zero>\<rangle>" ("G*") where
   "G* \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<leftrightarrow> Y x)"
   
 abbreviation Entailment::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<zero>\<rangle>\<rangle>" (infix "\<Rrightarrow>" 60) where 
   "X \<Rrightarrow> Y \<equiv>  \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. X z \<^bold>\<rightarrow> Y z)"
 
 subsubsection \<open>Results from Part I\<close> 
   
 text\<open>  Note that the only use G\"odel makes of axiom A3 is to show that being Godlike is a positive property (\emph{T2}). 
  We follow therefore Scott's proposal and take (\emph{T2}) directly as an axiom:  \<close>  
 axiomatization where
   A1a:"\<lfloor>\<^bold>\<forall>X. \<P> (\<^bold>\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X) \<rfloor>" and          \<comment> \<open>axiom 11.3A\<close>
   A1b:"\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X)\<rfloor>" and           \<comment> \<open>axiom 11.3B\<close>
   A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and    \<comment> \<open>axiom 11.5\<close>
   T2: "\<lfloor>\<P> G\<rfloor>"                                  \<comment> \<open>proposition 11.16\<close>
         
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: axioms are consistent\<close>
     
 lemma "\<lfloor>D\<rfloor>"  using A1a A1b A2 by blast \<comment> \<open>axioms already imply \emph{D} axiom\<close>
     
 lemma GodDefsAreEquivalent: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<leftrightarrow> G* x\<rfloor>" using A1b by fastforce 
     
 theorem T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" 
   using A1a A2 by blast  \<comment> \<open>positive properties are possibly instantiated\<close>  
 theorem T3: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G\<rfloor>" using T1 T2 by simp  \<comment> \<open>God exists possibly\<close>  
     
 subsubsection \<open>Axioms\<close>
         
 text\<open>  \<open>\<P>\<close> satisfies the so-called stability conditions (see @{cite "Fitting"}, p. 124), which means
  it designates rigidly (note that this makes for an \emph{essentialist} assumption). \<close>
 axiomatization where
       A4a: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X)\<rfloor>"      \<comment> \<open>axiom 11.11\<close>
 lemma A4b: "\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<not>(\<P> X)\<rfloor>" using A1a A1b A4a by blast
     
 abbreviation rigidPred::"('t\<Rightarrow>io)\<Rightarrow>io" where
  "rigidPred \<tau> \<equiv> (\<lambda>\<beta>. \<^bold>\<box>((\<lambda>z. \<beta> \<^bold>\<approx> z) \<^bold>\<down>\<tau>)) \<^bold>\<down>\<tau>"
  
 lemma "\<lfloor>rigidPred \<P>\<rfloor>" 
   using A4a A4b by blast \<comment> \<open>@{term "\<P>"} is therefore rigid\<close>
     
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms A1-4 consistent\<close>    
 text\<open> \bigbreak \<close>   
     
 subsubsection \<open>Theorems\<close>
 text\<open>  Remark: Essence is defined here (and in Fitting's variant) in the version of Scott; G\"odel's original version leads to the inconsistency
  reported in @{cite C55 and C60} \<close>
 
 abbreviation essenceOf::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<zero>\<rangle>" ("\<E>") where
   "\<E> Y x \<equiv> (Y x) \<^bold>\<and> (\<^bold>\<forall>Z. Z x \<^bold>\<rightarrow> Y \<Rrightarrow> Z)"   
 abbreviation beingIdenticalTo::"\<zero>\<Rightarrow>\<up>\<langle>\<zero>\<rangle>" ("id") where
   "id x  \<equiv> (\<lambda>y. y\<^bold>\<approx>x)"  \<comment> \<open>note that \emph{id} is a rigid predicate\<close>  
 
 text\<open>  Theorem 11.20 - Informal Proposition 5  \<close>
 theorem GodIsEssential: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)\<rfloor>" using A1b A4a by metis
     
 text\<open>  Theorem 11.21  \<close>
 theorem "\<lfloor>\<^bold>\<forall>x. G* x \<^bold>\<rightarrow> (\<E> G* x)\<rfloor>" using A4a by meson             
     
 text\<open>  Theorem 11.22 - Something can have only one essence:  \<close>
 theorem "\<lfloor>\<^bold>\<forall>X Y z. (\<E> X z \<^bold>\<and> \<E> Y z) \<^bold>\<rightarrow> (X \<Rrightarrow> Y)\<rfloor>" by meson  
   
 text\<open>  Theorem 11.23 - An essence is a complete characterization of an individual:  \<close>
 theorem EssencesCharacterizeCompletely: "\<lfloor>\<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> (X \<Rrightarrow> (id y))\<rfloor>"
 proof (rule ccontr)
   assume "\<not> \<lfloor>\<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> (X \<Rrightarrow> (id y))\<rfloor>"
   hence "\<exists>w. \<not>(( \<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> X \<Rrightarrow> id y) w)" by simp
   then obtain w where "\<not>(( \<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> X \<Rrightarrow> id y) w)" ..
   hence "(\<^bold>\<exists>X y. \<E> X y \<^bold>\<and> \<^bold>\<not>(X \<Rrightarrow> id y)) w" by simp
   hence "\<exists>X y. \<E> X y w \<and> (\<^bold>\<not>(X \<Rrightarrow> id y)) w" by simp
   then obtain P where "\<exists>y. \<E> P y w \<and> (\<^bold>\<not>(P \<Rrightarrow> id y)) w" ..
   then obtain a where 1: "\<E> P a w \<and> (\<^bold>\<not>(P \<Rrightarrow> id a)) w" ..
   hence 2: "\<E> P a w" by (rule conjunct1)
   from 1 have "(\<^bold>\<not>(P \<Rrightarrow> id a)) w" by (rule conjunct2)
   hence "\<exists>x. \<exists>z. w r x \<and>  existsAt z x \<and> P z x \<and> \<not>(a = z)" by blast
   then obtain w1 where "\<exists>z. w r w1 \<and>  existsAt z w1 \<and> P z w1 \<and> \<not>(a = z)" ..
   then obtain b where 3: "w r w1 \<and>  existsAt b w1 \<and> P b w1 \<and> \<not>(a = b)" ..
   hence "w r w1" by simp
   from 3 have "existsAt b w1" by simp
   from 3 have "P b w1" by simp
   from 3 have 4: " \<not>(a = b)" by simp
   from 2 have "P a w" by simp
   from 2 have "\<forall>Y. Y a w \<longrightarrow> ((P \<Rrightarrow> Y) w)" by auto
   hence "(\<^bold>\<rightharpoondown>(id b)) a w \<longrightarrow> (P \<Rrightarrow> (\<^bold>\<rightharpoondown>(id b))) w" by (rule allE)
   hence "\<not>(\<^bold>\<rightharpoondown>(id b)) a w \<or> ((P \<Rrightarrow> (\<^bold>\<rightharpoondown>(id b))) w)" by blast 
   then show False proof
     assume "\<not>(\<^bold>\<rightharpoondown>(id b)) a w"
     hence "a = b" by simp
     thus False using 4 by auto
     next  
     assume "((P \<Rrightarrow> (\<^bold>\<rightharpoondown>(id b))) w)"
     hence "\<forall>x. \<forall>z. (w r x \<and> existsAt z x \<and> P z x) \<longrightarrow> (\<^bold>\<rightharpoondown>(id b)) z x" by blast
     hence "\<forall>z. (w r w1 \<and> existsAt z w1 \<and> P z w1) \<longrightarrow> (\<^bold>\<rightharpoondown>(id b)) z w1" 
         by (rule allE)
     hence "(w r w1 \<and> existsAt b w1 \<and> P b w1) \<longrightarrow> (\<^bold>\<rightharpoondown>(id b)) b w1" by (rule allE)
     hence  "\<not>(w r w1 \<and> existsAt b w1 \<and> P b w1) \<or> (\<^bold>\<rightharpoondown>(id b)) b w1" by simp
     hence "(\<^bold>\<rightharpoondown>(id b)) b w" using 3 by simp
     hence "\<not>(b=b)" by simp
     thus False by simp
   qed
 qed
 
 text\<open>  Definition 11.24 - Necessary Existence (Informal Definition 6):  \<close>  
 abbreviation necessaryExistencePred::"\<up>\<langle>\<zero>\<rangle>" ("NE") 
   where "NE x  \<equiv> (\<lambda>w. (\<^bold>\<forall>Y.  \<E> Y x \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E Y) w)"
 
 text\<open>  Axiom 11.25 (Informal Axiom 5) \<close>
 axiomatization where 
  A5: "\<lfloor>\<P> NE\<rfloor>"
  
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms consistent\<close>
  
 text\<open>  Theorem 11.26 (Informal Proposition 7) - Possibilist existence of God implies necessary actualist existence:  \<close> 
 theorem GodExistenceImpliesNecExistence: "\<lfloor>\<^bold>\<exists> G \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>"
 proof -
 {
   fix w 
   {
     assume "\<exists>x. G x w"
     then obtain g where 1: "G g w" ..
     hence "NE g w" using A5 by auto                     \<comment> \<open>axiom 11.25\<close>
     hence "\<forall>Y. (\<E> Y g w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E Y) w" by simp
     hence 2: "(\<E> G g w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule allE)
     have  "(\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)) w" using GodIsEssential
       by (rule allE)     \<comment> \<open>GodIsEssential follows from Axioms 11.11 and 11.3B\<close>
     hence  "(G g \<^bold>\<rightarrow> (\<E> G g)) w" by (rule allE)
     hence  "G g w \<longrightarrow> \<E> G g w" by simp
     from this 1 have 3: "\<E> G g w" by (rule mp)
     from 2 3 have "(\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule mp)
   }
   hence "(\<exists>x. G x w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule impI)
   hence "((\<^bold>\<exists>x. G x) \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by simp
 }
  thus ?thesis by (rule allI) 
 qed
   
 text\<open>  \emph{Modal collapse} is countersatisfiable (unless we introduce S5 axioms): \<close>
 lemma "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" nitpick oops
   
 text\<open>  We postulate semantic frame conditions for some modal logics. Taken together, reflexivity, transitivity and symmetry
  make for an equivalence relation and therefore an \emph{S5} logic (via \emph{Sahlqvist correspondence}).
  We prefer to postulate them individually here in order to get more detailed information about their relevance 
  in the proofs presented below. \<close>
 axiomatization where
  refl: "reflexive aRel" and
  tran: "transitive aRel" and
  symm: "symmetric aRel"
  
 lemma True nitpick[satisfy] oops \<comment> \<open>model found: axioms still consistent\<close>
 text\<open>  Using an \emph{S5} logic, \emph{modal collapse} (\<open>\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>\<close>) is actually valid (see `More Objections' some pages below) \<close>
     
 text\<open>  We prove some useful inference rules: \<close>    
 lemma modal_distr: "\<lfloor>\<^bold>\<box>(\<phi> \<^bold>\<rightarrow> \<psi>)\<rfloor> \<Longrightarrow> \<lfloor>(\<^bold>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<psi>)\<rfloor>" by blast
 lemma modal_trans: "(\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<rfloor> \<and> \<lfloor>\<psi> \<^bold>\<rightarrow> \<chi>\<rfloor>) \<Longrightarrow> \<lfloor>\<phi> \<^bold>\<rightarrow> \<chi>\<rfloor>" by simp
 
 text\<open>  Theorem 11.27 - Informal Proposition 8. Note that only symmetry and transitivity for the accessibility relation are used. \<close> 
 theorem possExistenceImpliesNecEx: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" \<comment> \<open>local consequence\<close>
 proof -
   have "\<lfloor>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using GodExistenceImpliesNecExistence 
     by simp \<comment> \<open>follows from Axioms 11.11, 11.25 and 11.3B\<close>
   hence "\<lfloor>\<^bold>\<box>(\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G)\<rfloor>" using NEC by simp
   hence 1: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" by (rule modal_distr)
   have 2: "\<lfloor>\<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using symm tran by metis \<comment> \<open>frame conditions\<close>
   from 1 2 have "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor> \<and> \<lfloor>\<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" by simp
   thus ?thesis by (rule modal_trans)
 qed
 
 lemma T4: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G\<rfloor> \<longrightarrow> \<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using possExistenceImpliesNecEx 
     by (rule localImpGlobalCons)  \<comment> \<open>global consequence\<close>
   
 text\<open>  Corollary 11.28 - Necessary (actualist) existence of God (for both definitions); reflexivity is still not used:  \<close>    
 lemma GodNecExists: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using T3 T4 by metis    
 lemma God_starNecExists: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G*\<rfloor>" 
   using GodNecExists GodDefsAreEquivalent by simp
     
 
 subsubsection \<open>Monotheism\<close>
  
 text\<open>  Monotheism for non-normal models (with Leibniz equality) follows directly from God having all and only positive properties:  \<close>
 theorem Monotheism_LeibnizEq: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<^bold>\<forall>y. G y \<^bold>\<rightarrow> (x  \<^bold>\<approx>\<^sup>L y))\<rfloor>" 
   using GodDefsAreEquivalent by simp
     
 text\<open>  Monotheism for normal models is trickier. We need to consider some previous results (p. 162): \<close>
     
 lemma GodExistenceIsValid: "\<lfloor>\<^bold>\<exists>\<^sup>E G\<rfloor>" using GodNecExists refl
   by auto \<comment> \<open>reflexivity is now required by the solver\<close>
         
 text\<open>  Proposition 11.29:  \<close>
 theorem Monotheism_normalModel: "\<lfloor>\<^bold>\<exists>x.\<^bold>\<forall>y. G y \<^bold>\<leftrightarrow> x \<^bold>\<approx> y\<rfloor>"
 proof -
 {
   fix w 
   have "\<lfloor>\<^bold>\<exists>\<^sup>E G\<rfloor>" using GodExistenceIsValid by simp \<comment> \<open>follows from corollary 11.28\<close>
   hence "(\<^bold>\<exists>\<^sup>E G) w" by (rule allE)       
   then obtain g where 1: "existsAt g w \<and> G g w" ..
   hence 2: "\<E> G g w" using GodIsEssential by blast \<comment> \<open>follows from ax. 11.11/11.3B\<close>
   {
     fix y
     have "G y w \<longleftrightarrow> (g \<^bold>\<approx> y) w" proof 
       assume "G y w"
       hence 3: "\<E> G y w" using GodIsEssential by blast      
       have "(\<E> G y \<^bold>\<rightarrow> (G \<Rrightarrow> id y)) w" using EssencesCharacterizeCompletely
         by simp \<comment> \<open>follows from theorem 11.23\<close>
       hence "\<E> G y w \<longrightarrow> ((G \<Rrightarrow> id y) w)" by simp
       from this 3 have "(G \<Rrightarrow> id y) w" by (rule mp) 
       hence "(\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> z \<^bold>\<approx> y)) w" by simp
       hence "\<forall>x. w r x \<longrightarrow> ((\<forall>z. (existsAt z x \<and> G z x) \<longrightarrow> z = y))" by auto
       hence "w r w \<longrightarrow> ((\<forall>z. (existsAt z w \<and> G z w) \<longrightarrow> z = y))" by (rule allE)
       hence "\<forall>z. (w r w \<and> existsAt z w \<and> G z w) \<longrightarrow> z = y" by auto
       hence 4: "(w r w \<and> existsAt g w \<and> G g w) \<longrightarrow> g = y" by (rule allE)
       have "w r w" using refl 
         by simp \<comment> \<open>using frame reflexivity (Axiom M)\<close>
       hence  "w r w \<and> (existsAt g w \<and> G g w)" using 1 by (rule conjI)
       from 4 this have "g = y" by (rule mp)
       thus "(g \<^bold>\<approx> y) w" by simp
     next
       assume "(g \<^bold>\<approx> y) w"
       from this 2 have "\<E> G y w" by simp
       thus "G y w " by (rule conjunct1)
     qed
   }
   hence "\<forall>y. G y w \<longleftrightarrow> (g \<^bold>\<approx> y) w" by (rule allI) 
   hence "\<exists>x. (\<forall>y. G y w \<longleftrightarrow> (x \<^bold>\<approx> y) w)" by (rule exI) 
   hence "(\<^bold>\<exists>x. (\<^bold>\<forall>y. G y \<^bold>\<leftrightarrow> (x \<^bold>\<approx> y))) w" by simp
 }
 thus ?thesis by (rule allI) 
 qed
 text\<open> \bigbreak \<close>  
 text\<open> Corollary 11.30:  \<close>
 lemma GodImpliesExistence: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> E! x\<rfloor>" 
   using GodExistenceIsValid Monotheism_normalModel by metis
 
 subsubsection \<open>Positive Properties are Necessarily Instantiated\<close>
   
 lemma PosPropertiesNecExist: "\<lfloor>\<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E Y\<rfloor>" using GodNecExists A4a
   by meson \<comment> \<open>proposition 11.31: follows from corollary 11.28 and axiom A4a\<close>
  
     
 subsubsection \<open>More Objections\<close>
 text\<open>  Fitting discusses the objection raised by Sobel @{cite "sobel2004logic"}, who argues that G\"odel's axiom system
  is too strong: it implies that whatever is the case is so necessarily, i.e. the modal system collapses (\<open>\<phi> \<longrightarrow> \<box>\<phi>\<close>).
  The \emph{modal collapse} has been philosophically interpreted as implying the absence of free will. \<close>
 
 text\<open>  We start by proving an useful FOL lemma: \<close>  
 lemma useful: "(\<forall>x. \<phi> x \<longrightarrow> \<psi>) \<Longrightarrow> ((\<exists>x. \<phi> x) \<longrightarrow> \<psi>)" by simp
     
 text\<open>  In the context of our S5 axioms, the \emph{modal collapse} becomes valid (pp. 163-4):  \<close>     
 lemma ModalCollapse: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>"
 proof -
   {
   fix w
    {
     fix Q
     have "(\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)) w" using GodIsEssential 
       by (rule allE) \<comment> \<open>follows from Axioms 11.11 and 11.3B\<close>
     hence "\<forall>x. G x w \<longrightarrow> \<E> G x w" by simp
     hence "\<forall>x. G x w \<longrightarrow> (\<^bold>\<forall>Z. Z x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Z z)) w" by force
     hence "\<forall>x. G x w \<longrightarrow> ((\<lambda>y. Q) x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> (\<lambda>y. Q) z)) w" by force
     hence "\<forall>x. G x w \<longrightarrow> (Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w" by simp
     hence 1: "(\<exists>x. G x w) \<longrightarrow> ((Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w)" by (rule useful)
     have "\<exists>x. G x w" using GodExistenceIsValid by auto
     from 1 this have "(Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w" by (rule mp)
     hence "(Q \<^bold>\<rightarrow> \<^bold>\<box>((\<^bold>\<exists>\<^sup>Ez. G z) \<^bold>\<rightarrow> Q)) w" using useful by blast
     hence "(Q \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>\<^sup>Ez. G z) \<^bold>\<rightarrow> \<^bold>\<box>Q)) w" by simp
     hence "(Q \<^bold>\<rightarrow> \<^bold>\<box>Q) w" using GodNecExists by simp
    }
   hence "(\<^bold>\<forall>\<Phi>. \<Phi> \<^bold>\<rightarrow> \<^bold>\<box> \<Phi>) w" by (rule allI)
   }
   thus ?thesis by (rule allI)
 qed
   text\<open>  \pagebreak \<close>
 
 (*<*)
 end
 (*>*)