diff --git a/thys/Affine_Arithmetic/Affine_Form.thy b/thys/Affine_Arithmetic/Affine_Form.thy
--- a/thys/Affine_Arithmetic/Affine_Form.thy
+++ b/thys/Affine_Arithmetic/Affine_Form.thy
@@ -1,1989 +1,1989 @@
 section \<open>Affine Form\<close>
 theory Affine_Form
 imports
   "HOL-Analysis.Multivariate_Analysis"
-  "HOL-Library.Permutation"
+  "HOL-Library.List_Permutation"
   Affine_Arithmetic_Auxiliarities
   Executable_Euclidean_Space
 begin
 
 subsection \<open>Auxiliary developments\<close>
 
 lemma sum_list_mono:
   fixes xs ys::"'a::ordered_ab_group_add list"
   shows
     "length xs = length ys \<Longrightarrow> (\<And>x y. (x, y) \<in> set (zip xs ys) \<Longrightarrow> x \<le> y) \<Longrightarrow>
       sum_list xs \<le> sum_list ys"
   by (induct xs ys rule: list_induct2) (auto simp: algebra_simps intro: add_mono)
 
 lemma
   fixes xs::"'a::ordered_comm_monoid_add list"
   shows sum_list_nonneg: "(\<And>x. x \<in> set xs \<Longrightarrow> x \<ge> 0) \<Longrightarrow> sum_list xs \<ge> 0"
   by (induct xs) (auto intro!: add_nonneg_nonneg)
 
 lemma map_filter:
   "map f (filter (\<lambda>x. P (f x)) xs) = filter P (map f xs)"
   by (induct xs) simp_all
 
 lemma
   map_of_zip_upto2_length_eq_nth:
   assumes "distinct B"
   assumes "i < length B"
   shows "(map_of (zip B [0..<length B]) (B ! i)) = Some i"
 proof -
   have "length [0..<length B] = length B"
     by simp
   from map_of_zip_is_Some[OF this, of i] assms
   have "map_of (zip B [0..<length B]) (B ! i) = Some i"
     using assms by (auto simp: in_set_zip)
   thus ?thesis by simp
 qed
 
 lemma distinct_map_fst_snd_eqD:
   "distinct (map fst xs) \<Longrightarrow> (i, a) \<in> set xs \<Longrightarrow> (i, b) \<in> set xs \<Longrightarrow> a = b"
   by (metis (lifting) map_of_is_SomeI option.inject)
 
 lemma length_filter_snd_zip:
   "length ys = length xs \<Longrightarrow> length (filter (p \<circ> snd) (zip ys xs)) = length (filter p xs)"
   by (induct ys xs rule: list_induct2) (auto )
 
 lemma filter_snd_nth:
   "length ys = length xs \<Longrightarrow> n < length (filter p xs) \<Longrightarrow>
     snd (filter (p \<circ> snd) (zip ys xs) ! n) = filter p xs ! n"
   by (induct ys xs arbitrary: n rule: list_induct2) (auto simp: o_def nth_Cons split: nat.split)
 
 lemma distinct_map_snd_fst_eqD:
   "distinct (map snd xs) \<Longrightarrow> (i, a) \<in> set xs \<Longrightarrow> (j, a) \<in> set xs \<Longrightarrow> i = j"
   by (metis Pair_inject inj_on_contraD snd_conv distinct_map)
 
 lemma map_of_mapk_inj_on_SomeI:
   "inj_on f (fst ` (set t)) \<Longrightarrow> map_of t k = Some x \<Longrightarrow>
     map_of (map (case_prod (\<lambda>k. Pair (f k))) t) (f k) = Some x"
   by (induct t) (auto simp add: inj_on_def dest!: map_of_SomeD split: if_split_asm)
 
 lemma map_abs_nonneg[simp]:
   fixes xs::"'a::ordered_ab_group_add_abs list"
   shows "list_all (\<lambda>x. x \<ge> 0) xs \<Longrightarrow> map abs xs = xs"
   by (induct xs) auto
 
 lemma the_inv_into_image_eq: "inj_on f A \<Longrightarrow> Y \<subseteq> f ` A \<Longrightarrow> the_inv_into A f ` Y = f -` Y \<inter> A"
   using f_the_inv_into_f the_inv_into_f_f[where f = f and A = A]
   by force
 
 lemma image_fst_zip: "length ys = length xs \<Longrightarrow> fst ` set (zip ys xs) = set ys"
   by (metis dom_map_of_conv_image_fst dom_map_of_zip)
 
 lemma inj_on_fst_set_zip_distinct[simp]:
   "distinct xs \<Longrightarrow> length xs = length ys \<Longrightarrow> inj_on fst (set (zip xs ys))"
   by (force simp add: in_set_zip distinct_conv_nth intro!: inj_onI)
 
 lemma mem_greaterThanLessThan_absI:
   fixes x::real
   assumes "abs x < 1"
   shows "x \<in> {-1 <..< 1}"
   using assms by (auto simp: abs_real_def split: if_split_asm)
 
 lemma minus_one_less_divideI: "b > 0 \<Longrightarrow> -b < a \<Longrightarrow> -1 < a / (b::real)"
   by (auto simp: field_simps)
 
 lemma divide_less_oneI: "b > 0 \<Longrightarrow> b > a \<Longrightarrow> a / (b::real) < 1"
   by (auto simp: field_simps)
 
 lemma closed_segment_real:
   fixes a b::real
   shows "closed_segment a b = (if a \<le> b then {a .. b} else {b .. a})" (is "_ = ?if")
 proof safe
   fix x assume "x \<in> closed_segment a b"
   from segment_bound[OF this]
   show "x \<in> ?if" by (auto simp: abs_real_def split: if_split_asm)
 next
   fix x
   assume "x \<in> ?if"
   thus "x \<in> closed_segment a b"
     by (auto simp: closed_segment_def intro!: exI[where x="(x - a)/(b - a)"]
       simp: divide_simps algebra_simps)
 qed
 
 
 subsection \<open>Partial Deviations\<close>
 
 typedef (overloaded) 'a pdevs = "{x::nat \<Rightarrow> 'a::zero. finite {i. x i \<noteq> 0}}"
   \<comment> \<open>TODO: unify with polynomials\<close>
   morphisms pdevs_apply Abs_pdev
   by (auto intro!: exI[where x="\<lambda>x. 0"])
 
 setup_lifting type_definition_pdevs
 
 lemma pdevs_eqI: "(\<And>i. pdevs_apply x i = pdevs_apply y i) \<Longrightarrow> x = y"
   by transfer auto
 
 definition pdevs_val :: "(nat \<Rightarrow> real) \<Rightarrow> 'a::real_normed_vector pdevs \<Rightarrow> 'a"
   where "pdevs_val e x = (\<Sum>i. e i *\<^sub>R pdevs_apply x i)"
 
 definition valuate:: "((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow> 'a set"
   where "valuate x = x ` (UNIV \<rightarrow> {-1 .. 1})"
 
 lemma valuate_ex: "x \<in> valuate f \<longleftrightarrow> (\<exists>e. (\<forall>i. e i \<in> {-1 .. 1}) \<and> x = f e)"
   unfolding valuate_def
   by (auto simp add: valuate_def Pi_iff) blast
 
 instantiation pdevs :: (equal) equal
 begin
 
 definition equal_pdevs::"'a pdevs \<Rightarrow> 'a pdevs \<Rightarrow> bool"
   where "equal_pdevs a b \<longleftrightarrow> a = b"
 
 instance proof qed (simp add: equal_pdevs_def)
 end
 
 
 subsection \<open>Affine Forms\<close>
 
 text \<open>The data structure of affine forms represents particular sets, zonotopes\<close>
 
 type_synonym 'a aform = "'a \<times> 'a pdevs"
 
 
 subsection \<open>Evaluation, Range, Joint Range\<close>
 
 definition aform_val :: "(nat \<Rightarrow> real) \<Rightarrow> 'a::real_normed_vector aform \<Rightarrow> 'a"
   where "aform_val e X = fst X + pdevs_val e (snd X)"
 
 definition Affine ::
     "'a::real_normed_vector aform \<Rightarrow> 'a set"
   where "Affine X = valuate (\<lambda>e. aform_val e X)"
 
 definition Joints ::
     "'a::real_normed_vector aform list \<Rightarrow> 'a list set"
   where "Joints XS = valuate (\<lambda>e. map (aform_val e) XS)"
 
 lemma Joints_nthE:
   assumes "zs \<in> Joints ZS"
   obtains e where
     "\<And>i. i < length zs \<Longrightarrow> zs ! i = aform_val e (ZS ! i)"
     "\<And>i. e i \<in> {-1..1}"
   using assms
   by atomize_elim (auto simp: Joints_def Pi_iff valuate_ex)
 
 lemma Joints_mapE:
   assumes "ys \<in> Joints YS"
   obtains e where
     "ys = map (\<lambda>x. aform_val e x) YS"
     "\<And>i. e i \<in> {-1 .. 1}"
   using assms
   by (force simp: Joints_def valuate_def)
 
 lemma
   zipped_subset_mapped_Elem:
   assumes "xs = map (aform_val e) XS"
   assumes e: "\<And>i. e i \<in> {-1 .. 1}"
   assumes [simp]: "length xs = length XS"
   assumes [simp]: "length ys = length YS"
   assumes "set (zip ys YS) \<subseteq> set (zip xs XS)"
   shows "ys = map (aform_val e) YS"
 proof -
   from assms have ys: "\<And>i. i < length xs \<Longrightarrow> xs ! i = aform_val e (XS ! i)"
     by auto
   from assms have set_eq: "{(ys ! i, YS ! i) |i. i < length ys \<and> i < length YS} \<subseteq>
     {(xs ! i, XS ! i) |i. i < length xs \<and> i < length XS}"
     using assms(2)
     by (auto simp: set_zip)
   hence "\<forall>i<length YS. \<exists>j<length XS. ys ! i = xs ! j \<and> YS ! i = XS ! j"
     by auto
   then obtain j where j: "\<And>i. i < length YS \<Longrightarrow> ys ! i = xs ! (j i)"
     "\<And>i. i < length YS \<Longrightarrow> YS ! i = XS ! (j i)"
     "\<And>i. i < length YS \<Longrightarrow> j i < length XS"
     by metis
   show ?thesis
     using assms
     by (auto simp: Joints_def j ys intro!: exI[where x=e] nth_equalityI)
 qed
 
 lemma Joints_set_zip_subset:
   assumes "xs \<in> Joints XS"
   assumes "length xs = length XS"
   assumes "length ys = length YS"
   assumes "set (zip ys YS) \<subseteq> set (zip xs XS)"
   shows "ys \<in> Joints YS"
 proof -
   from Joints_mapE assms obtain e where
     ys: "xs = map (\<lambda>x. aform_val e x) XS"
     and e: "\<And>i. e i \<in> {-1 .. 1}"
     by blast
   show "ys \<in> Joints YS"
     using e zipped_subset_mapped_Elem[OF ys e assms(2-4)]
     by (auto simp: Joints_def valuate_def intro!: exI[where x=e])
 qed
 
 lemma Joints_set_zip:
   assumes "ys \<in> Joints YS"
   assumes "length xs = length XS"
   assumes "length YS = length XS"
   assumes sets_eq: "set (zip xs XS) = set (zip ys YS)"
   shows "xs \<in> Joints XS"
 proof -
   from assms have "length ys = length YS"
     by (auto simp: Joints_def valuate_def)
   from assms(1) this assms(2) show ?thesis
     by (rule Joints_set_zip_subset) (simp add: assms)
 qed
 
 definition Joints2 ::
     "'a::real_normed_vector aform list \<Rightarrow>'b::real_normed_vector aform \<Rightarrow> ('a list \<times> 'b) set"
   where "Joints2 XS Y = valuate (\<lambda>e. (map (aform_val e) XS, aform_val e Y))"
 
 lemma Joints2E:
   assumes "zs_y \<in> Joints2 ZS Y"
   obtains e where
     "\<And>i. i < length (fst zs_y) \<Longrightarrow> (fst zs_y) ! i = aform_val e (ZS ! i)"
     "snd (zs_y) = aform_val e Y"
     "\<And>i. e i \<in> {-1..1}"
   using assms
   by atomize_elim (auto simp: Joints2_def Pi_iff valuate_ex)
 
 lemma nth_in_AffineI:
   assumes "xs \<in> Joints XS"
   assumes "i < length XS"
   shows "xs ! i \<in> Affine (XS ! i)"
   using assms by (force simp: Affine_def Joints_def valuate_def)
 
 lemma Cons_nth_in_Joints1:
   assumes "xs \<in> Joints XS"
   assumes "i < length XS"
   shows "((xs ! i) # xs) \<in> Joints ((XS ! i) # XS)"
   using assms by (force simp: Joints_def valuate_def)
 
 lemma Cons_nth_in_Joints2:
   assumes "xs \<in> Joints XS"
   assumes "i < length XS"
   assumes "j < length XS"
   shows "((xs ! i) #(xs ! j) # xs) \<in> Joints ((XS ! i)#(XS ! j) # XS)"
   using assms by (force simp: Joints_def valuate_def)
 
 lemma Joints_swap:
   "x#y#xs\<in>Joints (X#Y#XS) \<longleftrightarrow> y#x#xs \<in> Joints (Y#X#XS)"
   by (force simp: Joints_def valuate_def)
 
 lemma Joints_swap_Cons_append:
   "length xs = length XS \<Longrightarrow> x#ys@xs\<in>Joints (X#YS@XS) \<longleftrightarrow> ys@x#xs \<in> Joints (YS@X#XS)"
   by (auto simp: Joints_def valuate_def)
 
 lemma Joints_ConsD:
   "x#xs\<in>Joints (X#XS) \<Longrightarrow> xs \<in> Joints XS"
   by (force simp: Joints_def valuate_def)
 
 lemma Joints_appendD1:
   "ys@xs\<in>Joints (YS@XS) \<Longrightarrow> length xs = length XS \<Longrightarrow> xs \<in> Joints XS"
   by (force simp: Joints_def valuate_def)
 
 lemma Joints_appendD2:
   "ys@xs\<in>Joints (YS@XS) \<Longrightarrow> length ys = length YS \<Longrightarrow> ys \<in> Joints YS"
   by (force simp: Joints_def valuate_def)
 
 lemma Joints_imp_length_eq: "xs \<in> Joints XS \<Longrightarrow> length xs = length XS"
   by (auto simp: Joints_def valuate_def)
 
 lemma Joints_rotate[simp]: "xs@[x] \<in> Joints (XS @[X]) \<longleftrightarrow> x#xs \<in> Joints (X#XS)"
   by (auto simp: Joints_def valuate_def)
 
 
 subsection \<open>Domain\<close>
 
 definition "pdevs_domain x = {i. pdevs_apply x i \<noteq> 0}"
 
 lemma finite_pdevs_domain[intro, simp]: "finite (pdevs_domain x)"
   unfolding pdevs_domain_def by transfer
 
 lemma in_pdevs_domain[simp]: "i \<in> pdevs_domain x \<longleftrightarrow> pdevs_apply x i \<noteq> 0"
   by (auto simp: pdevs_domain_def)
 
 
 subsection \<open>Least Fresh Index\<close>
 
 definition degree::"'a::real_vector pdevs \<Rightarrow> nat"
   where "degree x = (LEAST i. \<forall>j\<ge>i. pdevs_apply x j = 0)"
 
 lemma degree[rule_format, intro, simp]:
   shows "\<forall>j\<ge>degree x. pdevs_apply x j = 0"
   unfolding degree_def
 proof (rule LeastI_ex)
   have "\<And>j. j > Max (pdevs_domain x) \<Longrightarrow> j \<notin> (pdevs_domain x)"
     by (metis Max_less_iff all_not_in_conv less_irrefl_nat finite_pdevs_domain)
   then show "\<exists>xa. \<forall>j\<ge>xa. pdevs_apply x j = 0"
     by (auto intro!: exI[where x="Max (pdevs_domain x) + 1"])
 qed
 
 lemma degree_le:
   assumes d: "\<forall>j \<ge> d. pdevs_apply x j = 0"
   shows "degree x \<le> d"
   unfolding degree_def
   by (rule Least_le) (rule d)
 
 lemma degree_gt: "pdevs_apply x j \<noteq> 0 \<Longrightarrow> degree x > j"
   by auto
 
 lemma pdevs_val_pdevs_domain: "pdevs_val e X = (\<Sum>i\<in>pdevs_domain X. e i *\<^sub>R pdevs_apply X i)"
   by (auto simp: pdevs_val_def intro!: suminf_finite)
 
 lemma pdevs_val_sum_le: "degree X \<le> d \<Longrightarrow> pdevs_val e X = (\<Sum>i < d. e i *\<^sub>R pdevs_apply X i)"
   by (force intro!: degree_gt sum.mono_neutral_cong_left simp: pdevs_val_pdevs_domain)
 
 lemmas pdevs_val_sum = pdevs_val_sum_le[OF order_refl]
 
 lemma pdevs_val_zero[simp]: "pdevs_val (\<lambda>_. 0) x = 0"
   by (auto simp: pdevs_val_sum)
 
 lemma degree_eqI:
   assumes "pdevs_apply x d \<noteq> 0"
   assumes "\<And>j. j > d \<Longrightarrow> pdevs_apply x j = 0"
   shows "degree x = Suc d"
   unfolding eq_iff
   by (auto intro!: degree_gt degree_le assms simp: Suc_le_eq)
 
 lemma finite_degree_nonzero[intro, simp]: "finite {i. pdevs_apply x i \<noteq> 0}"
   by transfer (auto simp: vimage_def Collect_neg_eq)
 
 lemma degree_eq_Suc_max:
   "degree x = (if (\<forall>i. pdevs_apply x i = 0) then 0 else Suc (Max {i. pdevs_apply x i \<noteq> 0}))"
 proof -
   {
     assume "\<And>i. pdevs_apply x i = 0"
     hence ?thesis
       by auto (metis degree_le le_0_eq)
   } moreover {
     fix i assume "pdevs_apply x i \<noteq> 0"
     hence ?thesis
       using Max_in[OF finite_degree_nonzero, of x]
       by (auto intro!: degree_eqI) (metis Max.coboundedI[OF finite_degree_nonzero] in_pdevs_domain
         le_eq_less_or_eq less_asym pdevs_domain_def)
   } ultimately show ?thesis
     by blast
 qed
 
 lemma pdevs_val_degree_cong:
   assumes "b = d"
   assumes "\<And>i. i < degree b \<Longrightarrow> a i = c i"
   shows "pdevs_val a b = pdevs_val c d"
   using assms
   by (auto simp: pdevs_val_sum)
 
 abbreviation degree_aform::"'a::real_vector aform \<Rightarrow> nat"
   where "degree_aform X \<equiv> degree (snd X)"
 
 lemma degree_cong: "(\<And>i. (pdevs_apply x i = 0) = (pdevs_apply y i = 0)) \<Longrightarrow> degree x = degree y"
   unfolding degree_def
   by auto
 
 lemma Least_True_nat[intro, simp]: "(LEAST i::nat. True) = 0"
   by (metis (lifting) One_nat_def less_one not_less_Least not_less_eq)
 
 lemma sorted_list_of_pdevs_domain_eq:
   "sorted_list_of_set (pdevs_domain X) = filter ((\<noteq>) 0 o pdevs_apply X) [0..<degree X]"
   by (auto simp: degree_gt intro!: sorted_distinct_set_unique sorted_filter[of "\<lambda>x. x", simplified])
 
 
 subsection \<open>Total Deviation\<close>
 
 definition tdev::"'a::ordered_euclidean_space pdevs \<Rightarrow> 'a" where
   "tdev x = (\<Sum>i<degree x. \<bar>pdevs_apply x i\<bar>)"
 
 lemma abs_pdevs_val_le_tdev: "e \<in> UNIV \<rightarrow> {-1 .. 1} \<Longrightarrow> \<bar>pdevs_val e x\<bar> \<le> tdev x"
   by (force simp: pdevs_val_sum tdev_def abs_scaleR Pi_iff
     intro!: order_trans[OF sum_abs] sum_mono scaleR_left_le_one_le
     intro: abs_leI)
 
 
 subsection \<open>Binary Pointwise Operations\<close>
 
 definition binop_pdevs_raw::"('a::zero \<Rightarrow> 'b::zero \<Rightarrow> 'c::zero) \<Rightarrow>
     (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'c"
   where "binop_pdevs_raw f x y i = (if x i = 0 \<and> y i = 0 then 0 else f (x i) (y i))"
 
 lemma nonzeros_binop_pdevs_subset:
   "{i. binop_pdevs_raw f x y i \<noteq> 0} \<subseteq> {i. x i \<noteq> 0} \<union> {i. y i \<noteq> 0}"
   by (auto simp: binop_pdevs_raw_def)
 
 lift_definition binop_pdevs::
     "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a::zero pdevs \<Rightarrow> 'b::zero pdevs \<Rightarrow> 'c::zero pdevs"
   is binop_pdevs_raw
   using nonzeros_binop_pdevs_subset
   by (rule finite_subset) auto
 
 lemma pdevs_apply_binop_pdevs[simp]: "pdevs_apply (binop_pdevs f x y) i =
   (if pdevs_apply x i = 0 \<and> pdevs_apply y i = 0 then 0 else f (pdevs_apply x i) (pdevs_apply y i))"
   by transfer (auto simp: binop_pdevs_raw_def)
 
 
 subsection \<open>Addition\<close>
 
 definition add_pdevs::"'a::real_vector pdevs \<Rightarrow> 'a pdevs \<Rightarrow> 'a pdevs"
   where "add_pdevs = binop_pdevs (+)"
 
 lemma pdevs_apply_add_pdevs[simp]:
   "pdevs_apply (add_pdevs X Y) n = pdevs_apply X n + pdevs_apply Y n"
   by (auto simp: add_pdevs_def)
 
 lemma pdevs_val_add_pdevs[simp]:
   fixes x y::"'a::euclidean_space"
   shows "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y"
 proof -
   let ?sum = "\<lambda>m X. \<Sum>i < m. e i *\<^sub>R pdevs_apply X i"
   let ?m = "max (degree X) (degree Y)"
   have "pdevs_val e X + pdevs_val e Y = ?sum (degree X) X + ?sum (degree Y) Y"
     by (simp add: pdevs_val_sum)
   also have "?sum (degree X) X = ?sum ?m X"
     by (rule sum.mono_neutral_cong_left) auto
   also have "?sum (degree Y) Y = ?sum ?m Y"
     by (rule sum.mono_neutral_cong_left) auto
   also have "?sum ?m X + ?sum ?m Y = (\<Sum>i < ?m. e i *\<^sub>R (pdevs_apply X i + pdevs_apply Y i))"
     by (simp add: scaleR_right_distrib sum.distrib)
   also have "\<dots> = (\<Sum>i. e i *\<^sub>R (pdevs_apply X i + pdevs_apply Y i))"
     by (rule suminf_finite[symmetric]) auto
   also have "\<dots> = pdevs_val e (add_pdevs X Y)"
     by (simp add: pdevs_val_def)
   finally show "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y" by simp
 qed
 
 
 subsection \<open>Total Deviation\<close>
 
 lemma tdev_eq_zero_iff: fixes X::"real pdevs" shows "tdev X = 0 \<longleftrightarrow> (\<forall>e. pdevs_val e X = 0)"
   by (force simp add: pdevs_val_sum tdev_def sum_nonneg_eq_0_iff
     dest!: spec[where x="\<lambda>i. if pdevs_apply X i \<ge> 0 then 1 else -1"] split: if_split_asm)
 
 lemma tdev_nonneg[intro, simp]: "tdev X \<ge> 0"
   by (auto simp: tdev_def)
 
 lemma tdev_nonpos_iff[simp]: "tdev X \<le> 0 \<longleftrightarrow> tdev X = 0"
   by (auto simp: order.antisym)
 
 
 subsection \<open>Unary Operations\<close>
 
 definition unop_pdevs_raw::
     "('a::zero \<Rightarrow> 'b::zero) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'b"
   where "unop_pdevs_raw f x i = (if x i = 0 then 0 else f (x i))"
 
 lemma nonzeros_unop_pdevs_subset: "{i. unop_pdevs_raw f x i \<noteq> 0} \<subseteq> {i. x i \<noteq> 0}"
   by (auto simp: unop_pdevs_raw_def)
 
 lift_definition unop_pdevs::
     "('a \<Rightarrow> 'b) \<Rightarrow> 'a::zero pdevs \<Rightarrow> 'b::zero pdevs"
   is unop_pdevs_raw
   using nonzeros_unop_pdevs_subset
   by (rule finite_subset) auto
 
 lemma pdevs_apply_unop_pdevs[simp]: "pdevs_apply (unop_pdevs f x) i =
   (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i))"
   by transfer (auto simp: unop_pdevs_raw_def)
 
 lemma pdevs_domain_unop_linear:
   assumes "linear f"
   shows "pdevs_domain (unop_pdevs f x) \<subseteq> pdevs_domain x"
 proof -
   interpret f: linear f by fact
   show ?thesis
     by (auto simp: f.zero)
 qed
 
 lemma
   pdevs_val_unop_linear:
   assumes "linear f"
   shows "pdevs_val e (unop_pdevs f x) = f (pdevs_val e x)"
 proof -
   interpret f: linear f by fact
   have *: "\<And>i. (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i)) = f (pdevs_apply x i)"
     by (auto simp: f.zero)
   have "pdevs_val e (unop_pdevs f x) =
       (\<Sum>i\<in>pdevs_domain (unop_pdevs f x). e i *\<^sub>R f (pdevs_apply x i))"
     by (auto simp add: pdevs_val_pdevs_domain *)
   also have "\<dots> = (\<Sum>xa\<in>pdevs_domain x. e xa *\<^sub>R f (pdevs_apply x xa))"
     by (auto intro!: sum.mono_neutral_cong_left)
   also have "\<dots> = f (pdevs_val e x)"
     by (auto simp add: pdevs_val_pdevs_domain f.sum f.scaleR)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Pointwise Scaling of Partial Deviations\<close>
 
 definition scaleR_pdevs::"real \<Rightarrow> 'a::real_vector pdevs \<Rightarrow> 'a pdevs"
   where "scaleR_pdevs r x = unop_pdevs ((*\<^sub>R) r) x"
 
 lemma pdevs_apply_scaleR_pdevs[simp]:
   "pdevs_apply (scaleR_pdevs x Y) n = x *\<^sub>R pdevs_apply Y n"
   by (auto simp: scaleR_pdevs_def)
 
 lemma degree_scaleR_pdevs[simp]: "degree (scaleR_pdevs r x) = (if r = 0 then 0 else degree x)"
   unfolding degree_def
   by auto
 
 lemma pdevs_val_scaleR_pdevs[simp]:
   fixes x::real and Y::"'a::real_normed_vector pdevs"
   shows "pdevs_val e (scaleR_pdevs x Y) = x *\<^sub>R pdevs_val e Y"
   by (auto simp: pdevs_val_sum scaleR_sum_right ac_simps)
 
 
 subsection \<open>Partial Deviations Scale Pointwise\<close>
 
 definition pdevs_scaleR::"real pdevs \<Rightarrow> 'a::real_vector \<Rightarrow> 'a pdevs"
   where "pdevs_scaleR r x = unop_pdevs (\<lambda>r. r *\<^sub>R x) r"
 
 lemma pdevs_apply_pdevs_scaleR[simp]:
   "pdevs_apply (pdevs_scaleR X y) n = pdevs_apply X n *\<^sub>R y"
   by (auto simp: pdevs_scaleR_def)
 
 lemma degree_pdevs_scaleR[simp]: "degree (pdevs_scaleR r x) = (if x = 0 then 0 else degree r)"
   unfolding degree_def
   by auto
 
 lemma pdevs_val_pdevs_scaleR[simp]:
   fixes X::"real pdevs" and y::"'a::real_normed_vector"
   shows "pdevs_val e (pdevs_scaleR X y) = pdevs_val e X *\<^sub>R y"
   by (auto simp: pdevs_val_sum scaleR_sum_left)
 
 
 subsection \<open>Pointwise Unary Minus\<close>
 
 definition uminus_pdevs::"'a::real_vector pdevs \<Rightarrow> 'a pdevs"
   where "uminus_pdevs = unop_pdevs uminus"
 
 lemma pdevs_apply_uminus_pdevs[simp]: "pdevs_apply (uminus_pdevs x) = - pdevs_apply x"
   by (auto simp: uminus_pdevs_def)
 
 lemma degree_uminus_pdevs[simp]: "degree (uminus_pdevs x) = degree x"
   by (rule degree_cong) simp
 
 lemma pdevs_val_uminus_pdevs[simp]: "pdevs_val e (uminus_pdevs x) = - pdevs_val e x"
   unfolding pdevs_val_sum
   by (auto simp: sum_negf)
 
 definition "uminus_aform X = (- fst X, uminus_pdevs (snd X))"
 
 lemma fst_uminus_aform[simp]: "fst (uminus_aform Y) = - fst Y"
   by (simp add: uminus_aform_def)
 
 lemma aform_val_uminus_aform[simp]: "aform_val e (uminus_aform X) = - aform_val e X"
   by (auto simp: uminus_aform_def aform_val_def)
 
 
 subsection \<open>Constant\<close>
 
 lift_definition zero_pdevs::"'a::zero pdevs" is "\<lambda>_. 0" by simp
 
 lemma pdevs_apply_zero_pdevs[simp]: "pdevs_apply zero_pdevs i = 0"
   by transfer simp
 
 lemma pdevs_val_zero_pdevs[simp]: "pdevs_val e zero_pdevs = 0"
   by (auto simp: pdevs_val_def)
 
 definition "num_aform f = (f, zero_pdevs)"
 
 
 subsection \<open>Inner Product\<close>
 
 definition pdevs_inner::"'a::euclidean_space pdevs \<Rightarrow> 'a \<Rightarrow> real pdevs"
   where "pdevs_inner x b = unop_pdevs (\<lambda>x. x \<bullet> b) x"
 
 lemma pdevs_apply_pdevs_inner[simp]: "pdevs_apply (pdevs_inner p a) i = pdevs_apply p i \<bullet> a"
   by (simp add: pdevs_inner_def)
 
 lemma pdevs_val_pdevs_inner[simp]: "pdevs_val e (pdevs_inner p a) = pdevs_val e p \<bullet> a"
   by (auto simp add: inner_sum_left pdevs_val_pdevs_domain intro!: sum.mono_neutral_cong_left)
 
 definition inner_aform::"'a::euclidean_space aform \<Rightarrow> 'a \<Rightarrow> real aform"
   where "inner_aform X b = (fst X \<bullet> b, pdevs_inner (snd X) b)"
 
 
 
 subsection \<open>Inner Product Pair\<close>
 
 definition inner2::"'a::euclidean_space \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> real*real"
   where "inner2 x n l = (x \<bullet> n, x \<bullet> l)"
 
 definition pdevs_inner2::"'a::euclidean_space pdevs \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> (real*real) pdevs"
   where "pdevs_inner2 X n l = unop_pdevs (\<lambda>x. inner2 x n l) X"
 
 lemma pdevs_apply_pdevs_inner2[simp]: "pdevs_apply (pdevs_inner2 p a b) i = (pdevs_apply p i \<bullet> a, pdevs_apply p i \<bullet> b)"
   by (simp add: pdevs_inner2_def inner2_def zero_prod_def)
 
 definition inner2_aform::"'a::euclidean_space aform \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> (real*real) aform"
   where "inner2_aform X a b = (inner2 (fst X) a b, pdevs_inner2 (snd X) a b)"
 
 lemma linear_inner2[intro, simp]: "linear (\<lambda>x. inner2 x n i)"
   by unfold_locales (auto simp: inner2_def algebra_simps)
 
 lemma aform_val_inner2_aform[simp]: "aform_val e (inner2_aform Z n i) = inner2 (aform_val e Z) n i"
 proof -
   have "aform_val e (inner2_aform Z n i) = inner2 (fst Z) n i + inner2 (pdevs_val e (snd Z)) n i"
     by (auto simp: aform_val_def inner2_aform_def pdevs_inner2_def pdevs_val_unop_linear)
   also have "\<dots> = inner2 (aform_val e Z) n i"
     by (simp add: inner2_def algebra_simps aform_val_def)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Update\<close>
 
 lemma pdevs_val_upd[simp]:
   "pdevs_val (e(n := e')) X = pdevs_val e X - e n * pdevs_apply X n + e' * pdevs_apply X n"
   unfolding pdevs_val_def
   by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X],
     auto simp: pdevs_val_def sum.insert_remove)+
 
 lemma nonzeros_fun_upd:
   "{i. (f(n := a)) i \<noteq> 0} \<subseteq> {i. f i \<noteq> 0} \<union> {n}"
   by (auto split: if_split_asm)
 
 lift_definition pdev_upd::"'a::real_vector pdevs \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a pdevs"
   is "\<lambda>x n a. x(n:=a)"
   by (rule finite_subset[OF nonzeros_fun_upd]) simp
 
 lemma pdevs_apply_pdev_upd[simp]:
   "pdevs_apply (pdev_upd X n x) = (pdevs_apply X)(n:=x)"
   by transfer simp
 
 lemma pdevs_val_pdev_upd[simp]:
   "pdevs_val e (pdev_upd X n x) = pdevs_val e X + e n *\<^sub>R x - e n *\<^sub>R pdevs_apply X n"
   unfolding pdevs_val_def
   by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X],
     auto simp: pdevs_val_def sum.insert_remove)+
 
 lemma degree_pdev_upd:
   assumes "x = 0 \<longleftrightarrow> pdevs_apply X n = 0"
   shows "degree (pdev_upd X n x) = degree X"
   using assms
   by (auto intro!: degree_cong split: if_split_asm)
 
 lemma degree_pdev_upd_le:
   assumes "degree X \<le> n"
   shows "degree (pdev_upd X n x) \<le> Suc n"
   using assms
   by (auto intro!: degree_le)
 
 
 subsection \<open>Inf/Sup\<close>
 
 definition "Inf_aform X = fst X - tdev (snd X)"
 
 definition "Sup_aform X = fst X + tdev (snd X)"
 
 lemma Inf_aform:
   assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
   shows "Inf_aform X \<le> aform_val e X"
   using order_trans[OF abs_ge_minus_self abs_pdevs_val_le_tdev[OF assms]]
   by (auto simp: Inf_aform_def aform_val_def minus_le_iff)
 
 lemma Sup_aform:
   assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
   shows "aform_val e X \<le> Sup_aform X"
   using order_trans[OF abs_ge_self abs_pdevs_val_le_tdev[OF assms]]
   by (auto simp: Sup_aform_def aform_val_def)
 
 
 subsection \<open>Minkowski Sum\<close>
 
 definition msum_pdevs_raw::"nat\<Rightarrow>(nat \<Rightarrow> 'a::real_vector)\<Rightarrow>(nat \<Rightarrow> 'a)\<Rightarrow>(nat\<Rightarrow>'a)" where
   "msum_pdevs_raw n x y i = (if i < n then x i else y (i - n))"
 
 lemma nonzeros_msum_pdevs_raw:
   "{i. msum_pdevs_raw n f g i \<noteq> 0} = ({0..<n} \<inter> {i. f i \<noteq> 0}) \<union> (+) n ` ({i. g i \<noteq> 0})"
   by (force simp: msum_pdevs_raw_def not_less split: if_split_asm)
 
 lift_definition msum_pdevs::"nat\<Rightarrow>'a::real_vector pdevs\<Rightarrow>'a pdevs\<Rightarrow>'a pdevs" is msum_pdevs_raw
   unfolding nonzeros_msum_pdevs_raw by simp
 
 lemma pdevs_apply_msum_pdevs: "pdevs_apply (msum_pdevs n f g) i =
   (if i < n then pdevs_apply f i else pdevs_apply g (i - n))"
   by transfer (auto simp: msum_pdevs_raw_def)
 
 lemma degree_least_nonzero:
   assumes "degree f \<noteq> 0"
   shows "pdevs_apply f (degree f - 1) \<noteq> 0"
 proof
   assume H: "pdevs_apply f (degree f - 1) = 0"
   {
     fix j
     assume "j\<ge>degree f - 1"
     with H have "pdevs_apply f j = 0"
       by (cases "degree f - 1 = j") auto
   }
   from degree_le[rule_format, OF this]
   have "degree f \<le> degree f - 1"
     by blast
   with assms show False by simp
 qed
 
 lemma degree_leI:
   assumes "(\<And>i. pdevs_apply y i = 0 \<Longrightarrow> pdevs_apply x i = 0)"
   shows "degree x \<le> degree y"
 proof cases
   assume "degree x \<noteq> 0"
   from degree_least_nonzero[OF this]
   have "pdevs_apply y (degree x - 1) \<noteq> 0"
     by (auto simp: assms split: if_split_asm)
   from degree_gt[OF this] show ?thesis
     by simp
 qed simp
 
 lemma degree_msum_pdevs_ge1:
   shows "degree f \<le> n \<Longrightarrow> degree f \<le> degree (msum_pdevs n f g)"
   by (rule degree_leI) (auto simp: pdevs_apply_msum_pdevs split: if_split_asm)
 
 lemma degree_msum_pdevs_ge2:
   assumes "degree f \<le> n"
   shows "degree g \<le> degree (msum_pdevs n f g) - n"
 proof cases
   assume "degree g \<noteq> 0"
   hence "pdevs_apply g (degree g - 1) \<noteq> 0" by (rule degree_least_nonzero)
   hence "pdevs_apply (msum_pdevs n f g) (n + degree g - 1) \<noteq> 0"
     using assms
     by (auto simp: pdevs_apply_msum_pdevs)
   from degree_gt[OF this]
   show ?thesis
     by simp
 qed simp
 
 lemma degree_msum_pdevs_le:
   shows "degree (msum_pdevs n f g) \<le> n + degree g"
   by (auto intro!: degree_le simp: pdevs_apply_msum_pdevs)
 
 lemma
   sum_msum_pdevs_cases:
   assumes "degree f \<le> n"
   assumes [simp]: "\<And>i. e i 0 = 0"
   shows
     "(\<Sum>i <degree (msum_pdevs n f g).
       e i (if i < n then pdevs_apply f i else pdevs_apply g (i - n))) =
     (\<Sum>i <degree f. e i (pdevs_apply f i)) + (\<Sum>i <degree g. e (i + n) (pdevs_apply g i))"
   (is "?lhs = ?rhs")
 proof -
   have "?lhs = (\<Sum>i\<in>{..<degree (msum_pdevs n f g)} \<inter> {i. i < n}. e i (pdevs_apply f i)) +
     (\<Sum>i\<in>{..<degree (msum_pdevs n f g)} \<inter> - {i. i < n}. e i (pdevs_apply g (i - n)))"
     (is "_ = ?sum_f + ?sum_g")
      by (simp add: sum.If_cases if_distrib)
   also have "?sum_f = (\<Sum>i = 0..<degree f. e i (pdevs_apply f i))"
     using assms degree_msum_pdevs_ge1[of f n g]
     by (intro sum.mono_neutral_cong_right) auto
   also
   have "?sum_g = (\<Sum>i\<in>{0 + n..<degree (msum_pdevs n f g) - n + n}. e i (pdevs_apply g (i - n)))"
     by (rule sum.cong) auto
   also have "\<dots> = (\<Sum>i = 0..<degree (msum_pdevs n f g) - n. e (i + n) (pdevs_apply g (i + n - n)))"
     by (rule sum.shift_bounds_nat_ivl)
   also have "\<dots> = (\<Sum>i = 0..<degree g. e (i + n) (pdevs_apply g i))"
     using assms degree_msum_pdevs_ge2[of f n]
     by (intro sum.mono_neutral_cong_right) (auto intro!: sum.mono_neutral_cong_right)
   finally show ?thesis
     by (simp add: atLeast0LessThan)
 qed
 
 lemma tdev_msum_pdevs: "degree f \<le> n \<Longrightarrow> tdev (msum_pdevs n f g) = tdev f + tdev g"
   by (auto simp: tdev_def pdevs_apply_msum_pdevs intro!: sum_msum_pdevs_cases)
 
 lemma pdevs_val_msum_pdevs:
   "degree f \<le> n \<Longrightarrow> pdevs_val e (msum_pdevs n f g) = pdevs_val e f + pdevs_val (\<lambda>i. e (i + n)) g"
   by (auto simp: pdevs_val_sum pdevs_apply_msum_pdevs intro!: sum_msum_pdevs_cases)
 
 definition msum_aform::"nat \<Rightarrow> 'a::real_vector aform \<Rightarrow> 'a aform \<Rightarrow> 'a aform"
   where "msum_aform n f g = (fst f + fst g, msum_pdevs n (snd f) (snd g))"
 
 lemma fst_msum_aform[simp]: "fst (msum_aform n f g) = fst f + fst g"
   by (simp add: msum_aform_def)
 
 lemma snd_msum_aform[simp]: "snd (msum_aform n f g) = msum_pdevs n (snd f) (snd g)"
   by (simp add: msum_aform_def)
 
 lemma finite_nonzero_summable: "finite {i. f i \<noteq> 0} \<Longrightarrow> summable f"
   by (auto intro!: sums_summable sums_finite)
 
 lemma aform_val_msum_aform:
   assumes "degree_aform f \<le> n"
   shows "aform_val e (msum_aform n f g) = aform_val e f + aform_val (\<lambda>i. e (i + n)) g"
   using assms
   by (auto simp: pdevs_val_msum_pdevs aform_val_def)
 
 lemma Inf_aform_msum_aform:
   "degree_aform X \<le> n \<Longrightarrow> Inf_aform (msum_aform n X Y) = Inf_aform X + Inf_aform Y"
   by (simp add: Inf_aform_def tdev_msum_pdevs)
 
 lemma Sup_aform_msum_aform:
   "degree_aform X \<le> n \<Longrightarrow> Sup_aform (msum_aform n X Y) = Sup_aform X + Sup_aform Y"
   by (simp add: Sup_aform_def tdev_msum_pdevs)
 
 definition "independent_from d Y = msum_aform d (0, zero_pdevs) Y"
 
 definition "independent_aform X Y = independent_from (degree_aform X) Y"
 
 lemma degree_zero_pdevs[simp]: "degree zero_pdevs = 0"
   by (metis degree_least_nonzero pdevs_apply_zero_pdevs)
 
 lemma independent_aform_Joints:
   assumes "x \<in> Affine X"
   assumes "y \<in> Affine Y"
   shows "[x, y] \<in> Joints [X, independent_aform X Y]"
   using assms
   unfolding Affine_def valuate_def Joints_def
   apply safe
   subgoal premises prems for e ea
     using prems
     by (intro image_eqI[where x="\<lambda>i. if i < degree_aform X then e i else ea (i - degree_aform X)"])
       (auto simp: aform_val_def pdevs_val_msum_pdevs Pi_iff
       independent_aform_def independent_from_def intro!: pdevs_val_degree_cong)
   done
 
 lemma msum_aform_Joints:
   assumes "d \<ge> degree_aform X"
   assumes "\<And>X. X \<in> set XS \<Longrightarrow> d \<ge> degree_aform X"
   assumes "(x#xs) \<in> Joints (X#XS)"
   assumes "y \<in> Affine Y"
   shows "((x + y)#x#xs) \<in> Joints (msum_aform d X Y#X#XS)"
   using assms
   unfolding Joints_def valuate_def Affine_def
 proof (safe, goal_cases)
   case (1 e ea a b zs)
   then show ?case
     by (intro image_eqI[where x = "\<lambda>i. if i < d then e i else ea (i - d)"])
       (force simp: aform_val_def pdevs_val_msum_pdevs intro!: intro!: pdevs_val_degree_cong)+
 qed
 
 lemma Joints_msum_aform:
   assumes "d \<ge> degree_aform X"
   assumes "\<And>Y. Y \<in> set YS \<Longrightarrow> d \<ge> degree_aform Y"
   shows "Joints (msum_aform d X Y#YS) = {((x + y)#ys) |x y ys. y \<in> Affine Y \<and> x#ys \<in> Joints (X#YS)}"
   unfolding Affine_def valuate_def Joints_def
 proof (safe, goal_cases)
   case (1 x e)
   thus ?case
     using assms
     by (intro exI[where x = "aform_val e X"] exI[where x = "aform_val ((\<lambda>i. e (i + d))) Y"])
       (auto simp add: aform_val_def pdevs_val_msum_pdevs)
 next
   case (2 x xa y ys e ea)
   thus ?case using assms
     by (intro image_eqI[where x="\<lambda>i. if i < d then ea i else e (i - d)"])
        (force simp: aform_val_def pdevs_val_msum_pdevs Pi_iff intro!: pdevs_val_degree_cong)+
 qed
 
 lemma Joints_singleton_image: "Joints [x] = (\<lambda>x. [x]) ` Affine x"
   by (auto simp: Joints_def Affine_def valuate_def)
 
 lemma Collect_extract_image: "{g (f x y) |x y. P x y} = g ` {f x y |x y. P x y}"
   by auto
 
 lemma inj_Cons: "inj (\<lambda>x. x#xs)"
   by (auto intro!: injI)
 
 lemma Joints_Nil[simp]: "Joints [] = {[]}"
   by (force simp: Joints_def valuate_def)
 
 lemma msum_pdevs_zero_ident[simp]: "msum_pdevs 0 zero_pdevs x = x"
   by transfer (auto simp: msum_pdevs_raw_def)
 
 lemma msum_aform_zero_ident[simp]: "msum_aform 0 (0, zero_pdevs) x = x"
   by (simp add: msum_aform_def)
 
 lemma mem_Joints_singleton: "(x \<in> Joints [X]) = (\<exists>y. x = [y] \<and> y \<in> Affine X)"
   by (auto simp: Affine_def valuate_def Joints_def)
 
 lemma singleton_mem_Joints[simp]: "[x] \<in> Joints [X] \<longleftrightarrow> x \<in> Affine X"
   by (auto simp: mem_Joints_singleton)
 
 lemma msum_aform_Joints_without_first:
   assumes "d \<ge> degree_aform X"
   assumes "\<And>X. X \<in> set XS \<Longrightarrow> d \<ge> degree_aform X"
   assumes "(x#xs) \<in> Joints (X#XS)"
   assumes "y \<in> Affine Y"
   assumes "z = x + y"
   shows "z#xs \<in> Joints (msum_aform d X Y#XS)"
   unfolding \<open>z = x + y\<close>
   using msum_aform_Joints[OF assms(1-4)]
   by (force simp: Joints_def valuate_def)
 
 lemma Affine_msum_aform:
   assumes "d \<ge> degree_aform X"
   shows "Affine (msum_aform d X Y) = {x + y |x y. x \<in> Affine X \<and> y \<in> Affine Y}"
   using Joints_msum_aform[OF assms, of Nil Y, simplified, unfolded mem_Joints_singleton]
   by (auto simp add: Joints_singleton_image Collect_extract_image[where g="\<lambda>x. [x]"]
     inj_image_eq_iff[OF inj_Cons] )
 
 lemma Affine_zero_pdevs[simp]: "Affine (0, zero_pdevs) = {0}"
   by (force simp: Affine_def valuate_def aform_val_def)
 
 lemma Affine_independent_aform:
   "Affine (independent_aform X Y) = Affine Y"
   by (auto simp: independent_aform_def independent_from_def Affine_msum_aform)
 
 lemma
   abs_diff_eq1:
   fixes l u::"'a::ordered_euclidean_space"
   shows "l \<le> u \<Longrightarrow> \<bar>u - l\<bar> = u - l"
   by (metis abs_of_nonneg diff_add_cancel le_add_same_cancel2)
 
 lemma compact_sum:
   fixes f :: "'a \<Rightarrow> 'b::topological_space \<Rightarrow> 'c::real_normed_vector"
   assumes "finite I"
   assumes "\<And>i. i \<in> I \<Longrightarrow> compact (S i)"
   assumes "\<And>i. i \<in> I \<Longrightarrow> continuous_on (S i) (f i)"
   assumes "I \<subseteq> J"
   shows "compact {\<Sum>i\<in>I. f i (x i) | x. x \<in> Pi J S}"
   using assms
 proof (induct I)
   case empty
   thus ?case
   proof (cases "\<exists>x. x \<in> Pi J S")
     case False
     hence *: "{\<Sum>i\<in>{}. f i (x i) |x. x \<in> Pi J S} = {}"
       by (auto simp: Pi_iff)
     show ?thesis unfolding * by simp
   qed auto
 next
   case (insert a I)
   hence "{\<Sum>i\<in>insert a I. f i (xa i) |xa. xa \<in> Pi J S}
     = {x + y |x y. x \<in> f a ` S a \<and> y \<in> {\<Sum>i\<in>I. f i (x i) |x. x \<in> Pi J S}}"
   proof safe
     fix s x
     assume "s \<in> S a" "x \<in> Pi J S"
     thus "\<exists>xa. f a s + (\<Sum>i\<in>I. f i (x i)) = (\<Sum>i\<in>insert a I. f i (xa i)) \<and> xa \<in> Pi J S"
       using insert
       by (auto intro!: exI[where x="x(a:=s)"] sum.cong)
   qed force
   also have "compact \<dots>"
     using insert
     by (intro compact_sums) (auto intro!: compact_continuous_image)
   finally show ?case .
 qed
 
 lemma compact_Affine:
   fixes X::"'a::ordered_euclidean_space aform"
   shows "compact (Affine X)"
 proof -
   have "Affine X = {x + y|x y. x \<in> {fst X} \<and>
       y \<in> {(\<Sum>i \<in> {0..<degree_aform X}. e i *\<^sub>R pdevs_apply (snd X) i) | e. e \<in> UNIV \<rightarrow> {-1 .. 1}}}"
     by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_sum atLeast0LessThan)
   also have "compact \<dots>"
     by (rule compact_sums) (auto intro!: compact_sum continuous_intros)
   finally show ?thesis .
 qed
 
 lemma Joints2_JointsI:
   "(xs, x) \<in> Joints2 XS X \<Longrightarrow> x#xs \<in> Joints (X#XS)"
   by (auto simp: Joints_def Joints2_def valuate_def)
 
 
 subsection \<open>Splitting\<close>
 
 definition "split_aform X i =
   (let xi = pdevs_apply (snd X) i /\<^sub>R 2
   in ((fst X - xi, pdev_upd (snd X) i xi), (fst X + xi, pdev_upd (snd X) i xi)))"
 
 lemma split_aformE:
   assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
   assumes "x = aform_val e X"
   obtains err where "x = aform_val (e(i:=err)) (fst (split_aform X i))" "err \<in> {-1 .. 1}"
     | err where "x = aform_val (e(i:=err)) (snd (split_aform X i))" "err \<in> {-1 .. 1}"
 proof (atomize_elim)
   let ?thesis = "(\<exists>err. x = aform_val (e(i := err)) (fst (split_aform X i)) \<and> err \<in> {- 1..1}) \<or>
     (\<exists>err. x = aform_val (e(i := err)) (snd (split_aform X i)) \<and> err \<in> {- 1..1})"
   {
     assume "pdevs_apply (snd X) i = 0"
     hence "X = fst (split_aform X i)"
       by (auto simp: split_aform_def intro!: prod_eqI pdevs_eqI)
     with assms have ?thesis by (auto intro!: exI[where x="e i"])
   } moreover {
     assume "pdevs_apply (snd X) i \<noteq> 0"
     hence [simp]: "degree_aform X > i"
       by (rule degree_gt)
     note assms(2)
     also
     have "aform_val e X = fst X + (\<Sum>i<degree_aform X. e i *\<^sub>R pdevs_apply (snd X) i)"
       by (simp add: aform_val_def pdevs_val_sum)
     also
     have rewr: "{..<degree_aform X} = {0..<degree_aform X} - {i} \<union> {i}"
       by auto
     have "(\<Sum>i<degree_aform X. e i *\<^sub>R pdevs_apply (snd X) i) =
         (\<Sum>i \<in> {0..<degree_aform X} - {i}. e i *\<^sub>R pdevs_apply (snd X) i) +
         e i *\<^sub>R pdevs_apply (snd X) i"
       by (subst rewr, subst sum.union_disjoint) auto
     finally have "x = fst X + \<dots>" .
     hence "x = aform_val (e(i:=2 * e i - 1)) (snd (split_aform X i))"
         "x = aform_val (e(i:=2 * e i + 1)) (fst (split_aform X i))"
       by (auto simp: aform_val_def split_aform_def Let_def pdevs_val_sum atLeast0LessThan
         Diff_eq degree_pdev_upd if_distrib sum.If_cases field_simps
         scaleR_left_distrib[symmetric])
     moreover
     have "2 * e i - 1 \<in> {-1 .. 1} \<or> 2 * e i + 1 \<in> {-1 .. 1}"
       using assms by (auto simp: not_le Pi_iff dest!: spec[where x=i])
     ultimately have ?thesis by blast
   } ultimately show ?thesis by blast
 qed
 
 lemma pdevs_val_add: "pdevs_val (\<lambda>i. e i + f i) xs = pdevs_val e xs + pdevs_val f xs"
   by (auto simp: pdevs_val_pdevs_domain algebra_simps sum.distrib)
 
 lemma pdevs_val_minus: "pdevs_val (\<lambda>i. e i - f i) xs = pdevs_val e xs - pdevs_val f xs"
   by (auto simp: pdevs_val_pdevs_domain algebra_simps sum_subtractf)
 
 lemma pdevs_val_cmul: "pdevs_val (\<lambda>i. u * e i) xs = u *\<^sub>R pdevs_val e xs"
   by (auto simp: pdevs_val_pdevs_domain scaleR_sum_right)
 
 lemma atLeastAtMost_absI: "- a \<le> a \<Longrightarrow> \<bar>x::real\<bar> \<le> \<bar>a\<bar> \<Longrightarrow> x \<in> atLeastAtMost (- a) a"
   by auto
 
 lemma divide_atLeastAtMost_1_absI: "\<bar>x::real\<bar> \<le> \<bar>a\<bar> \<Longrightarrow> x/a \<in> {-1 .. 1}"
   by (intro atLeastAtMost_absI) (auto simp: divide_le_eq_1)
 
 lemma convex_scaleR_aux: "u + v = 1 \<Longrightarrow> u *\<^sub>R x + v *\<^sub>R x = (x::'a::real_vector)"
   by (metis scaleR_add_left scaleR_one)
 
 lemma convex_mult_aux: "u + v = 1 \<Longrightarrow> u * x + v * x = (x::real)"
   using convex_scaleR_aux[of u v x] by simp
 
 lemma convex_Affine: "convex (Affine X)"
 proof (rule convexI)
   fix x y::'a and u v::real
   assume "x \<in> Affine X" "y \<in> Affine X" and convex: "0 \<le> u" "0 \<le> v" "u + v = 1"
   then obtain e f where x: "x = aform_val e X" "e \<in> UNIV \<rightarrow> {-1 .. 1}"
     and y: "y = aform_val f X" "f \<in> UNIV \<rightarrow> {-1 .. 1}"
     by (auto simp: Affine_def valuate_def)
   let ?conv = "\<lambda>i. u * e i + v * f i"
   {
     fix i
     have "\<bar>?conv i\<bar> \<le> u * \<bar>e i\<bar> + v * \<bar>f i\<bar>"
       using convex by (intro order_trans[OF abs_triangle_ineq]) (simp add: abs_mult)
     also have "\<dots> \<le> 1"
       using convex x y
       by (intro convex_bound_le) (auto simp: Pi_iff abs_real_def)
     finally have "?conv i \<le> 1" "-1 \<le> ?conv i"
       by (auto simp: abs_real_def split: if_split_asm)
   }
   thus "u *\<^sub>R x + v *\<^sub>R y \<in> Affine X"
     using convex x y
     by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_add pdevs_val_cmul algebra_simps
       convex_scaleR_aux intro!: image_eqI[where x="?conv"])
 qed
 
 lemma segment_in_aform_val:
   assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
   assumes "f \<in> UNIV \<rightarrow> {-1 .. 1}"
   shows "closed_segment (aform_val e X) (aform_val f X) \<subseteq> Affine X"
 proof -
   have "aform_val e X \<in> Affine X" "aform_val f X \<in> Affine X"
     using assms by (auto simp: Affine_def valuate_def)
   with convex_Affine[of X, simplified convex_contains_segment]
   show ?thesis
     by simp
 qed
 
 
 subsection \<open>From List of Generators\<close>
 
 lift_definition pdevs_of_list::"'a::zero list \<Rightarrow> 'a pdevs"
   is "\<lambda>xs i. if i < length xs then xs ! i else 0"
   by auto
 
 lemma pdevs_apply_pdevs_of_list:
   "pdevs_apply (pdevs_of_list xs) i = (if i < length xs then xs ! i else 0)"
   by transfer simp
 
 lemma pdevs_apply_pdevs_of_list_Nil[simp]:
   "pdevs_apply (pdevs_of_list []) i = 0"
   by transfer auto
 
 lemma pdevs_apply_pdevs_of_list_Cons:
   "pdevs_apply (pdevs_of_list (x # xs)) i =
     (if i = 0 then x else pdevs_apply (pdevs_of_list xs) (i - 1))"
   by transfer auto
 
 lemma pdevs_domain_pdevs_of_list_Cons[simp]: "pdevs_domain (pdevs_of_list (x # xs)) =
   (if x = 0 then {} else {0}) \<union> (+) 1 ` pdevs_domain (pdevs_of_list xs)"
   by (force simp: pdevs_apply_pdevs_of_list_Cons split: if_split_asm)
 
 lemma pdevs_val_pdevs_of_list_eq[simp]:
   "pdevs_val e (pdevs_of_list (x # xs)) = e 0 *\<^sub>R x + pdevs_val (e o (+) 1) (pdevs_of_list xs)"
 proof -
   have "pdevs_val e (pdevs_of_list (x # xs)) =
     (\<Sum>i\<in>pdevs_domain (pdevs_of_list (x # xs)) \<inter> {0}. e i *\<^sub>R x) +
     (\<Sum>i\<in>pdevs_domain (pdevs_of_list (x # xs)) \<inter> - {0}.
       e i *\<^sub>R pdevs_apply (pdevs_of_list xs) (i - Suc 0))"
     (is "_ = ?l + ?r")
     by (simp add: pdevs_val_pdevs_domain if_distrib sum.If_cases pdevs_apply_pdevs_of_list_Cons)
   also
   have "?r = (\<Sum>i\<in>pdevs_domain (pdevs_of_list xs). e (Suc i) *\<^sub>R pdevs_apply (pdevs_of_list xs) i)"
     by (rule sum.reindex_cong[of "\<lambda>i. i + 1"]) auto
   also have "\<dots> = pdevs_val (e o (+) 1) (pdevs_of_list xs)"
     by (simp add: pdevs_val_pdevs_domain  )
   also have "?l = (\<Sum>i\<in>{0}. e i *\<^sub>R x)"
     by (rule sum.mono_neutral_cong_left) auto
   also have "\<dots> = e 0 *\<^sub>R x" by simp
   finally show ?thesis .
 qed
 
 lemma
   less_degree_pdevs_of_list_imp_less_length:
   assumes "i < degree (pdevs_of_list xs)"
   shows "i < length xs"
 proof -
   from assms have "pdevs_apply (pdevs_of_list xs) (degree (pdevs_of_list xs) - 1) \<noteq> 0"
     by (metis degree_least_nonzero less_nat_zero_code)
   hence "degree (pdevs_of_list xs) - 1 < length xs"
     by (simp add: pdevs_apply_pdevs_of_list split: if_split_asm)
   with assms show ?thesis
     by simp
 qed
 
 lemma tdev_pdevs_of_list[simp]: "tdev (pdevs_of_list xs) = sum_list (map abs xs)"
   by (auto simp: tdev_def pdevs_apply_pdevs_of_list sum_list_sum_nth
     less_degree_pdevs_of_list_imp_less_length
     intro!: sum.mono_neutral_cong_left degree_gt)
 
 lemma pdevs_of_list_Nil[simp]: "pdevs_of_list [] = zero_pdevs"
   by (auto intro!: pdevs_eqI)
 
 lemma pdevs_val_inj_sumI:
   fixes K::"'a set" and g::"'a \<Rightarrow> nat"
   assumes "finite K"
   assumes "inj_on g K"
   assumes "pdevs_domain x \<subseteq> g ` K"
   assumes "\<And>i. i \<in> K \<Longrightarrow> g i \<notin> pdevs_domain x \<Longrightarrow> f i = 0"
   assumes "\<And>i. i \<in> K \<Longrightarrow> g i \<in> pdevs_domain x \<Longrightarrow> f i = e (g i) *\<^sub>R pdevs_apply x (g i)"
   shows "pdevs_val e x = (\<Sum>i\<in>K. f i)"
 proof -
   have [simp]: "inj_on (the_inv_into K g) (pdevs_domain x)"
     using assms
     by (auto simp: intro!: subset_inj_on[OF inj_on_the_inv_into])
   {
     fix y assume y: "y \<in> pdevs_domain x"
     have g_inv: "g (the_inv_into K g y) = y"
       by (meson assms(2) assms(3) y f_the_inv_into_f subset_eq)
     have inv_in: "the_inv_into K g y \<in> K"
       by (meson assms(2) assms(3) y subset_iff in_pdevs_domain the_inv_into_into)
     have inv3: "the_inv_into (pdevs_domain x) (the_inv_into K g) (the_inv_into K g y) =
         g (the_inv_into K g y)"
       using assms y
       by (subst the_inv_into_f_f) (auto simp: f_the_inv_into_f[OF assms(2)])
     note g_inv inv_in inv3
   } note this[simp]
   have "pdevs_val e x = (\<Sum>i\<in>pdevs_domain x. e i *\<^sub>R pdevs_apply x i)"
     by (simp add: pdevs_val_pdevs_domain)
   also have "\<dots> = (\<Sum>i \<in> the_inv_into K g ` pdevs_domain x. e (g i) *\<^sub>R pdevs_apply x (g i))"
     by (rule sum.reindex_cong[OF inj_on_the_inv_into]) auto
   also have "\<dots> = (\<Sum>i\<in>K. f i)"
     using assms
     by (intro sum.mono_neutral_cong_left) (auto simp: the_inv_into_image_eq)
   finally show ?thesis .
 qed
 
 lemma pdevs_domain_pdevs_of_list_le: "pdevs_domain (pdevs_of_list xs) \<subseteq> {0..<length xs}"
   by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm)
 
 lemma pdevs_val_zip: "pdevs_val e (pdevs_of_list xs) = (\<Sum>(i,x)\<leftarrow>zip [0..<length xs] xs. e i *\<^sub>R x)"
   by (auto simp: sum_list_distinct_conv_sum_set
     in_set_zip image_fst_zip pdevs_apply_pdevs_of_list distinct_zipI1
     intro!: pdevs_val_inj_sumI[of _ fst]
     split: if_split_asm)
 
 lemma scaleR_sum_list:
   fixes xs::"'a::real_vector list"
   shows "a *\<^sub>R sum_list xs = sum_list (map (scaleR a) xs)"
   by (induct xs) (auto simp: algebra_simps)
 
 lemma pdevs_val_const_pdevs_of_list: "pdevs_val (\<lambda>_. c) (pdevs_of_list xs) = c *\<^sub>R sum_list xs"
   unfolding pdevs_val_zip split_beta' scaleR_sum_list
   by (rule arg_cong) (auto intro!: nth_equalityI)
 
 lemma pdevs_val_partition:
   assumes "e \<in> UNIV \<rightarrow> I"
   obtains f g where "pdevs_val e (pdevs_of_list xs) =
     pdevs_val f (pdevs_of_list (filter p xs)) +
     pdevs_val g (pdevs_of_list (filter (Not o p) xs))"
     "f \<in> UNIV \<rightarrow> I"
     "g \<in> UNIV \<rightarrow> I"
 proof -
   obtain i where i: "i \<in> I"
     by (metis assms funcset_mem iso_tuple_UNIV_I)
   let ?zip = "zip [0..<length xs] xs"
   define part where "part = partition (p \<circ> snd) ?zip"
   let ?f =
     "(\<lambda>n. if n < degree (pdevs_of_list (filter p xs)) then e (map fst (fst part) ! n) else i)"
   let ?g =
     "(\<lambda>n. if n < degree (pdevs_of_list (filter (Not \<circ> p) xs))
       then e (map fst (snd part) ! n)
       else i)"
   show ?thesis
   proof
     have "pdevs_val e (pdevs_of_list xs) = (\<Sum>(i,x)\<leftarrow>?zip. e i *\<^sub>R x)"
       by (rule pdevs_val_zip)
     also have "\<dots> = (\<Sum>(i, x)\<in>set ?zip. e i *\<^sub>R x)"
       by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1)
     also
     have [simp]: "set (fst part) \<inter> set (snd part) = {}"
       by (auto simp: part_def)
     from partition_set[of "p o snd" ?zip "fst part" "snd part"]
     have "set ?zip = set (fst part) \<union> set (snd part)"
       by (auto simp: part_def)
     also have "(\<Sum>a\<in>set (fst part) \<union> set (snd part). case a of (i, x) \<Rightarrow> e i *\<^sub>R x) =
         (\<Sum>(i, x)\<in>set (fst part). e i *\<^sub>R x) + (\<Sum>(i, x)\<in>set (snd part). e i *\<^sub>R x)"
       by (auto simp: split_beta sum_Un)
     also
     have "(\<Sum>(i, x)\<in>set (fst part). e i *\<^sub>R x) = (\<Sum>(i, x)\<leftarrow>(fst part). e i *\<^sub>R x)"
       by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1 part_def)
     also have "\<dots> = (\<Sum>i<length (fst part). case (fst part ! i) of (i, x) \<Rightarrow> e i *\<^sub>R x)"
       by (subst sum_list_sum_nth) (simp add: split_beta' atLeast0LessThan)
     also have "\<dots> =
       pdevs_val (\<lambda>n. e (map fst (fst part) ! n)) (pdevs_of_list (map snd (fst part)))"
       by (force
         simp: pdevs_val_zip sum_list_distinct_conv_sum_set distinct_zipI1 split_beta' in_set_zip
         intro!:
           sum.reindex_cong[where l=fst] image_eqI[where x = "(x, map snd (fst part) ! x)" for x])
     also
     have "(\<Sum>(i, x)\<in>set (snd part). e i *\<^sub>R x) = (\<Sum>(i, x)\<leftarrow>(snd part). e i *\<^sub>R x)"
       by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1 part_def)
     also have "\<dots> = (\<Sum>i<length (snd part). case (snd part ! i) of (i, x) \<Rightarrow> e i *\<^sub>R x)"
       by (subst sum_list_sum_nth) (simp add: split_beta' atLeast0LessThan)
     also have "\<dots> =
       pdevs_val (\<lambda>n. e (map fst (snd part) ! n)) (pdevs_of_list (map snd (snd part)))"
       by (force simp: pdevs_val_zip sum_list_distinct_conv_sum_set distinct_zipI1 split_beta'
         in_set_zip
         intro!: sum.reindex_cong[where l=fst]
           image_eqI[where x = "(x, map snd (snd part) ! x)" for x])
     also
     have "pdevs_val (\<lambda>n. e (map fst (fst part) ! n)) (pdevs_of_list (map snd (fst part))) =
       pdevs_val (\<lambda>n.
           if n < degree (pdevs_of_list (map snd (fst part))) then e (map fst (fst part) ! n) else i)
         (pdevs_of_list (map snd (fst part)))"
       by (rule pdevs_val_degree_cong) simp_all
     also
     have "pdevs_val (\<lambda>n. e (map fst (snd part) ! n)) (pdevs_of_list (map snd (snd part))) =
       pdevs_val (\<lambda>n.
           if n < degree (pdevs_of_list (map snd (snd part))) then e (map fst (snd part) ! n) else i)
         (pdevs_of_list (map snd (snd part)))"
       by (rule pdevs_val_degree_cong) simp_all
     also have "map snd (snd part) = filter (Not o p) xs"
       by (simp add: part_def filter_map[symmetric] o_assoc)
     also have "map snd (fst part) = filter p xs"
       by (simp add: part_def filter_map[symmetric])
     finally
     show
       "pdevs_val e (pdevs_of_list xs) =
         pdevs_val ?f (pdevs_of_list (filter p xs)) +
         pdevs_val ?g (pdevs_of_list (filter (Not \<circ> p) xs))" .
     show "?f \<in> UNIV \<rightarrow> I" "?g \<in> UNIV \<rightarrow> I"
       using assms \<open>i\<in>I\<close>
       by (auto simp: Pi_iff)
   qed
 qed
 
 lemma pdevs_apply_pdevs_of_list_append:
   "pdevs_apply (pdevs_of_list (xs @ zs)) i =
     (if i < length xs
     then pdevs_apply (pdevs_of_list xs) i else pdevs_apply (pdevs_of_list zs) (i - length xs))"
   by (auto simp: pdevs_apply_pdevs_of_list nth_append)
 
 lemma degree_pdevs_of_list_le_length[intro, simp]: "degree (pdevs_of_list xs) \<le> length xs"
   by (metis less_irrefl_nat le_less_linear less_degree_pdevs_of_list_imp_less_length)
 
 lemma degree_pdevs_of_list_append:
   "degree (pdevs_of_list (xs @ ys)) \<le> length xs + degree (pdevs_of_list ys)"
   by (rule degree_le) (auto simp: pdevs_apply_pdevs_of_list_append)
 
 lemma pdevs_val_pdevs_of_list_append:
   assumes "f \<in> UNIV \<rightarrow> I"
   assumes "g \<in> UNIV \<rightarrow> I"
   obtains e where
     "pdevs_val f (pdevs_of_list xs) + pdevs_val g (pdevs_of_list ys) =
       pdevs_val e (pdevs_of_list (xs @ ys))"
     "e \<in> UNIV \<rightarrow> I"
 proof
   let ?e = "(\<lambda>i. if i < length xs then f i else g (i - length xs))"
   have f: "pdevs_val f (pdevs_of_list xs) =
       (\<Sum>i\<in>{..<length xs}. ?e i *\<^sub>R pdevs_apply (pdevs_of_list (xs @ ys)) i)"
     by (auto simp: pdevs_val_sum degree_gt pdevs_apply_pdevs_of_list_append
       intro: sum.mono_neutral_cong_left)
   have g: "pdevs_val g (pdevs_of_list ys) =
       (\<Sum>i=length xs ..<length xs + degree (pdevs_of_list ys).
         ?e i *\<^sub>R pdevs_apply (pdevs_of_list (xs @ ys)) i)"
     (is "_ = ?sg")
     by (auto simp: pdevs_val_sum pdevs_apply_pdevs_of_list_append
       intro!: inj_onI image_eqI[where x="length xs + x" for x]
         sum.reindex_cong[where l="\<lambda>i. i - length xs"])
   show "pdevs_val f (pdevs_of_list xs) + pdevs_val g (pdevs_of_list ys) =
       pdevs_val ?e (pdevs_of_list (xs @ ys))"
     unfolding f g
     by (subst sum.union_disjoint[symmetric])
       (force simp: pdevs_val_sum ivl_disj_un degree_pdevs_of_list_append
         intro!: sum.mono_neutral_cong_right
         split: if_split_asm)+
   show "?e \<in> UNIV \<rightarrow> I"
     using assms by (auto simp: Pi_iff)
 qed
 
 lemma
   sum_general_mono:
   fixes f::"'a\<Rightarrow>('b::ordered_ab_group_add)"
   assumes [simp,intro]: "finite s" "finite t"
   assumes f: "\<And>x. x \<in> s - t \<Longrightarrow> f x \<le> 0"
   assumes g: "\<And>x. x \<in> t - s \<Longrightarrow> g x \<ge> 0"
   assumes fg: "\<And>x. x \<in> s \<inter> t \<Longrightarrow> f x \<le> g x"
   shows "(\<Sum>x \<in> s. f x) \<le> (\<Sum>x \<in> t. g x)"
 proof -
   have "s = (s - t) \<union> (s \<inter> t)" and [intro, simp]: "(s - t) \<inter> (s \<inter> t) = {}" by auto
   hence "(\<Sum>x \<in> s. f x) = (\<Sum>x \<in> s - t \<union> s \<inter> t. f x)"
     using assms by simp
   also have "\<dots> = (\<Sum>x \<in> s - t. f x) + (\<Sum>x \<in> s \<inter> t. f x)"
     by (simp add: sum_Un)
   also have "(\<Sum>x \<in> s - t. f x) \<le> 0"
     by (auto intro!: sum_nonpos f)
   also have "0 \<le> (\<Sum>x \<in> t - s. g x)"
     by (auto intro!: sum_nonneg g)
   also have "(\<Sum>x \<in> s \<inter> t. f x) \<le> (\<Sum>x \<in> s \<inter> t. g x)"
     by (auto intro!: sum_mono fg)
   also
   have [intro, simp]: "(t - s) \<inter> (s \<inter> t) = {}" by auto
   hence "sum g (t - s) + sum g (s \<inter> t) = sum g ((t - s) \<union> (s \<inter> t))"
     by (simp add: sum_Un)
   also have "\<dots> = sum g t"
     by (auto intro!: sum.cong)
   finally show ?thesis by simp
 qed
 
 lemma pdevs_val_perm_ex:
   assumes "xs <~~> ys"
   assumes mem: "e \<in> UNIV \<rightarrow> I"
   shows "\<exists>e'. e' \<in> UNIV \<rightarrow> I \<and> pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)"
   using assms
 proof (induct arbitrary: e)
   case Nil
   thus ?case
     by auto
 next
   case (Cons xs ys z)
   hence "(e \<circ> (+) (Suc 0)) \<in> UNIV \<rightarrow> I" by auto
   from Cons(2)[OF this] obtain e' where "e' \<in> UNIV \<rightarrow> I"
       "pdevs_val (e \<circ> (+) (Suc 0)) (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)"
     by metis
   thus ?case using Cons
     by (auto intro!: exI[where x="\<lambda>x. if x = 0 then e 0 else e' (x - 1)"] simp: o_def Pi_iff)
 next
   case (trans xs ys zs)
   thus ?case by metis
 next
   case (swap y x l)
   thus ?case
     by (auto intro!: exI[where x="\<lambda>i. if i = 0 then e 1 else if i = 1 then e 0 else e i"]
       simp: o_def Pi_iff)
 qed
 
 lemma pdevs_val_perm:
   assumes "xs <~~> ys"
   assumes mem: "e \<in> UNIV \<rightarrow> I"
   obtains e' where "e' \<in> UNIV \<rightarrow> I"
     "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)"
   using assms
   by (metis pdevs_val_perm_ex)
 
 lemma set_distinct_permI: "set xs = set ys \<Longrightarrow> distinct xs \<Longrightarrow> distinct ys \<Longrightarrow> xs <~~> ys"
   by (metis eq_set_perm_remdups remdups_id_iff_distinct)
 
 lemmas pdevs_val_permute = pdevs_val_perm[OF set_distinct_permI]
 
 lemma partition_permI:
   "filter p xs @ filter (Not o p) xs <~~> xs"
 proof (induct xs)
   case (Cons x xs)
   have swap_app_Cons: "filter p xs @ x # [a\<leftarrow>xs . \<not> p a] <~~> x # filter p xs @ [a\<leftarrow>xs . \<not> p a]"
     by (metis perm_sym perm_append_Cons)
   also have "\<dots> <~~> x#xs"
     using Cons by auto
   finally (trans)
   show ?case using Cons
     by simp
 qed simp
 
 lemma pdevs_val_eqI:
   assumes "\<And>i. i \<in> pdevs_domain y \<Longrightarrow> i \<in> pdevs_domain x \<Longrightarrow>
       e i *\<^sub>R pdevs_apply x i = f i *\<^sub>R pdevs_apply y i"
   assumes "\<And>i. i \<in> pdevs_domain y \<Longrightarrow> i \<notin> pdevs_domain x \<Longrightarrow> f i *\<^sub>R pdevs_apply y i = 0"
   assumes "\<And>i. i \<in> pdevs_domain x \<Longrightarrow> i \<notin> pdevs_domain y \<Longrightarrow> e i *\<^sub>R pdevs_apply x i = 0"
   shows "pdevs_val e x = pdevs_val f y"
   using assms
   by (force simp: pdevs_val_pdevs_domain
     intro!:
       sum.reindex_bij_witness_not_neutral[where
         i=id and j = id and
         S'="pdevs_domain x - pdevs_domain y" and
         T'="pdevs_domain y - pdevs_domain x"])
 
 definition
   filter_pdevs_raw::"(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'a::real_vector) \<Rightarrow> (nat \<Rightarrow> 'a)"
   where "filter_pdevs_raw I X = (\<lambda>i. if I i (X i) then X i else 0)"
 
 lemma filter_pdevs_raw_nonzeros: "{i. filter_pdevs_raw s f i \<noteq> 0} = {i. f i \<noteq> 0} \<inter> {x. s x (f x)}"
   by (auto simp: filter_pdevs_raw_def)
 
 lift_definition filter_pdevs::"(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a::real_vector pdevs \<Rightarrow> 'a pdevs"
   is filter_pdevs_raw
   by (simp add: filter_pdevs_raw_nonzeros)
 
 lemma pdevs_apply_filter_pdevs[simp]:
   "pdevs_apply (filter_pdevs I x) i = (if I i (pdevs_apply x i) then pdevs_apply x i else 0)"
   by transfer (auto simp: filter_pdevs_raw_def)
 
 lemma degree_filter_pdevs_le: "degree (filter_pdevs I x) \<le> degree x"
   by (rule degree_leI) (simp split: if_split_asm)
 
 lemma pdevs_val_filter_pdevs:
   "pdevs_val e (filter_pdevs I x) =
     (\<Sum>i \<in> {..<degree x} \<inter> {i. I i (pdevs_apply x i)}. e i *\<^sub>R pdevs_apply x i)"
   by (auto simp: pdevs_val_sum if_distrib sum.inter_restrict degree_filter_pdevs_le degree_gt
     intro!: sum.mono_neutral_cong_left split: if_split_asm)
 
 lemma pdevs_val_filter_pdevs_dom:
   "pdevs_val e (filter_pdevs I x) =
     (\<Sum>i \<in> pdevs_domain x \<inter> {i. I i (pdevs_apply x i)}. e i *\<^sub>R pdevs_apply x i)"
   by (auto
     simp: pdevs_val_pdevs_domain if_distrib sum.inter_restrict degree_filter_pdevs_le degree_gt
     intro!: sum.mono_neutral_cong_left split: if_split_asm)
 
 lemma pdevs_val_filter_pdevs_eval:
   "pdevs_val e (filter_pdevs p x) = pdevs_val (\<lambda>i. if p i (pdevs_apply x i) then e i else 0) x"
   by (auto split: if_split_asm intro!: pdevs_val_eqI)
 
 definition "pdevs_applys X i = map (\<lambda>x. pdevs_apply x i) X"
 definition "pdevs_vals e X = map (pdevs_val e) X"
 definition "aform_vals e X = map (aform_val e) X"
 definition "filter_pdevs_list I X = map (filter_pdevs (\<lambda>i _. I i (pdevs_applys X i))) X"
 
 lemma pdevs_applys_filter_pdevs_list[simp]:
   "pdevs_applys (filter_pdevs_list I X) i = (if I i (pdevs_applys X i) then pdevs_applys X i else
     map (\<lambda>_. 0) X)"
   by (auto simp: filter_pdevs_list_def o_def pdevs_applys_def)
 
 definition "degrees X = Max (insert 0 (degree ` set X))"
 
 abbreviation "degree_aforms X \<equiv> degrees (map snd X)"
 
 lemma degrees_leI:
   assumes "\<And>x. x \<in> set X \<Longrightarrow> degree x \<le> K"
   shows "degrees X \<le> K"
   using assms
   by (auto simp: degrees_def intro!: Max.boundedI)
 
 lemma degrees_leD:
   assumes "degrees X \<le> K"
   shows "\<And>x. x \<in> set X \<Longrightarrow> degree x \<le> K"
   using assms
   by (auto simp: degrees_def intro!: Max.boundedI)
 
 lemma degree_filter_pdevs_list_le: "degrees (filter_pdevs_list I x) \<le> degrees x"
   by (rule degrees_leI) (auto simp: filter_pdevs_list_def intro!: degree_le dest!: degrees_leD)
 
 
 definition "dense_list_of_pdevs x = map (\<lambda>i. pdevs_apply x i) [0..<degree x]"
 
 subsubsection \<open>(reverse) ordered coefficients as list\<close>
 
 definition "list_of_pdevs x =
   map (\<lambda>i. (i, pdevs_apply x i)) (rev (sorted_list_of_set (pdevs_domain x)))"
 
 lemma list_of_pdevs_zero_pdevs[simp]: "list_of_pdevs zero_pdevs = []"
   by (auto simp: list_of_pdevs_def)
 
 lemma sum_list_list_of_pdevs: "sum_list (map snd (list_of_pdevs x)) = sum_list (dense_list_of_pdevs x)"
   by (auto intro!: sum.mono_neutral_cong_left
     simp add: degree_gt sum_list_distinct_conv_sum_set dense_list_of_pdevs_def list_of_pdevs_def)
 
 lemma sum_list_filter_dense_list_of_pdevs[symmetric]:
   "sum_list (map snd (filter (p o snd) (list_of_pdevs x))) =
     sum_list (filter p (dense_list_of_pdevs x))"
   by (auto intro!: sum.mono_neutral_cong_left
     simp add: degree_gt sum_list_distinct_conv_sum_set dense_list_of_pdevs_def list_of_pdevs_def
       o_def filter_map)
 
 lemma pdevs_of_list_dense_list_of_pdevs: "pdevs_of_list (dense_list_of_pdevs x) = x"
   by (auto simp: pdevs_apply_pdevs_of_list dense_list_of_pdevs_def pdevs_eqI)
 
 lemma pdevs_val_sum_list: "pdevs_val (\<lambda>_. c) X = c *\<^sub>R sum_list (map snd (list_of_pdevs X))"
   by (auto simp: pdevs_val_sum sum_list_list_of_pdevs pdevs_val_const_pdevs_of_list[symmetric]
     pdevs_of_list_dense_list_of_pdevs)
 
 lemma list_of_pdevs_all_nonzero: "list_all (\<lambda>x. x \<noteq> 0) (map snd (list_of_pdevs xs))"
   by (auto simp: list_of_pdevs_def list_all_iff)
 
 lemma list_of_pdevs_nonzero: "x \<in> set (map snd (list_of_pdevs xs)) \<Longrightarrow> x \<noteq> 0"
   by (auto simp: list_of_pdevs_def)
 
 lemma pdevs_of_list_scaleR_0[simp]:
   fixes xs::"'a::real_vector list"
   shows "pdevs_of_list (map ((*\<^sub>R) 0) xs) = zero_pdevs"
   by (auto simp: pdevs_apply_pdevs_of_list intro!: pdevs_eqI)
 
 lemma degree_pdevs_of_list_scaleR:
   "degree (pdevs_of_list (map ((*\<^sub>R) c) xs)) = (if c \<noteq> 0 then degree (pdevs_of_list xs) else 0)"
   by (auto simp: pdevs_apply_pdevs_of_list intro!: degree_cong)
 
 lemma list_of_pdevs_eq:
   "rev (list_of_pdevs X) = (filter ((\<noteq>) 0 o snd) (map (\<lambda>i. (i, pdevs_apply X i)) [0..<degree X]))"
   (is "_ = filter ?P (map ?f ?xs)")
   using map_filter[of ?f ?P ?xs]
   by (auto simp: list_of_pdevs_def o_def sorted_list_of_pdevs_domain_eq rev_map)
 
 lemma sum_list_take_pdevs_val_eq:
   "sum_list (take d xs) = pdevs_val (\<lambda>i. if i < d then 1 else 0) (pdevs_of_list xs)"
 proof -
   have "sum_list (take d xs) = 1 *\<^sub>R sum_list (take d xs)" by simp
   also note pdevs_val_const_pdevs_of_list[symmetric]
   also have "pdevs_val (\<lambda>_. 1) (pdevs_of_list (take d xs)) =
       pdevs_val (\<lambda>i. if i < d then 1 else 0) (pdevs_of_list xs)"
     by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm intro!: pdevs_val_eqI)
   finally show ?thesis .
 qed
 
 lemma zero_in_range_pdevs_apply[intro, simp]:
   fixes X::"'a::real_vector pdevs" shows "0 \<in> range (pdevs_apply X)"
   by (metis degree_gt less_irrefl rangeI)
 
 lemma dense_list_in_range: "x \<in> set (dense_list_of_pdevs X) \<Longrightarrow> x \<in> range (pdevs_apply X)"
   by (auto simp: dense_list_of_pdevs_def)
 
 lemma not_in_dense_list_zeroD:
   assumes "pdevs_apply X i \<notin> set (dense_list_of_pdevs X)"
   shows "pdevs_apply X i = 0"
 proof (rule ccontr)
   assume "pdevs_apply X i \<noteq> 0"
   hence "i < degree X"
     by (rule degree_gt)
   thus False using assms
     by (auto simp: dense_list_of_pdevs_def)
 qed
 
 lemma list_all_list_of_pdevsI:
   assumes "\<And>i. i \<in> pdevs_domain X \<Longrightarrow> P (pdevs_apply X i)"
   shows "list_all (\<lambda>x. P x) (map snd (list_of_pdevs X))"
   using assms by (auto simp: list_all_iff list_of_pdevs_def)
 
 lemma pdevs_of_list_map_scaleR:
   "pdevs_of_list (map (scaleR r) xs) = scaleR_pdevs r (pdevs_of_list xs)"
   by (auto intro!: pdevs_eqI simp: pdevs_apply_pdevs_of_list)
 
 lemma
   map_permI:
   assumes "xs <~~> ys"
   shows "map f xs <~~> map f ys"
   using assms by induct auto
 
 lemma rev_perm: "rev xs <~~> ys \<longleftrightarrow> xs <~~> ys"
   by (metis perm.trans perm_rev rev_rev_ident)
 
 lemma list_of_pdevs_perm_filter_nonzero:
   "map snd (list_of_pdevs X) <~~> (filter ((\<noteq>) 0) (dense_list_of_pdevs X))"
 proof -
   have zip_map:
     "zip [0..<degree X] (dense_list_of_pdevs X) = map (\<lambda>i. (i, pdevs_apply X i)) [0..<degree X]"
     by (auto simp: dense_list_of_pdevs_def intro!: nth_equalityI)
   have "rev (list_of_pdevs X) <~~>
       filter ((\<noteq>) 0 o snd) (zip [0..<degree X] (dense_list_of_pdevs X))"
     by (auto simp: list_of_pdevs_eq o_def zip_map)
   from map_permI[OF this, of snd]
   have "map snd (list_of_pdevs X) <~~>
       map snd (filter ((\<noteq>) 0 \<circ> snd) (zip [0..<degree X] (dense_list_of_pdevs X)))"
     by (simp add: rev_map[symmetric] rev_perm)
   also have "map snd (filter ((\<noteq>) 0 \<circ> snd) (zip [0..<degree X] (dense_list_of_pdevs X))) =
       filter ((\<noteq>) 0) (dense_list_of_pdevs X)"
     using map_filter[of snd "(\<noteq>) 0" "(zip [0..<degree X] (dense_list_of_pdevs X))"]
     by (simp add: o_def dense_list_of_pdevs_def)
    finally
    show ?thesis .
 qed
 
 lemma pdevs_val_filter:
   assumes mem: "e \<in> UNIV \<rightarrow> I"
   assumes "0 \<in> I"
   obtains e' where
     "pdevs_val e (pdevs_of_list (filter p xs)) = pdevs_val e' (pdevs_of_list xs)"
     "e' \<in> UNIV \<rightarrow> I"
   unfolding pdevs_val_filter_pdevs_eval
 proof -
   have "(\<lambda>_::nat. 0) \<in> UNIV \<rightarrow> I" using assms by simp
   have "pdevs_val e (pdevs_of_list (filter p xs)) =
       pdevs_val e (pdevs_of_list (filter p xs)) +
       pdevs_val (\<lambda>_. 0) (pdevs_of_list (filter (Not o p) xs))"
     by (simp add: pdevs_val_sum)
   also
   from pdevs_val_pdevs_of_list_append[OF \<open>e \<in> _\<close> \<open>(\<lambda>_. 0) \<in> _\<close>]
   obtain e' where "e' \<in> UNIV \<rightarrow> I"
       "\<dots> = pdevs_val e' (pdevs_of_list (filter p xs @ filter (Not o p) xs))"
     by metis
   note this(2)
   also
   from pdevs_val_perm[OF partition_permI \<open>e' \<in> _\<close>]
   obtain e'' where "\<dots> = pdevs_val e'' (pdevs_of_list xs)" "e'' \<in> UNIV \<rightarrow> I" by metis
   note this(1)
   finally show ?thesis using \<open>e'' \<in> _\<close> ..
 qed
 
 lemma
   pdevs_val_of_list_of_pdevs:
   assumes "e \<in> UNIV \<rightarrow> I"
   assumes "0 \<in> I"
   obtains e' where
     "pdevs_val e (pdevs_of_list (map snd (list_of_pdevs X))) = pdevs_val e' X"
     "e' \<in> UNIV \<rightarrow> I"
 proof -
   obtain e' where "e' \<in> UNIV \<rightarrow> I"
     and "pdevs_val e (pdevs_of_list (map snd (list_of_pdevs X))) =
       pdevs_val e' (pdevs_of_list (filter ((\<noteq>) 0) (dense_list_of_pdevs X)))"
     by (rule pdevs_val_perm[OF list_of_pdevs_perm_filter_nonzero assms(1)])
   note this(2)
   also from pdevs_val_filter[OF \<open>e' \<in> _\<close> \<open>0 \<in> I\<close>, of "(\<noteq>) 0" "dense_list_of_pdevs X"]
   obtain e'' where "e'' \<in> UNIV \<rightarrow> I"
     and "\<dots> = pdevs_val e'' (pdevs_of_list (dense_list_of_pdevs X))"
     by metis
   note this(2)
   also have "\<dots> = pdevs_val e'' X" by (simp add: pdevs_of_list_dense_list_of_pdevs)
   finally show ?thesis using \<open>e'' \<in> UNIV \<rightarrow> I\<close> ..
 qed
 
 lemma
   pdevs_val_of_list_of_pdevs2:
   assumes "e \<in> UNIV \<rightarrow> I"
   obtains e' where
     "pdevs_val e X = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs X)))"
     "e' \<in> UNIV \<rightarrow> I"
 proof -
   from list_of_pdevs_perm_filter_nonzero[of X]
   have perm: "(filter ((\<noteq>) 0) (dense_list_of_pdevs X)) <~~> map snd (list_of_pdevs X)"
     by (simp add: perm_sym)
   have "pdevs_val e X = pdevs_val e (pdevs_of_list (dense_list_of_pdevs X))"
     by (simp add: pdevs_of_list_dense_list_of_pdevs)
   also from pdevs_val_partition[OF \<open>e \<in> _\<close>, of "dense_list_of_pdevs X" "(\<noteq>) 0"]
   obtain f g where "f \<in> UNIV \<rightarrow> I" "g \<in> UNIV \<rightarrow> I"
     "\<dots> = pdevs_val f (pdevs_of_list (filter ((\<noteq>) 0) (dense_list_of_pdevs X))) +
       pdevs_val g (pdevs_of_list (filter (Not \<circ> (\<noteq>) 0) (dense_list_of_pdevs X)))"
     (is "_ = ?f + ?g")
     by metis
   note this(3)
   also
   have "pdevs_of_list [x\<leftarrow>dense_list_of_pdevs X . x = 0] = zero_pdevs"
     by (auto intro!: pdevs_eqI simp: pdevs_apply_pdevs_of_list dest!: nth_mem)
   hence "?g = 0" by (auto simp: o_def )
   also
   obtain e' where "e' \<in> UNIV \<rightarrow> I"
     and "?f = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs X)))"
     by (rule pdevs_val_perm[OF perm \<open>f \<in> _\<close>])
   note this(2)
   finally show ?thesis using \<open>e' \<in> UNIV \<rightarrow> I\<close> by (auto intro!: that)
 qed
 
 lemma dense_list_of_pdevs_scaleR:
   "r \<noteq> 0 \<Longrightarrow> map ((*\<^sub>R) r) (dense_list_of_pdevs x) = dense_list_of_pdevs (scaleR_pdevs r x)"
   by (auto simp: dense_list_of_pdevs_def)
 
 lemma degree_pdevs_of_list_eq:
   "(\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0) \<Longrightarrow> degree (pdevs_of_list xs) = length xs"
   by (cases xs) (auto simp add: pdevs_apply_pdevs_of_list nth_Cons
     intro!: degree_eqI
     split: nat.split)
 
 lemma dense_list_of_pdevs_pdevs_of_list:
   "(\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0) \<Longrightarrow> dense_list_of_pdevs (pdevs_of_list xs) = xs"
   by (auto simp: dense_list_of_pdevs_def degree_pdevs_of_list_eq pdevs_apply_pdevs_of_list
     intro!: nth_equalityI)
 
 lemma pdevs_of_list_sum:
   assumes "distinct xs"
   assumes "e \<in> UNIV \<rightarrow> I"
   obtains f where "f \<in> UNIV \<rightarrow> I" "pdevs_val e (pdevs_of_list xs) = (\<Sum>P\<in>set xs. f P *\<^sub>R P)"
 proof -
   define f where "f X = e (the (map_of (zip xs [0..<length xs]) X))" for X
   from assms have "f \<in> UNIV \<rightarrow> I"
     by (auto simp: f_def)
   moreover
   have "pdevs_val e (pdevs_of_list xs) = (\<Sum>P\<in>set xs. f P *\<^sub>R P)"
     by (auto simp add: pdevs_val_zip f_def assms sum_list_distinct_conv_sum_set[symmetric]
       in_set_zip map_of_zip_upto2_length_eq_nth
       intro!: sum_list_nth_eqI)
   ultimately show ?thesis ..
 qed
 
 lemma pdevs_domain_eq_pdevs_of_list:
   assumes nz: "\<And>x. x \<in> set (xs) \<Longrightarrow> x \<noteq> 0"
   shows "pdevs_domain (pdevs_of_list xs) = {0..<length xs}"
   using nz
   by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm)
 
 lemma length_list_of_pdevs_pdevs_of_list:
   assumes nz: "\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0"
   shows "length (list_of_pdevs (pdevs_of_list xs)) = length xs"
   using nz by (auto simp: list_of_pdevs_def pdevs_domain_eq_pdevs_of_list)
 
 lemma nth_list_of_pdevs_pdevs_of_list:
   assumes nz: "\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0"
   assumes l: "n < length xs"
   shows "list_of_pdevs (pdevs_of_list xs) ! n  = ((length xs - Suc n), xs ! (length xs - Suc n))"
   using nz l
   by (auto simp: list_of_pdevs_def pdevs_domain_eq_pdevs_of_list rev_nth pdevs_apply_pdevs_of_list)
 
 lemma list_of_pdevs_pdevs_of_list_eq:
   "(\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0) \<Longrightarrow>
     list_of_pdevs (pdevs_of_list xs) = zip (rev [0..<length xs]) (rev xs)"
   by (auto simp: nth_list_of_pdevs_pdevs_of_list length_list_of_pdevs_pdevs_of_list rev_nth
     intro!: nth_equalityI)
 
 lemma sum_list_filter_list_of_pdevs_of_list:
   fixes xs::"'a::comm_monoid_add list"
   assumes "\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0"
   shows "sum_list (filter p (map snd (list_of_pdevs (pdevs_of_list xs)))) = sum_list (filter p xs)"
   using assms
   by (auto simp: list_of_pdevs_pdevs_of_list_eq rev_filter[symmetric])
 
 lemma
   sum_list_partition:
   fixes xs::"'a::comm_monoid_add list"
   shows "sum_list (filter p xs) + sum_list (filter (Not o p) xs) = sum_list xs"
   by (induct xs) (auto simp: ac_simps)
 
 
 subsection \<open>2d zonotopes\<close>
 
 definition "prod_of_pdevs x y = binop_pdevs Pair x y"
 
 lemma apply_pdevs_prod_of_pdevs[simp]:
   "pdevs_apply (prod_of_pdevs x y) i = (pdevs_apply x i, pdevs_apply y i)"
   unfolding prod_of_pdevs_def
   by (simp add: zero_prod_def)
 
 lemma pdevs_domain_prod_of_pdevs[simp]:
   "pdevs_domain (prod_of_pdevs x y) = pdevs_domain x \<union> pdevs_domain y"
   by (auto simp: zero_prod_def)
 
 lemma pdevs_val_prod_of_pdevs[simp]:
   "pdevs_val e (prod_of_pdevs x y) = (pdevs_val e x, pdevs_val e y)"
 proof -
   have "pdevs_val e x = (\<Sum>i\<in>pdevs_domain x \<union> pdevs_domain y. e i *\<^sub>R pdevs_apply x i)"
     (is "_ = ?x")
     unfolding pdevs_val_pdevs_domain
     by (rule sum.mono_neutral_cong_left) auto
   moreover have "pdevs_val e y = (\<Sum>i\<in>pdevs_domain x \<union> pdevs_domain y. e i *\<^sub>R pdevs_apply y i)"
     (is "_ = ?y")
     unfolding pdevs_val_pdevs_domain
     by (rule sum.mono_neutral_cong_left) auto
   ultimately have "(pdevs_val e x, pdevs_val e y) = (?x, ?y)"
     by auto
   also have "\<dots> = pdevs_val e (prod_of_pdevs x y)"
     by (simp add: sum_prod pdevs_val_pdevs_domain)
   finally show ?thesis by simp
 qed
 
 definition prod_of_aforms (infixr "\<times>\<^sub>a" 80)
   where "prod_of_aforms x y = ((fst x, fst y), prod_of_pdevs (snd x) (snd y))"
 
 
 subsection \<open>Intervals\<close>
 
 definition One_pdevs_raw::"nat \<Rightarrow> 'a::executable_euclidean_space"
   where "One_pdevs_raw i = (if i < length (Basis_list::'a list) then Basis_list ! i else 0)"
 
 lemma zeros_One_pdevs_raw:
   "One_pdevs_raw -` {0::'a::executable_euclidean_space} = {length (Basis_list::'a list)..}"
   by (auto simp: One_pdevs_raw_def nonzero_Basis split: if_split_asm dest!: nth_mem)
 
 lemma nonzeros_One_pdevs_raw:
   "{i. One_pdevs_raw i \<noteq> (0::'a::executable_euclidean_space)} = - {length (Basis_list::'a list)..}"
   using zeros_One_pdevs_raw
   by blast
 
 lift_definition One_pdevs::"'a::executable_euclidean_space pdevs" is One_pdevs_raw
   by (auto simp: nonzeros_One_pdevs_raw)
 
 lemma pdevs_apply_One_pdevs[simp]: "pdevs_apply One_pdevs i =
   (if i < length (Basis_list::'a::executable_euclidean_space list) then Basis_list ! i else 0::'a)"
   by transfer (simp add: One_pdevs_raw_def)
 
 lemma Max_Collect_less_nat: "Max {i::nat. i < k} = (if k = 0 then Max {} else k - 1)"
   by (auto intro!: Max_eqI)
 
 lemma degree_One_pdevs[simp]: "degree (One_pdevs::'a pdevs) =
     length (Basis_list::'a::executable_euclidean_space list)"
   by (auto simp: degree_eq_Suc_max Basis_list_nth_nonzero Max_Collect_less_nat
       intro!: Max_eqI DIM_positive)
 
 definition inner_scaleR_pdevs::"'a::euclidean_space \<Rightarrow> 'a pdevs \<Rightarrow> 'a pdevs"
   where "inner_scaleR_pdevs b x = unop_pdevs (\<lambda>x. (b \<bullet> x) *\<^sub>R x) x"
 
 lemma pdevs_apply_inner_scaleR_pdevs[simp]:
   "pdevs_apply (inner_scaleR_pdevs a x) i = (a \<bullet> (pdevs_apply x i)) *\<^sub>R (pdevs_apply x i)"
   by (simp add: inner_scaleR_pdevs_def)
 
 lemma degree_inner_scaleR_pdevs_le:
   "degree (inner_scaleR_pdevs (l::'a::executable_euclidean_space) One_pdevs) \<le>
     degree (One_pdevs::'a pdevs)"
   by (rule degree_leI) (auto simp: inner_scaleR_pdevs_def One_pdevs_raw_def)
 
 definition "pdevs_of_ivl l u = scaleR_pdevs (1/2) (inner_scaleR_pdevs (u - l) One_pdevs)"
 
 lemma degree_pdevs_of_ivl_le:
   "degree (pdevs_of_ivl l u::'a::executable_euclidean_space pdevs) \<le> DIM('a)"
   using degree_inner_scaleR_pdevs_le
   by (simp add: pdevs_of_ivl_def)
 
 lemma pdevs_apply_pdevs_of_ivl:
   defines "B \<equiv> Basis_list::'a::executable_euclidean_space list"
   shows "pdevs_apply (pdevs_of_ivl l u) i = (if i < length B then ((u - l)\<bullet>(B!i)/2)*\<^sub>R(B!i) else 0)"
   by (auto simp: pdevs_of_ivl_def B_def)
 
 lemma deg_length_less_imp[simp]:
   "k < degree (pdevs_of_ivl l u::'a::executable_euclidean_space pdevs) \<Longrightarrow>
     k < length (Basis_list::'a list)"
   by (metis (no_types, hide_lams) degree_One_pdevs degree_inner_scaleR_pdevs_le degree_scaleR_pdevs
       dual_order.strict_trans length_Basis_list_pos nat_neq_iff not_le pdevs_of_ivl_def)
 
 lemma tdev_pdevs_of_ivl: "tdev (pdevs_of_ivl l u) = \<bar>u - l\<bar> /\<^sub>R 2"
 proof -
   have "tdev (pdevs_of_ivl l u) =
     (\<Sum>i <degree (pdevs_of_ivl l u). \<bar>pdevs_apply (pdevs_of_ivl l u) i\<bar>)"
     by (auto simp: tdev_def)
   also have "\<dots> = (\<Sum>i = 0..<length (Basis_list::'a list). \<bar>pdevs_apply (pdevs_of_ivl l u) i\<bar>)"
     using degree_pdevs_of_ivl_le[of l u]
     by (intro sum.mono_neutral_cong_left) auto
   also have "\<dots> = (\<Sum>i = 0..<length (Basis_list::'a list).
       \<bar>((u - l) \<bullet> Basis_list ! i / 2) *\<^sub>R Basis_list ! i\<bar>)"
     by (auto simp: pdevs_apply_pdevs_of_ivl)
   also have "\<dots> = (\<Sum>b \<leftarrow> Basis_list. \<bar>((u - l) \<bullet> b / 2) *\<^sub>R b\<bar>)"
     by (auto simp: sum_list_sum_nth)
   also have "\<dots> = (\<Sum>b\<in>Basis. \<bar>((u - l) \<bullet> b / 2) *\<^sub>R b\<bar>)"
     by (auto simp: sum_list_distinct_conv_sum_set)
   also have "\<dots> = \<bar>u - l\<bar> /\<^sub>R 2"
     by (subst euclidean_representation[symmetric, of "\<bar>u - l\<bar> /\<^sub>R 2"])
       (simp add:  abs_inner abs_scaleR)
   finally show ?thesis .
 qed
 
 definition "aform_of_ivl l u = ((l + u)/\<^sub>R2, pdevs_of_ivl l u)"
 
 definition "aform_of_point x = aform_of_ivl x x"
 
 lemma Elem_affine_of_ivl_le:
   assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
   assumes "l \<le> u"
   shows "l \<le> aform_val e (aform_of_ivl l u)"
 proof -
   have "l =  (1 / 2) *\<^sub>R l + (1 / 2) *\<^sub>R l"
     by (simp add: scaleR_left_distrib[symmetric])
   also have "\<dots> = (l + u)/\<^sub>R2 - tdev (pdevs_of_ivl l u)"
     by (auto simp: assms tdev_pdevs_of_ivl algebra_simps)
   also have "\<dots> \<le> aform_val e (aform_of_ivl l u)"
     using abs_pdevs_val_le_tdev[OF assms(1), of "pdevs_of_ivl l u"]
     by (auto simp: aform_val_def aform_of_ivl_def minus_le_iff dest!: abs_le_D2)
   finally show ?thesis .
 qed
 
 lemma Elem_affine_of_ivl_ge:
   assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
   assumes "l \<le> u"
   shows "aform_val e (aform_of_ivl l u) \<le> u"
 proof -
   have "aform_val e (aform_of_ivl l u) \<le>  (l + u)/\<^sub>R2 + tdev (pdevs_of_ivl l u)"
     using abs_pdevs_val_le_tdev[OF assms(1), of "pdevs_of_ivl l u"]
     by (auto simp: aform_val_def aform_of_ivl_def minus_le_iff dest!: abs_le_D1)
   also have "\<dots> = (1 / 2) *\<^sub>R u + (1 / 2) *\<^sub>R u"
     by (auto simp: assms tdev_pdevs_of_ivl algebra_simps)
   also have "\<dots> = u"
     by (simp add: scaleR_left_distrib[symmetric])
   finally show ?thesis .
 qed
 
 lemma
   map_of_zip_upto_length_eq_nth:
   assumes "i < length B"
   assumes "d = length B"
   shows "(map_of (zip [0..<d] B) i) = Some (B ! i)"
 proof -
   have "length [0..<length B] = length B"
     by simp
   from map_of_zip_is_Some[OF this, of i] assms
   have "map_of (zip [0..<length B] B) i = Some (B ! i)"
     by (auto simp: in_set_zip)
   thus ?thesis by (simp add: assms)
 qed
 
 lemma in_ivl_affine_of_ivlE:
   assumes "k \<in> {l .. u}"
   obtains e where "e \<in> UNIV \<rightarrow> {-1 .. 1}" "k = aform_val e (aform_of_ivl l u)"
 proof atomize_elim
   define e where [abs_def]: "e i = (let b = if i <length (Basis_list::'a list) then
     (the (map_of (zip [0..<length (Basis_list::'a list)] (Basis_list::'a list)) i)) else 0 in
       ((k - (l + u) /\<^sub>R 2) \<bullet> b) / (((u - l) /\<^sub>R 2) \<bullet> b))" for i
   let ?B = "Basis_list::'a list"
 
   have "k = (1 / 2) *\<^sub>R (l + u) +
       (\<Sum>b \<in> Basis. (if (u - l) \<bullet> b = 0 then 0 else ((k - (1 / 2) *\<^sub>R (l + u)) \<bullet> b)) *\<^sub>R b)"
     (is "_ = _ + ?dots")
     using assms
     by (force simp add: algebra_simps eucl_le[where 'a='a] intro!: euclidean_eqI[where 'a='a])
   also have
     "?dots = (\<Sum>b \<in> Basis. (if (u - l) \<bullet> b = 0 then 0 else ((k - (1 / 2) *\<^sub>R (l + u)) \<bullet> b) *\<^sub>R b))"
     by (auto intro!: sum.cong)
   also have "\<dots> = (\<Sum>b \<leftarrow> ?B. (if (u - l) \<bullet> b = 0 then 0 else ((k - (1 / 2) *\<^sub>R (l + u)) \<bullet> b) *\<^sub>R b))"
     by (auto simp: sum_list_distinct_conv_sum_set)
   also have "\<dots> =
     (\<Sum>i = 0..<length ?B.
         (if (u - l) \<bullet> ?B ! i = 0 then 0 else ((k - (1 / 2) *\<^sub>R (l + u)) \<bullet> ?B ! i) *\<^sub>R ?B ! i))"
     by (auto simp: sum_list_sum_nth)
   also have "\<dots> =
     (\<Sum>i = 0..<degree (inner_scaleR_pdevs (u - l) One_pdevs).
         (if (u - l) \<bullet> Basis_list ! i = 0 then 0
         else ((k - (1 / 2) *\<^sub>R (l + u)) \<bullet> Basis_list ! i) *\<^sub>R Basis_list ! i))"
     using degree_inner_scaleR_pdevs_le[of "u - l"]
     by (intro sum.mono_neutral_cong_right) (auto dest!: degree)
   also have "(1 / 2) *\<^sub>R (l + u) +
     (\<Sum>i = 0..<degree (inner_scaleR_pdevs (u - l) One_pdevs).
         (if (u - l) \<bullet> Basis_list ! i = 0 then 0
         else ((k - (1 / 2) *\<^sub>R (l + u)) \<bullet> Basis_list ! i) *\<^sub>R Basis_list ! i)) =
       aform_val e (aform_of_ivl l u)"
     using degree_inner_scaleR_pdevs_le[of "u - l"]
     by (auto simp: aform_val_def aform_of_ivl_def pdevs_of_ivl_def map_of_zip_upto_length_eq_nth
       e_def Let_def pdevs_val_sum
       intro!: sum.cong)
   finally have "k = aform_val e (aform_of_ivl l u)" .
 
   moreover
   {
     fix k l u::real assume *: "l \<le> k" "k \<le> u"
     let ?m = "l / 2 + u / 2"
     have "\<bar>k - ?m\<bar> \<le> \<bar>if k \<le> ?m then ?m - l else u - ?m\<bar>"
       using * by auto
     also have "\<dots> \<le> \<bar>u / 2 - l / 2\<bar>"
       by (auto simp: abs_real_def)
     finally have "\<bar>k - (l / 2 + u / 2)\<bar> \<le> \<bar>u / 2 - l/2\<bar>" .
   } note midpoint_abs = this
   have "e \<in> UNIV \<rightarrow> {- 1..1}"
     using assms
     unfolding e_def Let_def
     by (intro Pi_I divide_atLeastAtMost_1_absI)
       (auto simp: map_of_zip_upto_length_eq_nth eucl_le[where 'a='a]
         divide_le_eq_1 not_less inner_Basis algebra_simps intro!: midpoint_abs
         dest!: nth_mem)
   ultimately show "\<exists>e. e \<in> UNIV \<rightarrow> {- 1..1} \<and> k = aform_val e (aform_of_ivl l u)"
     by blast
 qed
 
 lemma Inf_aform_aform_of_ivl:
   assumes "l \<le> u"
   shows "Inf_aform (aform_of_ivl l u) = l"
   using assms
   by (auto simp: Inf_aform_def aform_of_ivl_def tdev_pdevs_of_ivl abs_diff_eq1 algebra_simps)
     (metis field_sum_of_halves scaleR_add_left scaleR_one)
 
 lemma Sup_aform_aform_of_ivl:
   assumes "l \<le> u"
   shows "Sup_aform (aform_of_ivl l u) = u"
   using assms
   by (auto simp: Sup_aform_def aform_of_ivl_def tdev_pdevs_of_ivl abs_diff_eq1 algebra_simps)
     (metis field_sum_of_halves scaleR_add_left scaleR_one)
 
 lemma Affine_aform_of_ivl:
   "a \<le> b \<Longrightarrow> Affine (aform_of_ivl a b) = {a .. b}"
   by (force simp: Affine_def valuate_def intro!: Elem_affine_of_ivl_ge Elem_affine_of_ivl_le
     elim!: in_ivl_affine_of_ivlE)
 
 end
diff --git a/thys/Berlekamp_Zassenhaus/Missing_Multiset2.thy b/thys/Berlekamp_Zassenhaus/Missing_Multiset2.thy
--- a/thys/Berlekamp_Zassenhaus/Missing_Multiset2.thy
+++ b/thys/Berlekamp_Zassenhaus/Missing_Multiset2.thy
@@ -1,270 +1,270 @@
 theory Missing_Multiset2
-  imports "HOL-Library.Multiset" "HOL-Library.Permutation" "HOL-Library.Permutations"
+  imports "HOL-Library.Multiset" "HOL-Library.List_Permutation" "HOL-Library.Permutations"
     Containers.Containers_Auxiliary (* only for a lemma *)
 begin
 
 subsubsection \<open>Missing muiltiset\<close>
 
 lemma id_imp_bij:
   assumes id: "\<And>x. f (f x) = x" shows "bij f"
 proof (intro bijI injI surjI[of f, OF id])
   fix x y assume "f x = f y"
   then have "f (f x) = f (f y)" by auto
   with id show "x = y" by auto
 qed
 
 lemma rel_mset_Zero_iff[simp]:
   shows "rel_mset rel {#} Y \<longleftrightarrow> Y = {#}" and "rel_mset rel X {#} \<longleftrightarrow> X = {#}"
   using rel_mset_Zero rel_mset_size by (fastforce, fastforce)
 
 definition "is_mset_set X \<equiv> \<forall>x \<in># X. count X x = 1"
 
 lemma is_mset_setD[dest]: "is_mset_set X \<Longrightarrow> x \<in># X \<Longrightarrow> count X x = 1"
   unfolding is_mset_set_def by auto
 
 lemma is_mset_setI[intro]:
   assumes "\<And>x. x \<in># X \<Longrightarrow> count X x = 1"
   shows "is_mset_set X"
   using assms unfolding is_mset_set_def by auto
 
 lemma is_mset_set[simp]: "is_mset_set (mset_set X)"
   unfolding is_mset_set_def
   by (meson count_mset_set(1) count_mset_set(2) count_mset_set(3) not_in_iff)
 
 lemma is_mset_set_add[simp]:
   "is_mset_set (X + {#x#}) \<longleftrightarrow> is_mset_set X \<and> x \<notin># X" (is "?L \<longleftrightarrow> ?R")
 proof(intro iffI conjI)
   assume L: ?L
   with count_eq_zero_iff count_single show "is_mset_set X"
     unfolding is_mset_set_def
     by (metis (no_types, hide_lams) add_mset_add_single count_add_mset nat.inject set_mset_add_mset_insert union_single_eq_member)
   show "x \<notin># X"
   proof
     assume "x \<in># X"
     then have "count (X + {#x#}) x > 1" by auto
     with L show False by (auto simp: is_mset_set_def)
   qed
 next
   assume R: ?R show ?L
   proof
     fix x' assume x': "x' \<in># X + {#x#}"
     show "count (X + {#x#}) x' = 1"
     proof(cases "x' \<in># X")
       case True with R have "count X x' = 1" by auto
         moreover from True R have "count {#x#} x' = 0" by auto
         ultimately show ?thesis by auto
     next
       case False then have "count X x' = 0" by (simp add: not_in_iff)
         with R x' show ?thesis by auto
     qed
   qed
 qed
 
 
 lemma mset_set_id[simp]:
   assumes "is_mset_set X"
   shows "mset_set (set_mset X) = X"
   using assms unfolding is_mset_set_def
   by (metis count_eq_zero_iff count_mset_set(1) count_mset_set(3) finite_set_mset multiset_eqI)
 
 lemma count_image_mset:
   shows "count (image_mset f X) y = (\<Sum>x | x \<in># X \<and> y = f x. count X x)"
 proof(induct X)
   case empty show ?case by auto
 next
   case (add x X)
     define X' where "X' \<equiv> X + {#x#}"
     have "(\<Sum>z | z \<in># X' \<and> y = f z. count (X + {#x#}) z) =
           (\<Sum>z | z \<in># X' \<and> y = f z. count X z) + (\<Sum>z | z \<in># X' \<and> y = f z. count {#x#} z)"
       unfolding plus_multiset.rep_eq sum.distrib..
     also have split:
       "{z. z \<in># X' \<and> y = f z} =
        {z. z \<in># X' \<and> y = f z \<and> z \<noteq> x} \<union> {z. z \<in># X' \<and> y = f z \<and> z = x}" by blast
     then have "(\<Sum>z | z \<in># X' \<and> y = f z. count {#x#} z) =
       (\<Sum>z | z \<in># X' \<and> y = f z \<and> z = x. count {#x#} z)"
       unfolding split by (subst sum.union_disjoint, auto)
     also have "... = (if y = f x then 1 else 0)" using card_eq_Suc_0_ex1 by (auto simp: X'_def)
     also have "(\<Sum>z | z \<in># X' \<and> y = f z. count X z) = (\<Sum>z | z \<in># X \<and> y = f z. count X z)"
     proof(cases "x \<in># X")
       case True then have "z \<in># X' \<longleftrightarrow> z \<in># X" for z by (auto simp: X'_def)
       then show ?thesis by auto 
     next
       case False
         have split: "{z. z \<in># X' \<and> y = f z} = {z. z \<in># X \<and> y = f z} \<union> {z. z = x \<and> y = f z}"
           by (auto simp: X'_def)
         also have "sum (count X) ... = (\<Sum>z | z \<in># X \<and> y = f z. count X z) + (\<Sum>z | z = x \<and> y = f z. count X z)"
           by (subst sum.union_disjoint, auto simp: False)
         also with False have "\<And>z. z = x \<and> y = f z \<Longrightarrow> count X z = 0" by (meson count_inI)
         with sum.neutral_const have "(\<Sum>z | z = x \<and> y = f z. count X z) = 0" by auto
         finally show ?thesis by auto
     qed
     also have "... = count (image_mset f X) y" using add by auto
     finally show ?case by (simp add: X'_def)  
 qed
 
 lemma is_mset_set_image:
   assumes "inj_on f (set_mset X)" and "is_mset_set X"
   shows "is_mset_set (image_mset f X)"
 proof (cases X)
   case empty then show ?thesis by auto
 next
   case (add x X)
     define X' where "X' \<equiv> add_mset x X"
     with assms add have inj:"inj_on f (set_mset X')"
           and X': "is_mset_set X'" by auto
   show ?thesis
   proof(unfold add, intro is_mset_setI, fold X'_def)
     fix y assume "y \<in># image_mset f X'"
     then have "y \<in> f ` set_mset X'" by auto 
     with inj have "\<exists>!x'. x' \<in># X' \<and> y = f x'" by (meson imageE inj_onD)
     then obtain x' where x': "{x'. x' \<in># X' \<and> y = f x'} = {x'}" by auto
     then have "count (image_mset f X') y = count X' x'"
       unfolding count_image_mset by auto
     also from X' x' have "... = 1" by auto
     finally show "count (image_mset f X') y = 1".
   qed
 qed
 
 (* a variant for "right" *)
 lemma ex_mset_zip_right:
   assumes "length xs = length ys" "mset ys' = mset ys"
   shows "\<exists>xs'. length ys' = length xs' \<and> mset (zip xs' ys') = mset (zip xs ys)"
 using assms
 proof (induct xs ys arbitrary: ys' rule: list_induct2)
   case Nil
   thus ?case
     by auto
 next
   case (Cons x xs y ys ys')
   obtain j where j_len: "j < length ys'" and nth_j: "ys' ! j = y"
     by (metis Cons.prems in_set_conv_nth list.set_intros(1) mset_eq_setD)
 
   define ysa where "ysa = take j ys' @ drop (Suc j) ys'"
   have "mset ys' = {#y#} + mset ysa"
     unfolding ysa_def using j_len nth_j
     by (metis Cons_nth_drop_Suc union_mset_add_mset_right add_mset_remove_trivial add_diff_cancel_left'
         append_take_drop_id mset.simps(2) mset_append)
   hence ms_y: "mset ysa = mset ys"
     by (simp add: Cons.prems)
   then obtain xsa where
     len_a: "length ysa = length xsa" and ms_a: "mset (zip xsa ysa) = mset (zip xs ys)"
     using Cons.hyps(2) by blast
 
   define xs' where "xs' = take j xsa @ x # drop j xsa"
   have ys': "ys' = take j ysa @ y # drop j ysa"
     using ms_y j_len nth_j Cons.prems ysa_def
     by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc Cons_nth_drop_Suc length_Cons
       length_drop size_mset)
   have j_len': "j \<le> length ysa"
     using j_len ys' ysa_def
     by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
   have "length ys' = length xs'"
     unfolding xs'_def using Cons.prems len_a ms_y
     by (metis add_Suc_right append_take_drop_id length_Cons length_append mset_eq_length)
   moreover have "mset (zip xs' ys') = mset (zip (x # xs) (y # ys))"
     unfolding ys' xs'_def
     apply (rule HOL.trans[OF mset_zip_take_Cons_drop_twice])
     using j_len' by (auto simp: len_a ms_a)
   ultimately show ?case
     by blast
 qed
 
 lemma list_all2_reorder_right_invariance:
   assumes rel: "list_all2 R xs ys" and ms_y: "mset ys' = mset ys"
   shows "\<exists>xs'. list_all2 R xs' ys' \<and> mset xs' = mset xs"
 proof -
   have len: "length xs = length ys"
     using rel list_all2_conv_all_nth by auto
   obtain xs' where
     len': "length xs' = length ys'" and ms_xy: "mset (zip xs' ys') = mset (zip xs ys)"
     using len ms_y by (metis ex_mset_zip_right)
   have "list_all2 R xs' ys'"
     using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: mset_eq_setD)
   moreover have "mset xs' = mset xs"
     using len len' ms_xy map_fst_zip mset_map by metis
   ultimately show ?thesis
     by blast
 qed
 
 lemma rel_mset_via_perm: "rel_mset rel (mset xs) (mset ys) \<longleftrightarrow> (\<exists>zs. perm xs zs \<and> list_all2 rel zs ys)"
 proof (unfold rel_mset_def, intro iffI, goal_cases)
   case 1
   then obtain zs ws where zs: "mset zs = mset xs" and ws: "mset ws = mset ys" and zsws: "list_all2 rel zs ws" by auto
   note list_all2_reorder_right_invariance[OF zsws ws[symmetric], unfolded zs mset_eq_perm]
   then show ?case using perm_sym by auto
 next
   case 2
   from this[folded mset_eq_perm] show ?case by force
 qed
 
 lemma rel_mset_free:
   assumes rel: "rel_mset rel X Y" and xs: "mset xs = X"
   shows "\<exists>ys. mset ys = Y \<and> list_all2 rel xs ys"
 proof-
   from rel[unfolded rel_mset_def] obtain xs' ys'
     where xs': "mset xs' = X" and ys': "mset ys' = Y" and xsys': "list_all2 rel xs' ys'" by auto
   from xs' xs have "mset xs = mset xs'" by auto
   from mset_eq_permutation[OF this]
   obtain f where perm: "f permutes {..<length xs'}" and xs': "permute_list f xs' = xs".
   then have [simp]: "length xs' = length xs" by auto
   from permute_list_nth[OF perm, unfolded xs'] have *: "\<And>i. i < length xs \<Longrightarrow> xs ! i = xs' ! f i" by auto
   note [simp] = list_all2_lengthD[OF xsys',symmetric]
   note [simp] = atLeast0LessThan[symmetric]
   note bij =  permutes_bij[OF perm]
   define ys where "ys \<equiv> map (nth ys' \<circ> f) [0..<length ys']"
   then have [simp]: "length ys = length ys'" by auto 
   have "mset ys = mset (map (nth ys') (map f [0..<length ys']))"
    unfolding ys_def by auto
   also have "... = image_mset (nth ys') (image_mset f (mset [0..<length ys']))"
     by (simp add: multiset.map_comp)
   also have "(mset [0..<length ys']) = mset_set {0..<length ys'}"
     by (metis mset_sorted_list_of_multiset sorted_list_of_mset_set sorted_list_of_set_range) 
   also have "image_mset f (...) = mset_set (f ` {..<length ys'})"
     using subset_inj_on[OF bij_is_inj[OF bij]] by (subst image_mset_mset_set, auto)
   also have "... = mset [0..<length ys']" using perm by (simp add: permutes_image)
   also have "image_mset (nth ys') ... = mset ys'" by(fold mset_map, unfold map_nth, auto)
   finally have "mset ys = Y" using ys' by auto
   moreover have "list_all2 rel xs ys"
   proof(rule list_all2_all_nthI)
     fix i assume i: "i < length xs"
     with * have "xs ! i = xs' ! f i" by auto
     also from i permutes_in_image[OF perm]
     have "rel (xs' ! f i) (ys' ! f i)" by (intro list_all2_nthD[OF xsys'], auto)
     finally show "rel (xs ! i) (ys ! i)" unfolding ys_def using i by simp
   qed simp
   ultimately show ?thesis by auto
 qed
 
 lemma rel_mset_split:
   assumes rel: "rel_mset rel (X1+X2) Y"
   shows "\<exists>Y1 Y2. Y = Y1 + Y2 \<and> rel_mset rel X1 Y1 \<and> rel_mset rel X2 Y2"
 proof-
   obtain xs1 where xs1: "mset xs1 = X1" using ex_mset by auto
   obtain xs2 where xs2: "mset xs2 = X2" using ex_mset by auto
   from xs1 xs2 have "mset (xs1 @ xs2) = X1 + X2" by auto
   from rel_mset_free[OF rel this] obtain ys
     where ys: "mset ys = Y" "list_all2 rel (xs1 @ xs2) ys" by auto
   then obtain ys1 ys2
     where ys12: "ys = ys1 @ ys2"
       and xs1ys1: "list_all2 rel xs1 ys1"
       and xs2ys2: "list_all2 rel xs2 ys2"
     using list_all2_append1 by blast
   from ys12 ys have "Y = mset ys1 + mset ys2" by auto
   moreover from xs1 xs1ys1 have "rel_mset rel X1 (mset ys1)" unfolding rel_mset_def by auto
   moreover from xs2 xs2ys2 have "rel_mset rel X2 (mset ys2)" unfolding rel_mset_def by auto
   ultimately show ?thesis by (subst exI[of _ "mset ys1"], subst exI[of _ "mset ys2"],auto)
 qed
 
 lemma rel_mset_OO:
   assumes AB: "rel_mset R A B" and BC: "rel_mset S B C"
   shows "rel_mset (R OO S) A C"
 proof-
   from AB obtain as bs where A_as: "A = mset as" and B_bs: "B = mset bs" and as_bs: "list_all2 R as bs"
     by (auto simp: rel_mset_def)
   from rel_mset_free[OF BC] B_bs obtain cs where C_cs: "C = mset cs" and bs_cs: "list_all2 S bs cs"
     by auto
   from list_all2_trans[OF _ as_bs bs_cs, of "R OO S"] A_as C_cs
   show ?thesis by (auto simp: rel_mset_def)
 qed
 
 end
diff --git a/thys/Buchi_Complementation/Complementation_Final.thy b/thys/Buchi_Complementation/Complementation_Final.thy
--- a/thys/Buchi_Complementation/Complementation_Final.thy
+++ b/thys/Buchi_Complementation/Complementation_Final.thy
@@ -1,183 +1,183 @@
 section \<open>Final Instantiation of Algorithms Related to Complementation\<close>
 
 theory Complementation_Final
 imports
   "Complementation_Implement"
   "Formula"
   "Transition_Systems_and_Automata.NBA_Translate"
   "Transition_Systems_and_Automata.NGBA_Algorithms"
-  "HOL-Library.Permutation"
+  "HOL-Library.List_Permutation"
 begin
 
   subsection \<open>Syntax\<close>
 
   (* TODO: this syntax has unnecessarily high inner binding strength, requiring extra parentheses
     the regular let syntax correctly uses inner binding strength 0: ("(2_ =/ _)" 10) *)
   no_syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" [1000, 13] 13)
   syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" 13)
 
   subsection \<open>Hashcodes on Complement States\<close>
 
   definition "hci k \<equiv> uint32_of_nat k * 1103515245 + 12345"
   definition "hc \<equiv> \<lambda> (p, q, b). hci p + hci q * 31 + (if b then 1 else 0)"
   definition "list_hash xs \<equiv> fold ((XOR) \<circ> hc) xs 0"
 
   lemma list_hash_eq:
     assumes "distinct xs" "distinct ys" "set xs = set ys"
     shows "list_hash xs = list_hash ys"
   proof -
     have "remdups xs <~~> remdups ys" using eq_set_perm_remdups assms(3) by this
     then have "xs <~~> ys" using assms(1, 2) by (simp add: distinct_remdups_id)
     then have "fold ((XOR) \<circ> hc) xs a = fold ((XOR) \<circ> hc) ys a" for a
     proof (induct arbitrary: a)
       case (swap y x l)
       have "x XOR y XOR a = y XOR x XOR a" for x y by (transfer) (simp add: word_bw_lcs(3))
       then show ?case by simp
     qed simp+
     then show ?thesis unfolding list_hash_def by this
   qed
 
   definition state_hash :: "nat \<Rightarrow> Complementation_Implement.state \<Rightarrow> nat" where
     "state_hash n p \<equiv> nat_of_hashcode (list_hash p) mod n"
 
   lemma state_hash_bounded_hashcode[autoref_ga_rules]: "is_bounded_hashcode state_rel
     (gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
     (prod_eq (=) (\<longleftrightarrow>))) state_hash"
   proof
     show [param]: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
       (prod_eq (=) (\<longleftrightarrow>)), (=)) \<in> state_rel \<rightarrow> state_rel \<rightarrow> bool_rel" by autoref
     show "state_hash n xs = state_hash n ys" if "xs \<in> Domain state_rel" "ys \<in> Domain state_rel"
       "gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list))
       (list_map_lookup (=)) (prod_eq (=) (=)) xs ys" for xs ys n
     proof -
       have 1: "distinct (map fst xs)" "distinct (map fst ys)"
         using that(1, 2) unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
       have 2: "distinct xs" "distinct ys" using 1 by (auto intro: distinct_mapI)
       have 3: "(xs, map_of xs) \<in> state_rel" "(ys, map_of ys) \<in> state_rel"
         using 1 unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
       have 4: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
         (prod_eq (=) (\<longleftrightarrow>)) xs ys, map_of xs = map_of ys) \<in> bool_rel" using 3 by parametricity
       have 5: "map_to_set (map_of xs) = map_to_set (map_of ys)" using that(3) 4 by simp
       have 6: "set xs = set ys" using map_to_set_map_of 1 5 by blast
       show "state_hash n xs = state_hash n ys" unfolding state_hash_def using list_hash_eq 2 6 by metis
     qed
     show "state_hash n x < n" if "1 < n" for n x using that unfolding state_hash_def by simp
   qed
 
   subsection \<open>Complementation\<close>
 
   schematic_goal complement_impl:
     assumes [simp]: "finite (NBA.nodes A)"
     assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "(?f :: ?'c, op_translate (complement_4 A)) \<in> ?R"
     by (autoref_monadic (plain))
   concrete_definition complement_impl uses complement_impl
 
   theorem complement_impl_correct:
     assumes "finite (NBA.nodes A)"
     assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "NBA.language (nbae_nba (nbaei_nbae (complement_impl Ai))) =
       streams (nba.alphabet A) - NBA.language A"
     using op_translate_language[OF complement_impl.refine[OF assms]]
     using complement_4_correct[OF assms(1)]
     by simp
 
   subsection \<open>Language Subset\<close>
 
   definition [simp]: "op_language_subset A B \<equiv> NBA.language A \<subseteq> NBA.language B"
 
   lemmas [autoref_op_pat] = op_language_subset_def[symmetric]
 
   schematic_goal language_subset_impl:
     assumes [simp]: "finite (NBA.nodes B)"
     assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "(?f :: ?'c, do {
       let AB' = intersect' A (complement_4 B);
       ASSERT (finite (NGBA.nodes AB'));
       RETURN (NGBA.language AB' = {})
     }) \<in> ?R"
 		by (autoref_monadic (plain))
   concrete_definition language_subset_impl uses language_subset_impl
   lemma language_subset_impl_refine[autoref_rules]:
     assumes "SIDE_PRECOND (finite (NBA.nodes A))"
     assumes "SIDE_PRECOND (finite (NBA.nodes B))"
     assumes "SIDE_PRECOND (nba.alphabet A \<subseteq> nba.alphabet B)"
     assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "(language_subset_impl Ai Bi, (OP op_language_subset :::
       \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
   proof -
     have "(RETURN (language_subset_impl Ai Bi), do {
       let AB' = intersect' A (complement_4 B);
       ASSERT (finite (NGBA.nodes AB'));
       RETURN (NGBA.language AB' = {})
     }) \<in> \<langle>bool_rel\<rangle> nres_rel"
       using language_subset_impl.refine assms(2, 4, 5) unfolding autoref_tag_defs by this
     also have "(do {
       let AB' = intersect' A (complement_4 B);
       ASSERT (finite (NGBA.nodes AB'));
       RETURN (NGBA.language AB' = {})
     }, RETURN (NBA.language A \<subseteq> NBA.language B)) \<in> \<langle>bool_rel\<rangle> nres_rel"
     proof refine_vcg
       show "finite (NGBA.nodes (intersect' A (complement_4 B)))" using assms(1, 2) by auto
       have 1: "NBA.language A \<subseteq> streams (nba.alphabet B)"
         using nba.language_alphabet streams_mono2 assms(3) unfolding autoref_tag_defs by blast
       have 2: "NBA.language (complement_4 B) = streams (nba.alphabet B) - NBA.language B"
         using complement_4_correct assms(2) by auto
       show "(NGBA.language (intersect' A (complement_4 B)) = {},
         NBA.language A \<subseteq> NBA.language B) \<in> bool_rel" using 1 2 by auto
     qed
     finally show ?thesis using RETURN_nres_relD unfolding nres_rel_comp by force
   qed
 
   subsection \<open>Language Equality\<close>
 
   definition [simp]: "op_language_equal A B \<equiv> NBA.language A = NBA.language B"
 
   lemmas [autoref_op_pat] = op_language_equal_def[symmetric]
 
   schematic_goal language_equal_impl:
     assumes [simp]: "finite (NBA.nodes A)"
     assumes [simp]: "finite (NBA.nodes B)"
     assumes [simp]: "nba.alphabet A = nba.alphabet B"
     assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "(?f :: ?'c, NBA.language A \<subseteq> NBA.language B \<and> NBA.language B \<subseteq> NBA.language A) \<in> ?R"
     by autoref
   concrete_definition language_equal_impl uses language_equal_impl
   lemma language_equal_impl_refine[autoref_rules]:
     assumes "SIDE_PRECOND (finite (NBA.nodes A))"
     assumes "SIDE_PRECOND (finite (NBA.nodes B))"
     assumes "SIDE_PRECOND (nba.alphabet A = nba.alphabet B)"
     assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "(language_equal_impl Ai Bi, (OP op_language_equal :::
       \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
     using language_equal_impl.refine[OF assms[unfolded autoref_tag_defs]] by auto
 
   schematic_goal product_impl:
     assumes [simp]: "finite (NBA.nodes B)"
     assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
     shows "(?f :: ?'c, do {
       let AB' = intersect A (complement_4 B);
       ASSERT (finite (NBA.nodes AB'));
       op_translate AB'
     }) \<in> ?R"
 		by (autoref_monadic (plain))
   concrete_definition product_impl uses product_impl
 
   (* TODO: possible optimizations:
     - introduce op_map_map operation for maps instead of manually iterating via FOREACH
     - consolidate various binds and maps in expand_map_get_7 *)
   export_code
     Set.empty Set.insert Set.member
     "Inf :: 'a set set \<Rightarrow> 'a set" "Sup :: 'a set set \<Rightarrow> 'a set" image Pow set
     nat_of_integer integer_of_nat
     Variable Negation Conjunction Disjunction satisfies map_formula
     nbaei alphabetei initialei transitionei acceptingei
     nbae_nba_impl complement_impl language_equal_impl product_impl
     in SML module_name Complementation file_prefix Complementation
 
 end
\ No newline at end of file
diff --git a/thys/CakeML/generated/LemExtraDefs.thy b/thys/CakeML/generated/LemExtraDefs.thy
--- a/thys/CakeML/generated/LemExtraDefs.thy
+++ b/thys/CakeML/generated/LemExtraDefs.thy
@@ -1,1255 +1,1255 @@
 (*========================================================================*)
 (*                        Lem                                             *)
 (*                                                                        *)
 (*          Dominic Mulligan, University of Cambridge                     *)
 (*          Francesco Zappa Nardelli, INRIA Paris-Rocquencourt            *)
 (*          Gabriel Kerneis, University of Cambridge                      *)
 (*          Kathy Gray, University of Cambridge                           *)
 (*          Peter Boehm, University of Cambridge (while working on Lem)   *)
 (*          Peter Sewell, University of Cambridge                         *)
 (*          Scott Owens, University of Kent                               *)
 (*          Thomas Tuerk, University of Cambridge                         *)
 (*          Brian Campbell, University of Edinburgh                       *)
 (*          Shaked Flur, University of Cambridge                          *)
 (*          Thomas Bauereiss, University of Cambridge                     *)
 (*          Stephen Kell, University of Cambridge                         *)
 (*          Thomas Williams                                               *)
 (*          Lars Hupel                                                    *)
 (*          Basile Clement                                                *)
 (*                                                                        *)
 (*  The Lem sources are copyright 2010-2018                               *)
 (*  by the authors above and Institut National de Recherche en            *)
 (*  Informatique et en Automatique (INRIA).                               *)
 (*                                                                        *)
 (*  All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli}   *)
 (*  are distributed under the license below.  The former are distributed  *)
 (*  under the LGPLv2, as in the LICENSE file.                             *)
 (*                                                                        *)
 (*                                                                        *)
 (*  Redistribution and use in source and binary forms, with or without    *)
 (*  modification, are permitted provided that the following conditions    *)
 (*  are met:                                                              *)
 (*  1. Redistributions of source code must retain the above copyright     *)
 (*  notice, this list of conditions and the following disclaimer.         *)
 (*  2. Redistributions in binary form must reproduce the above copyright  *)
 (*  notice, this list of conditions and the following disclaimer in the   *)
 (*  documentation and/or other materials provided with the distribution.  *)
 (*  3. The names of the authors may not be used to endorse or promote     *)
 (*  products derived from this software without specific prior written    *)
 (*  permission.                                                           *)
 (*                                                                        *)
 (*  THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS    *)
 (*  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED     *)
 (*  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE    *)
 (*  ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY       *)
 (*  DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL    *)
 (*  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE     *)
 (*  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS         *)
 (*  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER  *)
 (*  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR       *)
 (*  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN   *)
 (*  IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                         *)
 (*========================================================================*)
 
 chapter \<open>Auxiliary Definitions needed by Lem\<close>
 
 theory "LemExtraDefs"
 
 imports
    Main
-   "HOL-Library.Permutation"
+   "HOL-Library.List_Permutation"
    "HOL-Library.While_Combinator"
 begin
 
 subsection \<open>General\<close>
 
 consts failwith :: " 'a \<Rightarrow> 'b"
 
 subsection \<open>Lists\<close>
 
 fun index :: " 'a list \<Rightarrow> nat \<Rightarrow> 'a option "  where
    "index [] n = None"
  | "index (x # xs) 0 = Some x"
  | "index (x # xs) (Suc n) = index xs n"
 
 lemma index_eq_some [simp]:
    "index l n = Some x \<longleftrightarrow> (n < length l \<and> (x = l ! n))"
 proof (induct l arbitrary: n x)
   case Nil thus ?case by simp
 next
   case (Cons e es n x)
   note ind_hyp = this
 
   show ?case
   proof (cases n)
     case 0 thus ?thesis by auto
   next
     case (Suc n')
     with ind_hyp show ?thesis by simp
   qed
 qed
 
 lemma index_eq_none [simp]:
    "index l n = None \<longleftrightarrow> length l \<le> n"
 by (rule iffD1[OF Not_eq_iff]) auto
 
 
 lemma index_simps [simp]:
    "length l \<le> n \<Longrightarrow> index l n = None"
    "n < length l \<Longrightarrow> index l n = Some (l ! n)"
 by (simp_all)
 
 fun find_indices :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat list" where
    "find_indices P [] = []"
  | "find_indices P (x # xs) = (if P x then 0 # (map Suc (find_indices P xs)) else (map Suc (find_indices P xs)))"
 
 lemma length_find_indices :
   "length (find_indices P l) \<le> length l"
 by (induct l) auto
 
 lemma sorted_map_suc :
   "sorted l \<Longrightarrow> sorted (map Suc l)"
 by (induct l) (simp_all)
 
 lemma sorted_find_indices :
   "sorted (find_indices P xs)"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   from sorted_map_suc[OF this]
   show ?case
     by (simp)
 qed
 
 lemma find_indices_set [simp] :
   "set (find_indices P l) = {i. i < length l \<and> P (l ! i)}"
 proof (intro set_eqI)
   fix i
   show "i \<in> set (find_indices P l) \<longleftrightarrow> (i \<in> {i. i < length l \<and> P (l ! i)})"
   proof (induct l arbitrary: i)
     case Nil thus ?case by simp
   next
     case (Cons x l' i)
     note ind_hyp = this
     show ?case
     proof (cases i)
       case 0 thus ?thesis by auto
     next
       case (Suc i') with ind_hyp[of i'] show ?thesis by auto
     qed
   qed
 qed
 
 definition find_index where
   "find_index P xs = (case find_indices P xs of
       []    \<Rightarrow> None
     | i # _ \<Rightarrow> Some i)"
 
 lemma find_index_eq_some [simp] :
   "(find_index P xs = Some ii) \<longleftrightarrow> (ii < length xs \<and> P (xs ! ii) \<and> (\<forall>i' < ii. \<not>(P (xs ! i'))))"
   (is "?lhs = ?rhs")
 proof (cases "find_indices P xs")
   case Nil
   with find_indices_set[of P xs]
   show ?thesis
     unfolding find_index_def by auto
 next
   case (Cons i il) note find_indices_eq = this
 
   from sorted_find_indices[of P xs] find_indices_eq
   have "sorted (i # il)" by simp
   hence i_leq: "\<And>i'. i' \<in> set (i # il) \<Longrightarrow> i \<le> i'" by auto
 
   from find_indices_set[of P xs, unfolded find_indices_eq]
   have set_i_il_eq:"\<And>i'. i' \<in> set (i # il) = (i' < length xs \<and> P (xs ! i'))"
     by simp
 
   have lhs_eq: "find_index P xs = Some i"
     unfolding find_index_def find_indices_eq by simp
 
   show ?thesis
   proof (intro iffI)
     assume ?lhs
     with lhs_eq have ii_eq[simp]: "ii = i" by simp
 
     from set_i_il_eq[of i] i_leq[unfolded set_i_il_eq]
     show ?rhs by auto (metis leD less_trans)
   next
     assume ?rhs
     with set_i_il_eq[of ii]
     have "ii \<in> set (i # il) \<and> (ii \<le> i)"
       by (metis leI length_pos_if_in_set nth_Cons_0 nth_mem set_i_il_eq)
 
     with i_leq [of ii] have "i = ii" by simp
     thus ?lhs unfolding lhs_eq by simp
   qed
 qed
 
 lemma find_index_eq_none [simp] :
   "(find_index P xs = None) \<longleftrightarrow> (\<forall>x \<in> set xs. \<not>(P x))" (is "?lhs = ?rhs")
 proof (rule iffD1[OF Not_eq_iff], intro iffI)
   assume "\<not> ?lhs"
   then obtain i where "find_index P xs = Some i" by auto
   hence "i < length xs \<and> P (xs ! i)" by simp
   thus "\<not> ?rhs" by auto
 next
   let ?p = "(\<lambda>i. i < length xs \<and> P(xs ! i))"
 
   assume "\<not> ?rhs"
   then obtain i where "?p i"
     by (metis in_set_conv_nth)
 
   from LeastI [of ?p, OF \<open>?p i\<close>]
   have "?p (Least ?p)" .
 
   hence "find_index P xs = Some (Least ?p)"
     by (subst find_index_eq_some) (metis (mono_tags) less_trans not_less_Least)
 
   thus "\<not> ?lhs" by blast
 qed
 
 definition genlist where
   "genlist f n = map f (upt 0 n)"
 
 lemma genlist_length [simp] :
   "length (genlist f n) = n"
 unfolding genlist_def by simp
 
 lemma genlist_simps [simp]:
    "genlist f 0 = []"
    "genlist f (Suc n) = genlist f n @ [f n]"
 unfolding genlist_def by auto
 
 definition split_at where
   "split_at n l = (take n l, drop n l)"
 
 fun delete_first :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list) option "  where
     "delete_first P [] = None"
   | "delete_first P (x # xs) =
      (if (P x) then Some xs else
       map_option (\<lambda>xs'. x # xs') (delete_first P xs))"
 declare delete_first.simps [simp del]
 
 lemma delete_first_simps [simp] :
    "delete_first P [] = None"
    "P x \<Longrightarrow> delete_first P (x # xs) = Some xs"
    "\<not>(P x) \<Longrightarrow> delete_first P (x # xs) = map_option (\<lambda>xs'. x # xs') (delete_first P xs)"
 unfolding delete_first.simps by auto
 
 lemmas delete_first_unroll = delete_first.simps(2)
 
 
 lemma delete_first_eq_none [simp] :
   "delete_first P l = None \<longleftrightarrow> (\<forall>x \<in> set l. \<not> (P x))"
 by (induct l) (auto simp add: delete_first_unroll)
 
 lemma delete_first_eq_some :
   "delete_first P l = (Some l') \<longleftrightarrow> (\<exists>l1 x l2. P x \<and> (\<forall>x \<in> set l1. \<not>(P x)) \<and> (l = l1 @ (x # l2)) \<and> (l' = l1 @ l2))"
   (is "?lhs l l' = (\<exists>l1 x l2. ?rhs_body l1 x l2 l l')")
 proof (induct l arbitrary: l')
   case Nil thus ?case by simp
 next
   case (Cons e l l')
   note ind_hyp = this
 
   show ?case
   proof (cases "P e")
     case True
     show ?thesis
     proof (rule iffI)
       assume "?lhs (e # l) l'"
       with \<open>P e\<close> have "l = l'" by simp
       with \<open>P e\<close> have "?rhs_body [] e l' (e # l) l'" by simp
       thus "\<exists>l1 x l2. ?rhs_body l1 x l2 (e # l) l'" by blast
     next
       assume "\<exists>l1 x l2. ?rhs_body l1 x l2 (e # l) l'"
       then obtain l1 x l2 where body_ok: "?rhs_body l1 x l2 (e # l) l'" by blast
 
       from body_ok \<open>P e\<close> have l1_eq[simp]: "l = l'"
         by (cases l1) (simp_all)
       with \<open>P e\<close> show "?lhs (e # l) l'" by simp
     qed
   next
     case False
     define rhs_pred where "rhs_pred \<equiv> \<lambda>l1 x l2 l l'. ?rhs_body l1 x l2 l l'"
     have rhs_fold: "\<And>l1 x l2 l l'. ?rhs_body l1 x l2 l l' = rhs_pred l1 x l2 l l'"
        unfolding rhs_pred_def by simp
 
     have "(\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l') = (\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l')"
     proof (intro iffI)
       assume "\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l'"
       then obtain z l1 x l2 where "rhs_pred l1 x l2 l z" and l'_eq: "l' = e # z" by auto
       with \<open>\<not>(P e)\<close> have "rhs_pred (e # l1) x l2 (e # l) l'"
         unfolding rhs_pred_def by simp
       thus "\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l'" by blast
     next
       assume "\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l'"
       then obtain l1 x l2 where "rhs_pred l1 x l2 (e # l) l'" by blast
       with \<open>\<not> (P e)\<close> obtain l1' where l1_eq[simp]: "l1 = e # l1'"
         unfolding rhs_pred_def by (cases l1) (auto)
 
       with \<open>rhs_pred l1 x l2 (e # l) l'\<close>
       have "rhs_pred l1' x l2 l (l1' @ l2) \<and> e # (l1' @ l2) = l'"
         unfolding rhs_pred_def by (simp)
       thus "\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l'" by blast
     qed
     with \<open>\<not> P e\<close> show ?thesis
       unfolding rhs_fold
       by (simp add: ind_hyp[unfolded rhs_fold])
   qed
 qed
 
 
 lemma perm_eval [code] :
   "perm [] l \<longleftrightarrow> l = []" (is ?g1)
   "perm (x # xs) l \<longleftrightarrow> (case delete_first (\<lambda>e. e = x) l of
        None => False
      | Some l' => perm xs l')" (is ?g2)
 proof -
   show ?g1 by auto
 next
   show ?g2
   proof (cases "delete_first (\<lambda>e. e = x) l")
     case None note del_eq = this
     hence "x \<notin> set l" by auto
     with perm_set_eq [of "x # xs" l]
     have "\<not> perm (x # xs) l" by auto
     thus ?thesis unfolding del_eq by simp
   next
     case (Some l') note del_eq = this
 
     from del_eq[unfolded delete_first_eq_some]
     obtain l1 l2 where l_eq: "l = l1 @ [x] @ l2" and l'_eq: "l' = l1 @ l2" by auto
 
     have "(x # xs <~~> l1 @ x # l2) = (xs <~~> l1 @ l2)"
     proof -
       from perm_append_swap [of l1 "[x]"]
            perm_append2 [of "l1 @ [x]" "x # l1" l2]
       have "l1 @ x # l2 <~~> x # (l1 @ l2)" by simp
       hence "x # xs <~~> l1 @ x # l2 \<longleftrightarrow> x # xs <~~> x # (l1 @ l2)"
         by (metis perm.trans perm_sym)
       thus ?thesis by simp
     qed
     with del_eq l_eq l'_eq show ?thesis by simp
   qed
 qed
 
 
 fun sorted_by  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> bool "  where
    "sorted_by cmp [] = True"
  | "sorted_by cmp [_] = True"
  | "sorted_by cmp (x1 # x2 # xs) = ((cmp x1 x2) \<and> sorted_by cmp (x2 # xs))"
 
 lemma sorted_by_lesseq [simp] :
   "sorted_by ((\<le>) :: ('a::{linorder}) => 'a => bool) = sorted"
 proof (rule ext)
   fix l :: "'a list"
   show "sorted_by (\<le>) l = sorted l"
   proof (induct l)
     case Nil thus ?case by simp
   next
     case (Cons x xs)
     thus ?case by (cases xs) (simp_all del: sorted.simps(2) add: sorted2_simps)
   qed
 qed
 
 lemma sorted_by_cons_imp :
   "sorted_by cmp (x # xs) \<Longrightarrow> sorted_by cmp xs"
 by (cases xs) simp_all
 
 lemma sorted_by_cons_trans :
   assumes trans_cmp: "transp cmp"
   shows "sorted_by cmp (x # xs) = ((\<forall>x' \<in> set xs . cmp x x') \<and> sorted_by cmp xs)"
 proof (induct xs arbitrary: x)
   case Nil thus ?case by simp
 next
   case (Cons x2 xs x1)
   note ind_hyp = this
 
   from trans_cmp
   show ?case
     by (auto simp add: ind_hyp transp_def)
 qed
 
 
 fun insert_sort_insert_by  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
   "insert_sort_insert_by cmp e ([]) = ( [e])"
 | "insert_sort_insert_by cmp e (x # xs) = ( if cmp e x then (e # (x # xs)) else x # (insert_sort_insert_by cmp e xs))"
 
 
 lemma insert_sort_insert_by_length [simp] :
   "length (insert_sort_insert_by cmp e l) = Suc (length l)"
 by (induct l) auto
 
 lemma insert_sort_insert_by_set [simp] :
   "set (insert_sort_insert_by cmp e l) = insert e (set l)"
 by (induct l) auto
 
 lemma insert_sort_insert_by_perm :
   "(insert_sort_insert_by cmp e l) <~~> (e # l)"
 proof (induct l)
   case Nil thus ?case by simp
 next
   case (Cons e2 l')
   note ind_hyp = this
 
   have "e2 # e # l' <~~> e # e2 # l'" by (rule perm.swap)
   hence "e2 # insert_sort_insert_by cmp e l' <~~> e # e2 # l'"
     using ind_hyp by (metis cons_perm_eq perm.trans)
   thus ?case by simp
 qed
 
 
 lemma insert_sort_insert_by_sorted_by :
 assumes cmp_cases: "\<And>y. y \<in> set l \<Longrightarrow> \<not> (cmp e y) \<Longrightarrow> cmp y e"
 assumes cmp_trans: "transp cmp"
 shows "sorted_by cmp l \<Longrightarrow> sorted_by cmp (insert_sort_insert_by cmp e l)"
 using cmp_cases
 proof (induct l)
   case Nil thus ?case by simp
 next
   case (Cons x1 l')
   note ind_hyp = Cons(1)
   note sorted_x1_l' = Cons(2)
   note cmp_cases = Cons(3)
 
   show ?case
   proof (cases l')
     case Nil with cmp_cases show ?thesis by simp
   next
     case (Cons x2 l'') note l'_eq = this
 
     from l'_eq sorted_x1_l' have "cmp x1 x2" "sorted_by cmp l'" by simp_all
 
     show ?thesis
     proof (cases "cmp e x1")
       case True
       with \<open>cmp x1 x2\<close> \<open>sorted_by cmp l'\<close>
       have "sorted_by cmp (x1 # l')"
         unfolding l'_eq by (simp)
       with \<open>cmp e x1\<close>
       show ?thesis by simp
     next
       case False
 
       with cmp_cases have "cmp x1 e" by simp
       have "\<And>x'.  x' \<in> set l' \<Longrightarrow> cmp x1 x'"
       proof -
         fix x'
         assume "x' \<in> set l'"
         hence "x' = x2 \<or> cmp x2 x'"
           using \<open>sorted_by cmp l'\<close> l'_eq sorted_by_cons_trans [OF cmp_trans, of x2 l'']
           by auto
         with transpD[OF cmp_trans, of x1 x2 x'] \<open>cmp x1 x2\<close>
         show "cmp x1 x'" by blast
       qed
       hence "sorted_by cmp (x1 # insert_sort_insert_by cmp e l')"
         using ind_hyp [OF \<open>sorted_by cmp l'\<close>] \<open>cmp x1 e\<close> cmp_cases
         unfolding sorted_by_cons_trans[OF cmp_trans]
         by simp
       with \<open>\<not>(cmp e x1)\<close>
       show ?thesis by simp
     qed
   qed
 qed
 
 
 
 fun insert_sort_by :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     "insert_sort_by cmp [] = []"
   | "insert_sort_by cmp (x # xs) = insert_sort_insert_by cmp x (insert_sort_by cmp xs)"
 
 
 lemma insert_sort_by_perm :
   "(insert_sort_by cmp l) <~~> l"
 proof (induct l)
   case Nil thus ?case by simp
 next
   case (Cons x l)
   thus ?case
    by simp (metis cons_perm_eq insert_sort_insert_by_perm perm.trans)
 qed
 
 lemma insert_sort_by_length [simp]:
   "length (insert_sort_by cmp l) = length l"
 by (induct l) auto
 
 lemma insert_sort_by_set [simp]:
   "set (insert_sort_by cmp l) = set l"
 by (induct l) auto
 
 definition sort_by where
   "sort_by = insert_sort_by"
 
 lemma sort_by_simps [simp]:
   "length (sort_by cmp l) = length l"
   "set (sort_by cmp l) = set l"
 unfolding sort_by_def by simp_all
 
 lemma sort_by_perm :
   "sort_by cmp l <~~> l"
 unfolding sort_by_def
 by (simp add: insert_sort_by_perm)
 
 subsection \<open>Maps\<close>
 
 definition map_image :: "('v \<Rightarrow> 'w) \<Rightarrow> ('k, 'v) map \<Rightarrow> ('k, 'w) map" where
   "map_image f m = (\<lambda>k. map_option f (m k))"
 
 definition map_domain_image :: "('k \<Rightarrow> 'v \<Rightarrow> 'w) \<Rightarrow> ('k, 'v) map \<Rightarrow> ('k, 'w) map" where
   "map_domain_image f m = (\<lambda>k. map_option (f k) (m k))"
 
 
 lemma map_image_simps [simp]:
   "(map_image f m) k = None \<longleftrightarrow> m k = None"
   "(map_image f m) k = Some x \<longleftrightarrow> (\<exists>x'. (m k = Some x') \<and> (x = f x'))"
   "(map_image f Map.empty) = Map.empty"
   "(map_image f (m (k \<mapsto> v)) = (map_image f m) (k \<mapsto> f v))"
 unfolding map_image_def by auto
 
 lemma map_image_dom_ran [simp]:
   "dom (map_image f m) = dom m"
   "ran (map_image f m) = f ` (ran m)"
 unfolding dom_def ran_def by auto
 
 definition map_to_set :: "('k, 'v) map \<Rightarrow> ('k * 'v) set" where
   "map_to_set m = { (k, v) . m k = Some v }"
 
 lemma map_to_set_simps [simp] :
   "map_to_set Map.empty = {}"  (is ?g1)
   "map_to_set (m ((k::'k) \<mapsto> (v::'v))) = (insert (k, v) (map_to_set (m |` (- {k}))))" (is ?g2)
 proof -
   show ?g1 unfolding map_to_set_def by simp
 next
   show ?g2
   proof (rule set_eqI)
     fix kv :: "('k * 'v)"
     obtain k' v' where kv_eq[simp]: "kv = (k', v')" by (rule prod.exhaust)
 
     show "(kv \<in> map_to_set (m(k \<mapsto> v))) = (kv \<in> insert (k, v) (map_to_set (m |` (- {k}))))"
       by (auto simp add: map_to_set_def)
   qed
 qed
 
 
 subsection \<open>Sets\<close>
 
 definition "set_choose s \<equiv> (SOME x. (x \<in> s))"
   
 definition without_trans_edges :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
   "without_trans_edges S \<equiv>
      let ts = trancl S in
        { (x, y) \<in> S. \<forall>z \<in> snd ` S. x \<noteq> z \<and> y \<noteq> z \<longrightarrow> \<not> ((x, z) \<in> ts \<and> (z, y) \<in> ts)}"
   
 definition unbounded_lfp :: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where
   "unbounded_lfp S f \<equiv>
      while (\<lambda>x. x \<subset> S) f S"
   
 definition unbounded_gfp :: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where
   "unbounded_gfp S f \<equiv>
      while (\<lambda>x. S \<subset> x) f S"
 
 lemma set_choose_thm[simp]:
   "s \<noteq> {} \<Longrightarrow> (set_choose s) \<in> s"
 unfolding set_choose_def
 by (rule someI_ex) auto
 
 lemma set_choose_sing [simp]:
   "set_choose {x} = x"
   unfolding set_choose_def
   by auto
 
 lemma set_choose_code [code]:
   "set_choose (set [x]) = x"
 by auto
 
 lemma set_choose_in [intro] :
   assumes "s \<noteq> {}"
   shows "set_choose s \<in> s"
 proof -
   from \<open>s \<noteq> {}\<close>
   obtain x where "x \<in> s" by auto
   thus ?thesis
     unfolding set_choose_def
     by (rule someI)
 qed
 
 
 definition set_case where
   "set_case s c_empty c_sing c_else =
     (if (s = {}) then c_empty else
     (if (card s = 1) then c_sing (set_choose s) else
        c_else))"
 
 lemma set_case_simps [simp] :
   "set_case {} c_empty c_sing c_else = c_empty"
   "set_case {x} c_empty c_sing c_else = c_sing x"
   "card s > 1 \<Longrightarrow> set_case s c_empty c_sing c_else = c_else"
   "\<not>(finite s) \<Longrightarrow> set_case s c_empty c_sing c_else = c_else"
 unfolding set_case_def by auto
 
 lemma set_case_simp_insert2 [simp] :
 assumes x12_neq: "x1 \<noteq> x2"
 shows "set_case (insert x1 (insert x2 xs))  c_empty c_sing c_else = c_else"
 proof (cases "finite xs")
   case False thus ?thesis by (simp)
 next
   case True note fin_xs = this
 
   have "card {x1,x2} \<le> card (insert x1 (insert x2 xs))"
     by (rule card_mono) (auto simp add: fin_xs)
   with x12_neq have "1 < card (insert x1 (insert x2 xs))" by simp
   thus ?thesis by auto
 qed
 
 lemma set_case_code [code] :
   "set_case (set []) c_empty c_sing c_else = c_empty"
   "set_case (set [x]) c_empty c_sing c_else = c_sing x"
   "set_case (set (x1 # x2 # xs)) c_empty c_sing c_else =
    (if (x1 = x2) then
      set_case (set (x2 # xs)) c_empty c_sing c_else
    else
      c_else)"
 by auto
 
 definition set_lfp:: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where
   "set_lfp s f = lfp (\<lambda>s'. f s' \<union> s)"
 
 lemma set_lfp_tail_rec_def :
 assumes mono_f: "mono f"
 shows "set_lfp s f = (if (f s) \<subseteq> s then s else (set_lfp (s \<union> f s) f))" (is "?ls = ?rs")
 proof (cases "f s \<subseteq> s")
   case True note fs_sub_s = this
 
   from fs_sub_s have "\<Inter>{u. f u \<union> s \<subseteq> u} = s" by auto
   hence "?ls = s" unfolding set_lfp_def lfp_def .
   with fs_sub_s show "?ls = ?rs" by simp
 next
   case False note not_fs_sub_s = this
 
   from mono_f have mono_f': "mono (\<lambda>s'. f s' \<union> s)"
     unfolding mono_def by auto
 
   have "\<Inter>{u. f u \<union> s \<subseteq> u} = \<Inter>{u. f u \<union> (s \<union> f s) \<subseteq> u}" (is "\<Inter>?S1 = \<Inter>?S2")
   proof
     have "?S2 \<subseteq> ?S1" by auto
     thus "\<Inter>?S1 \<subseteq> \<Inter>?S2" by (rule Inf_superset_mono)
   next
     { fix e
       assume "e \<in> \<Inter>?S2"
       hence S2_prop: "\<And>s'. f s' \<subseteq> s' \<Longrightarrow> s \<subseteq> s' \<Longrightarrow> f s \<subseteq> s' \<Longrightarrow> e \<in> s'" by simp
 
       { fix s'
         assume "f s' \<subseteq> s'" "s \<subseteq> s'"
 
         from mono_f \<open>s \<subseteq> s'\<close>
         have "f s \<subseteq> f s'" unfolding mono_def by simp
         with \<open>f s' \<subseteq> s'\<close> have "f s \<subseteq> s'" by simp
         with \<open>f s' \<subseteq> s'\<close> \<open>s \<subseteq> s'\<close> S2_prop
         have "e \<in> s'" by simp
       }
       hence "e \<in> \<Inter>?S1" by simp
     }
     thus "\<Inter>?S2 \<subseteq> \<Inter>?S1" by auto
   qed
   hence "?ls = (set_lfp (s \<union> f s) f)"
      unfolding set_lfp_def lfp_def .
   with not_fs_sub_s show "?ls = ?rs" by simp
 qed
 
 lemma set_lfp_simps [simp] :
 "mono f \<Longrightarrow> f s \<subseteq> s \<Longrightarrow> set_lfp s f = s"
 "mono f \<Longrightarrow> \<not>(f s \<subseteq> s) \<Longrightarrow> set_lfp s f = (set_lfp (s \<union> f s) f)"
 by (metis set_lfp_tail_rec_def)+
 
 
 fun insert_in_list_at_arbitrary_pos where
    "insert_in_list_at_arbitrary_pos x [] = {[x]}"
  | "insert_in_list_at_arbitrary_pos x (y # ys) =
     insert (x # y # ys) ((\<lambda>l. y # l) ` (insert_in_list_at_arbitrary_pos x ys))"
 
 lemma insert_in_list_at_arbitrary_pos_thm :
   "xl \<in> insert_in_list_at_arbitrary_pos x l \<longleftrightarrow>
    (\<exists>l1 l2. l = l1 @ l2 \<and> xl = l1 @ [x] @ l2)"
 proof (induct l arbitrary: xl)
   case Nil thus ?case by simp
 next
   case (Cons y l xyl)
   note ind_hyp = this
 
   show ?case
   proof (rule iffI)
     assume xyl_in: "xyl \<in> insert_in_list_at_arbitrary_pos x (y # l)"
     show "\<exists>l1 l2. y # l = l1 @ l2 \<and> xyl = l1 @ [x] @ l2"
     proof (cases "xyl = x # y # l")
       case True
       hence "y # l = [] @ (y # l) \<and> xyl = [] @ [x] @ (y # l)" by simp
       thus ?thesis by blast
     next
       case False
       with xyl_in have "xyl \<in> (#) y ` insert_in_list_at_arbitrary_pos x l" by simp
       with ind_hyp obtain l1 l2 where "l = l1 @ l2 \<and> xyl = y # l1 @ x # l2"
          by (auto simp add: image_def Bex_def)
       hence "y # l = (y # l1) @ l2 \<and> xyl = (y # l1) @ [x] @ l2" by simp
       thus ?thesis by blast
     qed
   next
     assume "\<exists>l1 l2. y # l = l1 @ l2 \<and> xyl = l1 @ [x] @ l2"
     then obtain l1 l2 where yl_eq: "y # l = l1 @ l2" and xyl_eq: "xyl = l1 @ [x] @ l2" by blast
     show "xyl \<in> insert_in_list_at_arbitrary_pos x (y # l)"
     proof (cases l1)
       case Nil
       with yl_eq xyl_eq
       have "xyl = x # y # l" by simp
       thus ?thesis by simp
     next
       case (Cons y' l1')
       with yl_eq have l1_eq: "l1 = y # l1'" and l_eq: "l = l1' @ l2" by simp_all
 
       have "\<exists>l1'' l2''. l = l1'' @ l2'' \<and> l1' @ [x] @ l2 = l1'' @ [x] @ l2''"
         apply (rule_tac exI[where x = l1'])
         apply (rule_tac exI [where x = l2])
         apply (simp add: l_eq)
       done
       hence "(l1' @ [x] @ l2) \<in> insert_in_list_at_arbitrary_pos x l"
         unfolding ind_hyp by blast
       hence "\<exists>l'. l' \<in> insert_in_list_at_arbitrary_pos x l \<and> l1 @ x # l2 = y # l'"
         by (rule_tac exI [where x = "l1' @ [x] @ l2"]) (simp add: l1_eq)
       thus ?thesis
         by (simp add: image_def Bex_def xyl_eq)
     qed
   qed
 qed
 
 definition list_of_set_set :: "'a set \<Rightarrow> ('a list) set" where
 "list_of_set_set s = { l . (set l = s) \<and> distinct l }"
 
 lemma list_of_set_set_empty [simp]:
   "list_of_set_set {} = {[]}"
 unfolding list_of_set_set_def by auto
 
 lemma list_of_set_set_insert [simp] :
   "list_of_set_set (insert x s) =
      \<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set (s - {x})))"
    (is "?lhs = ?rhs")
 proof (intro set_eqI)
   fix l
 
   have "(set l = insert x s \<and> distinct l) \<longleftrightarrow> (\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2)"
   proof (intro iffI)
     assume "set l = insert x s \<and> distinct l"
     hence set_l_eq: "set l = insert x s" and "distinct l" by simp_all
 
     from \<open>set l = insert x s\<close>
     have "x \<in> set l" by simp
     then obtain l1 l2 where l_eq: "l = l1 @ x # l2"
       unfolding in_set_conv_decomp by blast
 
     from \<open>distinct l\<close>  l_eq
     have "distinct (l1 @ l2)" and x_nin: "x \<notin> set (l1 @ l2)"
       by auto
 
     from x_nin set_l_eq[unfolded l_eq]
     have set_l12_eq: "set (l1 @ l2) = s - {x}"
       by auto
 
     from \<open>distinct (l1 @ l2)\<close> l_eq set_l12_eq
     show "\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2"
       by blast
   next
     assume "\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2"
     then obtain l1 l2 where "set (l1 @ l2) = s - {x}"  "distinct (l1 @ l2)" "l = l1 @ x # l2"
       by blast
     thus "set l = insert x s \<and> distinct l"
        by auto
   qed
 
   thus "l \<in> list_of_set_set (insert x s) \<longleftrightarrow> l \<in> (\<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set (s - {x}))))"
      unfolding list_of_set_set_def
      by (simp add: insert_in_list_at_arbitrary_pos_thm ex_simps[symmetric] del: ex_simps)
 qed
 
 lemma list_of_set_set_code [code]:
   "list_of_set_set (set []) = {[]}"
   "list_of_set_set (set (x # xs)) =
      \<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set ((set xs) - {x})))"
 by simp_all
 
 lemma list_of_set_set_is_empty :
   "list_of_set_set s = {} \<longleftrightarrow> \<not> (finite s)"
 proof -
   have "finite s \<longleftrightarrow> (\<exists>l. set l = s \<and> distinct l)"
   proof (rule iffI)
     assume "\<exists>l. set l = s \<and> distinct l" then
     obtain l where "s = set l" by blast
     thus "finite s" by simp
   next
     assume "finite s"
     thus "\<exists>l. set l = s \<and> distinct l"
     proof (induct s)
       case empty
       show ?case by auto
     next
       case (insert e s)
       note e_nin_s = insert(2)
       from insert(3) obtain l where set_l: "set l = s" and dist_l: "distinct l" by blast
 
       from set_l have set_el: "set (e # l) = insert e s" by auto
       from dist_l set_l e_nin_s have dist_el: "distinct (e # l)" by simp
 
       from set_el dist_el show ?case by blast
     qed
   qed
   thus ?thesis
     unfolding list_of_set_set_def by simp
 qed
 
 definition list_of_set :: "'a set \<Rightarrow> 'a list" where
    "list_of_set s = set_choose (list_of_set_set s)"
 
 lemma list_of_set [simp] :
   assumes fin_s: "finite s"
   shows "set (list_of_set s) = s"
         "distinct (list_of_set s)"
 proof -
   from fin_s list_of_set_set_is_empty[of s]
   have "\<not> (list_of_set_set s = {})" by simp
   hence "list_of_set s \<in> list_of_set_set s"
     unfolding list_of_set_def
     by (rule set_choose_thm)
   thus "set (list_of_set s) = s"
        "distinct (list_of_set s)" unfolding list_of_set_set_def
   by simp_all
 qed
 
 lemma list_of_set_in:
   "finite s \<Longrightarrow> list_of_set s \<in> list_of_set_set s"
 unfolding list_of_set_def
 by (metis list_of_set_set_is_empty set_choose_thm)
 
 definition ordered_list_of_set where
   "ordered_list_of_set cmp s = set_choose (sort_by cmp ` list_of_set_set s)"
 
 subsection \<open>sum\<close>
 
 find_consts "'a list => ('a list * _)"
 
 fun sum_partition :: "('a + 'b) list \<Rightarrow> 'a list * 'b list"  where
   "sum_partition [] = ([], [])"
 | "sum_partition ((Inl l) # lrs) =
      (let (ll, rl) = sum_partition lrs in
      (l # ll, rl))"
 | "sum_partition ((Inr r) # lrs) =
      (let (ll, rl) = sum_partition lrs in
      (ll, r # rl))"
 
 lemma sum_partition_length :
   "List.length lrs = List.length (fst (sum_partition lrs)) + List.length (snd (sum_partition lrs))"
 proof (induct lrs)
   case Nil thus ?case by simp
 next
   case (Cons lr lrs) thus ?case
     by (cases lr) (auto split: prod.split)
 qed
 
 subsection \<open>sorting\<close>
 
 subsection \<open>Strings\<close>
 
 declare String.literal.explode_inverse [simp]
 
 subsection \<open>num to string conversions\<close>
 
 definition nat_list_to_string :: "nat list \<Rightarrow> string" where
   "nat_list_to_string nl = map char_of nl"
 
 definition is_digit where
   "is_digit (n::nat) = (n < 10)"
 
 lemma is_digit_simps[simp] :
   "n < 10 \<Longrightarrow> is_digit n"
   "\<not>(n < 10) \<Longrightarrow> \<not>(is_digit n)"
 unfolding is_digit_def by simp_all
 
 lemma is_digit_expand :
   "is_digit n \<longleftrightarrow>
      (n = 0) \<or> (n = 1) \<or> (n = 2) \<or> (n = 3) \<or>  (n = 4) \<or>
      (n = 5) \<or> (n = 6) \<or> (n = 7) \<or> (n = 8) \<or>  (n = 9)"
 unfolding is_digit_def by auto
 
 lemmas is_digitE = is_digit_expand[THEN iffD1,elim_format]
 lemmas is_digitI = is_digit_expand[THEN iffD2,rule_format]
 
 definition is_digit_char where
   "is_digit_char c \<longleftrightarrow>
      (c = CHR ''0'') \<or> (c = CHR ''5'') \<or>
      (c = CHR ''1'') \<or> (c = CHR ''6'') \<or>
      (c = CHR ''2'') \<or> (c = CHR ''7'') \<or>
      (c = CHR ''3'') \<or> (c = CHR ''8'') \<or>
      (c = CHR ''4'') \<or> (c = CHR ''9'')"
 
 lemma is_digit_char_simps[simp] :
   "is_digit_char (CHR ''0'')"
   "is_digit_char (CHR ''1'')"
   "is_digit_char (CHR ''2'')"
   "is_digit_char (CHR ''3'')"
   "is_digit_char (CHR ''4'')"
   "is_digit_char (CHR ''5'')"
   "is_digit_char (CHR ''6'')"
   "is_digit_char (CHR ''7'')"
   "is_digit_char (CHR ''8'')"
   "is_digit_char (CHR ''9'')"
 unfolding is_digit_char_def by simp_all
 
 lemmas is_digit_charE = is_digit_char_def[THEN iffD1,elim_format]
 lemmas is_digit_charI = is_digit_char_def[THEN iffD2,rule_format]
 
 definition digit_to_char :: "nat \<Rightarrow> char" where
   "digit_to_char n = (
      if n = 0 then CHR ''0''
      else if n = 1 then CHR ''1''
      else if n = 2 then CHR ''2''
      else if n = 3 then CHR ''3''
      else if n = 4 then CHR ''4''
      else if n = 5 then CHR ''5''
      else if n = 6 then CHR ''6''
      else if n = 7 then CHR ''7''
      else if n = 8 then CHR ''8''
      else if n = 9 then CHR ''9''
      else CHR ''X'')"
 
 lemma digit_to_char_simps [simp]:
   "digit_to_char 0 = CHR ''0''"
   "digit_to_char (Suc 0) = CHR ''1''"
   "digit_to_char 2 = CHR ''2''"
   "digit_to_char 3 = CHR ''3''"
   "digit_to_char 4 = CHR ''4''"
   "digit_to_char 5 = CHR ''5''"
   "digit_to_char 6 = CHR ''6''"
   "digit_to_char 7 = CHR ''7''"
   "digit_to_char 8 = CHR ''8''"
   "digit_to_char 9 = CHR ''9''"
   "n > 9 \<Longrightarrow> digit_to_char n = CHR ''X''"
 unfolding digit_to_char_def
 by simp_all
 
 definition char_to_digit :: "char \<Rightarrow> nat" where
   "char_to_digit c = (
      if c = CHR ''0'' then 0
      else if c = CHR ''1'' then 1
      else if c = CHR ''2'' then 2
      else if c = CHR ''3'' then 3
      else if c = CHR ''4'' then 4
      else if c = CHR ''5'' then 5
      else if c = CHR ''6'' then 6
      else if c = CHR ''7'' then 7
      else if c = CHR ''8'' then 8
      else if c = CHR ''9'' then 9
      else 10)"
 
 lemma char_to_digit_simps [simp]:
   "char_to_digit (CHR ''0'') = 0"
   "char_to_digit (CHR ''1'') = 1"
   "char_to_digit (CHR ''2'') = 2"
   "char_to_digit (CHR ''3'') = 3"
   "char_to_digit (CHR ''4'') = 4"
   "char_to_digit (CHR ''5'') = 5"
   "char_to_digit (CHR ''6'') = 6"
   "char_to_digit (CHR ''7'') = 7"
   "char_to_digit (CHR ''8'') = 8"
   "char_to_digit (CHR ''9'') = 9"
 unfolding char_to_digit_def by simp_all
 
 
 lemma diget_to_char_inv[simp]:
 assumes is_digit: "is_digit n"
 shows "char_to_digit (digit_to_char n) = n"
 using is_digit unfolding is_digit_expand by auto
 
 lemma char_to_diget_inv[simp]:
 assumes is_digit: "is_digit_char c"
 shows "digit_to_char (char_to_digit c) = c"
 using is_digit
 unfolding char_to_digit_def is_digit_char_def
 by auto
 
 lemma char_to_digit_div_mod [simp]:
 assumes is_digit: "is_digit_char c"
 shows "char_to_digit c < 10"
 using is_digit
 unfolding char_to_digit_def is_digit_char_def
 by auto
 
 
 lemma is_digit_char_intro[simp]:
   "is_digit (char_to_digit c) = is_digit_char c"
 unfolding char_to_digit_def is_digit_char_def is_digit_expand
 by auto
 
 lemma is_digit_intro[simp]:
   "is_digit_char (digit_to_char n) = is_digit n"
 unfolding digit_to_char_def is_digit_char_def is_digit_expand
 by auto
 
 lemma digit_to_char_11:
 "digit_to_char n1 = digit_to_char n2 \<Longrightarrow>
  (is_digit n1 = is_digit n2) \<and> (is_digit n1 \<longrightarrow> (n1 = n2))"
 by (metis diget_to_char_inv is_digit_intro)
 
 lemma char_to_digit_11:
 "char_to_digit c1 = char_to_digit c2 \<Longrightarrow>
  (is_digit_char c1 = is_digit_char c2) \<and> (is_digit_char c1 \<longrightarrow> (c1 = c2))"
 by (metis char_to_diget_inv is_digit_char_intro)
 
 function nat_to_string :: "nat \<Rightarrow> string" where
   "nat_to_string n =
      (if (is_digit n) then [digit_to_char n] else
       nat_to_string (n div 10) @ [digit_to_char (n mod 10)])"
 by auto
 termination
   by (relation "measure id") (auto simp add: is_digit_def)
 
 definition int_to_string :: "int \<Rightarrow> string" where
   "int_to_string i \<equiv>
      if i < 0 then
        ''-'' @ nat_to_string (nat (abs i))
      else
        nat_to_string (nat i)"
 
 lemma nat_to_string_simps[simp]:
    "is_digit n \<Longrightarrow> nat_to_string n = [digit_to_char n]"
   "\<not>(is_digit n) \<Longrightarrow> nat_to_string n = nat_to_string (n div 10) @ [digit_to_char (n mod 10)]"
 by simp_all
 declare nat_to_string.simps[simp del]
 
 lemma nat_to_string_neq_nil[simp]:
   "nat_to_string n \<noteq> []"
   by (cases "is_digit n") simp_all
 
 lemmas nat_to_string_neq_nil2[simp] = nat_to_string_neq_nil[symmetric]
 
 lemma nat_to_string_char_to_digit [simp]:
   "is_digit_char c \<Longrightarrow> nat_to_string (char_to_digit c) = [c]"
 by auto
 
 lemma nat_to_string_11[simp] :
   "(nat_to_string n1 = nat_to_string n2) \<longleftrightarrow> n1 = n2"
 proof (rule iffI)
   assume "n1 = n2"
   thus "nat_to_string n1 = nat_to_string n2" by simp
 next
   assume "nat_to_string n1 = nat_to_string n2"
   thus "n1 = n2"
   proof (induct n2 arbitrary: n1 rule: less_induct)
     case (less n2')
     note ind_hyp = this(1)
     note n2s_eq = less(2)
 
     have is_dig_eq: "is_digit n2' = is_digit n1" using n2s_eq
       apply (cases "is_digit n2'")
       apply (case_tac [!] "is_digit n1")
       apply (simp_all)
     done
 
     show ?case
     proof (cases "is_digit n2'")
       case True with n2s_eq is_dig_eq show ?thesis by simp (metis digit_to_char_11)
     next
       case False
       with is_dig_eq have not_digs : "\<not> (is_digit n1)"  "\<not> (is_digit n2')" by simp_all
 
       from not_digs(2) have "n2' div 10 < n2'" unfolding is_digit_def by auto
       note ind_hyp' = ind_hyp [OF this, of "n1 div 10"]
 
       from not_digs n2s_eq ind_hyp' digit_to_char_11[of "n1 mod 10" "n2' mod 10"]
       have "(n1 mod 10) = (n2' mod 10)" "n1 div 10 = n2' div 10" by simp_all
       thus "n1 = n2'" by (metis div_mult_mod_eq)
     qed
   qed
 qed
 
 definition "is_nat_string s \<equiv> (\<forall>c\<in>set s. is_digit_char c)"
 definition "is_strong_nat_string s \<equiv> is_nat_string s \<and> (s \<noteq> []) \<and> (hd s = CHR ''0'' \<longrightarrow> length s = 1)"
 
 lemma is_nat_string_simps[simp]:
   "is_nat_string []"
   "is_nat_string (c # s) \<longleftrightarrow> is_digit_char c \<and> is_nat_string s"
 unfolding is_nat_string_def by simp_all
 
 lemma is_strong_nat_string_simps[simp]:
   "\<not>(is_strong_nat_string [])"
   "is_strong_nat_string (c # s) \<longleftrightarrow> is_digit_char c \<and> is_nat_string s \<and>
                                     (c = CHR ''0'' \<longrightarrow> s = [])"
 unfolding is_strong_nat_string_def by simp_all
 
 fun string_to_nat_aux :: "nat \<Rightarrow> string \<Rightarrow> nat" where
    "string_to_nat_aux n [] = n"
  | "string_to_nat_aux n (d#ds) =
     string_to_nat_aux (n*10 + char_to_digit d) ds"
 
 definition string_to_nat :: "string \<Rightarrow> nat option" where
    "string_to_nat s \<equiv>
     (if is_nat_string s then Some (string_to_nat_aux 0 s) else None)"
 
 definition string_to_nat' :: "string \<Rightarrow> nat" where
   "string_to_nat' s \<equiv> the (string_to_nat s)"
 
 lemma string_to_nat_aux_inv :
 assumes "is_nat_string s"
 assumes "n > 0 \<or> is_strong_nat_string s"
 shows "nat_to_string (string_to_nat_aux n s) =
 (if n = 0 then '''' else nat_to_string n) @ s"
 using assms
 proof (induct s arbitrary: n)
   case Nil
   thus ?case
     by (simp add: is_strong_nat_string_def)
 next
   case (Cons c s n)
   from Cons(2) have "is_digit_char c" "is_nat_string s" by simp_all
   note cs_ok = Cons(3)
   let ?m = "n*10 + char_to_digit c"
   note ind_hyp = Cons(1)[OF \<open>is_nat_string s\<close>, of ?m]
 
   from \<open>is_digit_char c\<close> have m_div: "?m div 10 = n" and
                               m_mod: "?m mod 10 = char_to_digit c"
     unfolding is_digit_char_def
     by auto
 
   show ?case
   proof (cases "?m = 0")
     case True
     with \<open>is_digit_char c\<close>
     have "n = 0" "c = CHR ''0''" unfolding is_digit_char_def by auto
     moreover with cs_ok have "s = []" by simp
     ultimately show ?thesis by simp
   next
     case False note m_neq_0 = this
     with ind_hyp have ind_hyp':
       "nat_to_string (string_to_nat_aux ?m s) = (nat_to_string ?m) @ s" by auto
 
     hence "nat_to_string (string_to_nat_aux n (c # s)) = (nat_to_string ?m) @ s"
       by simp
 
     with \<open>is_digit_char c\<close> m_div show ?thesis by simp
   qed
 qed
 
 lemma string_to_nat_inv :
 assumes strong_nat_s: "is_strong_nat_string s"
 assumes s2n_s: "string_to_nat s = Some n"
 shows "nat_to_string n = s"
 proof -
   from strong_nat_s have nat_s: "is_nat_string s" unfolding is_strong_nat_string_def by simp
   with s2n_s have n_eq: "n = string_to_nat_aux 0 s" unfolding string_to_nat_def by simp
 
   from string_to_nat_aux_inv[of s 0, folded n_eq] nat_s strong_nat_s
   show ?thesis by simp
 qed
 
 lemma nat_to_string_induct [case_names "digit" "non_digit"]:
 assumes digit: "\<And>d. is_digit d \<Longrightarrow> P d"
 assumes not_digit: "\<And>n. \<not>(is_digit n) \<Longrightarrow> P (n div 10) \<Longrightarrow> P (n mod 10) \<Longrightarrow> P n"
 shows "P n"
 proof (induct n rule: less_induct)
   case (less n)
   note ind_hyp = this
 
   show ?case
   proof (cases "is_digit n")
     case True with digit show ?thesis by simp
   next
     case False note not_dig = this
     hence "n div 10 < n" "n mod 10 < n" unfolding is_digit_def by auto
     with not_dig ind_hyp not_digit show ?thesis by simp
   qed
 qed
 
 lemma nat_to_string___is_nat_string [simp]:
   "is_nat_string (nat_to_string n)"
 unfolding is_nat_string_def
 proof (induct n rule: nat_to_string_induct)
   case (digit d)
   thus ?case by simp
 next
   case (non_digit n)
   thus ?case by simp
 qed
 
 lemma nat_to_string___eq_0 [simp]:
   "(nat_to_string n = (CHR ''0'')#s) \<longleftrightarrow> (n = 0 \<and> s = [])"
 unfolding is_nat_string_def
 proof (induct n arbitrary: s rule: nat_to_string_induct)
   case (digit d) thus ?case unfolding is_digit_expand by auto
 next
   case (non_digit n)
 
   obtain c s' where ns_eq: "nat_to_string (n div 10) = c # s'"
      by (cases "nat_to_string (n div 10)") auto
 
   from non_digit(1) have "n div 10 \<noteq> 0" unfolding is_digit_def by auto
   with non_digit(2) ns_eq have c_neq: "c \<noteq> CHR ''0''" by auto
 
   from \<open>\<not> (is_digit n)\<close> c_neq ns_eq
   show ?case by auto
 qed
 
 lemma nat_to_string___is_strong_nat_string:
   "is_strong_nat_string (nat_to_string n)"
 proof (cases "is_digit n")
   case True thus ?thesis by simp
 next
   case False note not_digit = this
 
   obtain c s' where ns_eq: "nat_to_string n = c # s'"
      by (cases "nat_to_string n") auto
 
   from not_digit have "0 < n" unfolding is_digit_def by simp
   with ns_eq have c_neq: "c \<noteq> CHR ''0''" by auto
   hence "hd (nat_to_string n) \<noteq> CHR ''0''" unfolding ns_eq by simp
 
   thus ?thesis unfolding is_strong_nat_string_def
     by simp
 qed
 
 lemma nat_to_string_inv :
   "string_to_nat (nat_to_string n) = Some n"
 by (metis nat_to_string_11
           nat_to_string___is_nat_string
           nat_to_string___is_strong_nat_string
           string_to_nat_def
           string_to_nat_inv)
 
 definition The_opt where
   "The_opt p = (if (\<exists>!x. p x) then Some (The p) else None)"
 
 lemma The_opt_eq_some [simp] :
 "((The_opt p) = (Some x)) \<longleftrightarrow> ((p x) \<and> ((\<forall> y.  p y \<longrightarrow> (x = y))))"
     (is "?lhs = ?rhs")
 proof (cases "\<exists>!x. p x")
   case True
   note exists_unique = this
   then obtain x where p_x: "p x" by auto
 
   from the1_equality[of p x] exists_unique p_x
   have the_opt_eq: "The_opt p = Some x"
     unfolding The_opt_def by simp
 
   from exists_unique the_opt_eq p_x show ?thesis
     by auto
 next
   case False
   note not_unique = this
 
   hence "The_opt p = None"
     unfolding The_opt_def by simp
   with not_unique show ?thesis by auto
 qed
 
 lemma The_opt_eq_none [simp] :
 "((The_opt p) = None) \<longleftrightarrow> \<not>(\<exists>!x. p x)"
 unfolding The_opt_def by auto
 
 
 end
diff --git a/thys/CakeML/generated/Lem_sorting.thy b/thys/CakeML/generated/Lem_sorting.thy
--- a/thys/CakeML/generated/Lem_sorting.thy
+++ b/thys/CakeML/generated/Lem_sorting.thy
@@ -1,110 +1,110 @@
 chapter \<open>Generated by Lem from \<open>sorting.lem\<close>.\<close>
 
 theory "Lem_sorting" 
 
 imports
   Main
   "Lem_bool"
   "Lem_basic_classes"
   "Lem_maybe"
   "Lem_list"
   "Lem_num"
   "Lem"
-  "HOL-Library.Permutation"
+  "HOL-Library.List_Permutation"
 
 begin 
 
 
 
 \<comment> \<open>\<open>open import Bool Basic_classes Maybe List Num\<close>\<close>
 
 \<comment> \<open>\<open>open import {isabelle} `HOL-Library.Permutation`\<close>\<close>
 \<comment> \<open>\<open>open import {coq} `Coq.Lists.List`\<close>\<close>
 \<comment> \<open>\<open>open import {hol} `sortingTheory` `permLib`\<close>\<close>
 \<comment> \<open>\<open>open import {isabelle} `$LIB_DIR/Lem`\<close>\<close>
 
 \<comment> \<open>\<open> ------------------------- \<close>\<close>
 \<comment> \<open>\<open> permutations              \<close>\<close>
 \<comment> \<open>\<open> ------------------------- \<close>\<close>
 
 \<comment> \<open>\<open>val isPermutation : forall 'a. Eq 'a => list 'a -> list 'a -> bool\<close>\<close>
 \<comment> \<open>\<open>val isPermutationBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool\<close>\<close>
 
 fun  isPermutationBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where 
      " isPermutationBy eq ([]) l2 = ( (l2 = []))"
 |" isPermutationBy eq (x # xs) l2 = ( (
       (case  delete_first (eq x) l2 of
           None => False
         | Some ys => isPermutationBy eq xs ys
       )
     ))"
 
 
 
 
 \<comment> \<open>\<open> ------------------------- \<close>\<close>
 \<comment> \<open>\<open> isSorted                  \<close>\<close>
 \<comment> \<open>\<open> ------------------------- \<close>\<close>
 
 \<comment> \<open>\<open> isSortedBy R l 
    checks, whether the list l is sorted by ordering R. 
    R should represent an order, i.e. it should be transitive.
    Different backends defined "isSorted" slightly differently. However,
    the definitions coincide for transitive R. Therefore there is the
    following restriction:
 
    WARNING: Use isSorted and isSortedBy only with transitive relations!
 \<close>\<close>
 
 \<comment> \<open>\<open>val isSorted : forall 'a. Ord 'a => list 'a -> bool\<close>\<close>
 \<comment> \<open>\<open>val isSortedBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> bool\<close>\<close>
 
 \<comment> \<open>\<open> DPM: rejigged the definition with a nested match to get past Coq's termination checker. \<close>\<close>
 \<comment> \<open>\<open>let rec isSortedBy cmp l=  match l with
   | [] -> true
   | x1 :: xs ->
     match xs with
       | [] -> true
       | x2 :: _ -> (cmp x1 x2 && isSortedBy cmp xs)
     end
 end\<close>\<close>
 
 
 \<comment> \<open>\<open> ----------------------- \<close>\<close>
 \<comment> \<open>\<open> insertion sort          \<close>\<close>
 \<comment> \<open>\<open> ----------------------- \<close>\<close> 
 
 \<comment> \<open>\<open>val insert : forall 'a. Ord 'a => 'a -> list 'a -> list 'a\<close>\<close>
 \<comment> \<open>\<open>val insertBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a\<close>\<close>
 
 \<comment> \<open>\<open>val insertSort: forall 'a. Ord 'a => list 'a -> list 'a\<close>\<close>
 \<comment> \<open>\<open>val insertSortBy: forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a\<close>\<close>
 
 \<comment> \<open>\<open>let rec insertBy cmp e l=  match l with
   | [] -> [e]
   | x :: xs -> if cmp x e then x :: (insertBy cmp e xs) else (e :: x :: xs)
 end\<close>\<close>
 
 \<comment> \<open>\<open>let insertSortBy cmp l=  List.foldl (fun l e -> insertBy cmp e l) [] l\<close>\<close>
 
 
 \<comment> \<open>\<open> ----------------------- \<close>\<close>
 \<comment> \<open>\<open> general sorting         \<close>\<close>
 \<comment> \<open>\<open> ----------------------- \<close>\<close> 
 
 \<comment> \<open>\<open>val sort: forall 'a. Ord 'a => list 'a -> list 'a\<close>\<close>
 \<comment> \<open>\<open>val sortBy: forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a\<close>\<close>
 \<comment> \<open>\<open>val sortByOrd: forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a\<close>\<close>
 
 \<comment> \<open>\<open>val predicate_of_ord : forall 'a. ('a -> 'a -> ordering) -> 'a -> 'a -> bool\<close>\<close>
 definition predicate_of_ord  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool "  where 
      " predicate_of_ord f x y = (
   (case  f x y of
       LT => True
     | EQ => True
     | GT => False
   ))"
 
 
 
 end
diff --git a/thys/Chandy_Lamport/Snapshot.thy b/thys/Chandy_Lamport/Snapshot.thy
--- a/thys/Chandy_Lamport/Snapshot.thy
+++ b/thys/Chandy_Lamport/Snapshot.thy
@@ -1,5272 +1,5272 @@
 section \<open>The Chandy--Lamport algorithm\<close>
 
 theory Snapshot
   imports
     "HOL-Library.Sublist"
-    "HOL-Library.Permutation"
+    "HOL-Library.List_Permutation"
     Distributed_System
     Trace
     Util
     Swap
 
 begin
 
 subsection \<open>The computation locale\<close>
 
 text \<open>We extend the distributed system locale presented
 earlier: Now we are given a trace t of the distributed system between
 two configurations, the initial and final configuartions of t. Our objective
 is to show that the Chandy--Lamport algorithm terminated successfully and
 exhibits the same properties as claimed in~\cite{chandy}. In the initial state
 no snapshotting must have taken place yet, however the computation itself may
 have progressed arbitrarily far already.
 
 We assume that there exists at least one process, that the
 total number of processes in the system is finite, and that there
 are only finitely many channels between the processes. The process graph
 is strongly connected. Finally there are Chandy and Lamport's core assumptions:
 every process snapshots at some time and no marker may remain in a channel forever.\<close>
 
 locale computation = distributed_system +
   fixes
     init final :: "('a, 'b, 'c) configuration"
   assumes
     finite_channels:
       "finite {i. \<exists>p q. channel i = Some (p, q)}" and
     strongly_connected_raw:
       "\<forall>p q. (p \<noteq> q) \<longrightarrow>
          (tranclp (\<lambda>p q. (\<exists>i. channel i = Some (p, q)))) p q" and
 
     at_least_two_processes:
       "card (UNIV :: 'a set) > 1" and
     finite_processes:
       "finite (UNIV :: 'a set)" and
 
     no_initial_Marker:
       "\<forall>i. (\<exists>p q. channel i = Some (p, q))
       \<longrightarrow> Marker \<notin> set (msgs init i)" and
     no_msgs_if_no_channel:
       "\<forall>i. channel i = None \<longrightarrow> msgs init i = []" and
     no_initial_process_snapshot:
       "\<forall>p. ~ has_snapshotted init p" and
     no_initial_channel_snapshot:
       "\<forall>i. channel_snapshot init i = ([], NotStarted)" and
 
     valid: "\<exists>t. trace init t final" and
     l1: "\<forall>t i cid. trace init t final
                  \<and> Marker \<in> set (msgs (s init t i) cid)
       \<longrightarrow> (\<exists>j. j \<ge> i \<and> Marker \<notin> set (msgs (s init t j) cid))" and
     l2: "\<forall>t p. trace init t final
       \<longrightarrow> (\<exists>i. has_snapshotted (s init t i) p \<and> i \<le> length t)"
 begin
 
 definition has_channel where
   "has_channel p q \<longleftrightarrow> (\<exists>i. channel i = Some (p, q))"
 
 lemmas strongly_connected = strongly_connected_raw[folded has_channel_def]
 
 lemma exists_some_channel:
   shows "\<exists>i p q. channel i = Some (p, q)"
 proof -
   obtain p q where "p : (UNIV :: 'a set) \<and> q : (UNIV :: 'a set) \<and> p \<noteq> q" 
     by (metis (mono_tags) One_nat_def UNIV_eq_I all_not_in_conv at_least_two_processes card_Suc_Diff1 card.empty finite_processes insert_iff iso_tuple_UNIV_I less_numeral_extra(4) n_not_Suc_n)
   then have "(tranclp has_channel) p q" using strongly_connected by simp
   then obtain r s where "has_channel r s" 
     by (meson tranclpD)
   then show ?thesis using has_channel_def by auto
 qed
 
 abbreviation S where
   "S \<equiv> s init"
 
 lemma no_messages_if_no_channel:
   assumes "trace init t final"
   shows "channel cid = None \<Longrightarrow> msgs (s init t i) cid = []"
   using no_messages_introduced_if_no_channel[OF assms no_msgs_if_no_channel] by blast
 
 lemma S_induct [consumes 3, case_names S_init S_step]:
   "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
      \<And>i. P i i;
      \<And>i j. i < j \<Longrightarrow> j \<le> length t \<Longrightarrow> (S t i) \<turnstile> (t ! i) \<mapsto> (S t (Suc i)) \<Longrightarrow> P (Suc i) j \<Longrightarrow> P i j
    \<rbrakk> \<Longrightarrow> P i j"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   then have "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (Suc i))" using Suc step_Suc by simp
   then show ?case using Suc by simp
 qed
 
 lemma exists_index:
   assumes
     "trace init t final" and
     "ev \<in> set (take (j - i) (drop i t))"
   shows
     "\<exists>k. i \<le> k \<and> k < j \<and> ev = t ! k"
 proof -
   have "trace (S t i) (take (j - i) (drop i t)) (S t j)" 
     by (metis assms(1) assms(2) diff_is_0_eq' exists_trace_for_any_i_j list.distinct(1) list.set_cases nat_le_linear take_eq_Nil)
   obtain l where "ev = (take (j - i) (drop i t)) ! l" "l < length (take (j - i) (drop i t))"
     by (metis assms(2) in_set_conv_nth)
   let ?k = "l + i"
   have "(take (j - i) (drop i t)) ! l = drop i t ! l" 
     using \<open>l < length (take (j - i) (drop i t))\<close> by auto
   also have "... = t ! ?k" 
     by (metis add.commute assms(2) drop_all empty_iff list.set(1) nat_le_linear nth_drop take_Nil)
   finally have "ev = t ! ?k" 
     using \<open>ev = take (j - i) (drop i t) ! l\<close> by blast
   moreover have "i \<le> ?k \<and> ?k < j" 
     using \<open>l < length (take (j - i) (drop i t))\<close> by auto
   ultimately show ?thesis by blast
 qed
 
 lemma no_change_if_ge_length_t:
   assumes
     "trace init t final" and
     "i \<ge> length t" and
     "j \<ge> i"
   shows
     "S t i = S t j"
 proof -
   have "trace (S t i) (take (j - i) (drop i t)) (S t j)" 
     using assms(1) assms(3) exists_trace_for_any_i_j by blast
   moreover have "(take (j - i) (drop i t)) = Nil" 
     by (simp add: assms(2))
   ultimately show ?thesis 
     by (metis tr_init trace_and_start_determines_end)
 qed
 
 lemma no_marker_if_no_snapshot:
   shows
     "\<lbrakk> trace init t final; channel cid = Some (p, q);
        ~ has_snapshotted (S t i) p \<rbrakk>
      \<Longrightarrow>  Marker \<notin> set (msgs (S t i) cid)"
 proof (induct i)
   case 0
   then show ?case 
     by (metis exists_trace_for_any_i no_initial_Marker take_eq_Nil tr_init trace_and_start_determines_end)
 next
   case (Suc n)
   then have IH: "Marker \<notin> set (msgs (S t n) cid)" 
     by (meson distributed_system.exists_trace_for_any_i_j distributed_system.snapshot_stable_2 distributed_system_axioms eq_iff le_Suc_eq)
   then obtain tr where decomp: "trace (S t n) tr (S t (Suc n))" "tr = take (Suc n - n) (drop n t)"
     using Suc exists_trace_for_any_i_j le_Suc_eq by blast
   have "Marker \<notin> set (msgs (S t (Suc n)) cid)"
   proof (cases "tr = []")
     case True
     then show ?thesis 
       by (metis IH decomp(1) tr_init trace_and_start_determines_end)
   next
     case False
     then obtain ev where step: "tr = [ev]" "(S t n) \<turnstile> ev \<mapsto> (S t (Suc n))" 
       by (metis One_nat_def Suc_eq_plus1 Suc_leI \<open>tr = take (Suc n - n) (drop n t)\<close> \<open>trace (S t n) tr (S t (Suc n))\<close> add_diff_cancel_left' append.simps(1) butlast_take cancel_comm_monoid_add_class.diff_cancel length_greater_0_conv list.distinct(1) list.sel(3) snoc_eq_iff_butlast take0 take_Nil trace.cases)
     then show ?thesis
     proof (cases ev)
       case (Snapshot p')
       then show ?thesis 
         by (metis IH Suc.prems(2) Suc.prems(3) local.step(2) new_Marker_in_set_implies_nonregular_occurence new_msg_in_set_implies_occurrence nonregular_event_induces_snapshot snapshot_state_unchanged)
     next
       case (RecvMarker cid' p' q')
       have "p' \<noteq> p"
       proof (rule ccontr)
         assume asm: "~ p' \<noteq> p"
         then have "has_snapshotted (S t (Suc n)) p"
         proof -
           have "~ regular_event ev" using RecvMarker by auto
           moreover have "occurs_on ev = p" using asm RecvMarker by auto
           ultimately show ?thesis using step(2) Suc.hyps Suc.prems 
             by (metis nonregular_event_induces_snapshot snapshot_state_unchanged)
         qed
         then show False using Suc.prems by blast
       qed
       moreover have "cid \<noteq> cid'"
       proof (rule ccontr)
         assume "~ cid \<noteq> cid'"
         then have "hd (msgs (S t n) cid) = Marker \<and> length (msgs (S t n) cid) > 0" 
           using step RecvMarker can_occur_def by auto
         then have "Marker : set (msgs (S t n) cid)" 
           using list.set_sel(1) by fastforce
         then show False using IH by simp
       qed
       ultimately have "msgs (S t (Suc n)) cid = msgs (S t n) cid"
       proof -
         have "\<nexists>r. channel cid = Some (p', r)" 
           using Suc.prems(2) \<open>p' \<noteq> p\<close> by auto
         with \<open>cid \<noteq> cid'\<close> RecvMarker step show ?thesis by (cases "has_snapshotted (S t n) p'", auto) 
       qed
       then show ?thesis by (simp add: IH)
     next
       case (Trans p' s s')
       then show ?thesis 
         using IH local.step(2) by force
     next
       case (Send cid' p' q' s s' m)
       with step IH show ?thesis by (cases "cid' = cid", auto)
     next
       case (Recv cid' p' q' s s' m)
       with step IH show ?thesis by (cases "cid' = cid", auto)
     qed
   qed
   then show ?case by blast
 qed
 
 subsection \<open>Termination\<close>
 
 text \<open>We prove that the snapshot algorithm terminates, as exhibited
 by lemma \texttt{snapshot\_algorithm\_must\_terminate}. In the final configuration all
 processes have snapshotted, and no markers remain in the channels.\<close>
 
 lemma must_exist_snapshot:
   assumes
     "trace init t final"
   shows
     "\<exists>p i. Snapshot p = t ! i"
 proof (rule ccontr)
   assume "\<nexists>p i. Snapshot p = t ! i"
   have "\<forall>i p. ~ has_snapshotted (S t i) p"
   proof (rule allI)
     fix i
     show "\<forall>p. ~ has_snapshotted (S t i) p"
     proof (induct i)
       case 0
       then show ?case 
        by (metis assms distributed_system.trace_and_start_determines_end distributed_system_axioms exists_trace_for_any_i computation.no_initial_process_snapshot computation_axioms take0 tr_init)
     next
       case (Suc n)
       then have IH: "\<forall>p. ~ has_snapshotted (S t n) p" by auto
       then obtain tr where "trace (S t n) tr (S t (Suc n))" "tr = take (Suc n - n) (drop n t)"
         using assms exists_trace_for_any_i_j le_Suc_eq by blast
       show "\<forall>p. ~ has_snapshotted (S t (Suc n)) p"
       proof (cases "tr = []")
         case True
         then show ?thesis
           by (metis IH \<open>trace (S t n) tr (S t (Suc n))\<close> tr_init trace_and_start_determines_end)
       next
         case False
         then obtain ev where step: "tr = [ev]" "(S t n) \<turnstile> ev \<mapsto> (S t (Suc n))"
           by (metis One_nat_def Suc_eq_plus1 Suc_leI \<open>tr = take (Suc n - n) (drop n t)\<close> \<open>trace (S t n) tr (S t (Suc n))\<close> add_diff_cancel_left' append.simps(1) butlast_take cancel_comm_monoid_add_class.diff_cancel length_greater_0_conv list.distinct(1) list.sel(3) snoc_eq_iff_butlast take0 take_Nil trace.cases)
         then show ?thesis
         using step Suc.hyps proof (cases ev)
           case (Snapshot q)
           then show ?thesis 
             by (metis \<open>\<nexists>p i. Snapshot p = t ! i\<close> \<open>tr = [ev]\<close> \<open>tr = take (Suc n - n) (drop n t)\<close> append_Cons append_take_drop_id nth_append_length)
         next
           case (RecvMarker cid' q r)
           then have m: "Marker \<in> set (msgs (S t n) cid')" 
             using RecvMarker_implies_Marker_in_set step by blast
           have "~ has_snapshotted (S t n) q" using Suc by auto
           then have "Marker \<notin> set (msgs (S t n) cid')"
           proof -
             have "channel cid' = Some (r, q)" using step can_occur_def RecvMarker by auto
             then show ?thesis 
               using IH assms no_marker_if_no_snapshot by blast
           qed
           then show ?thesis using m by auto
         qed auto
       qed
     qed
   qed
   obtain j p where "has_snapshotted (S t j) p" using l2 assms by blast
   then show False 
     using \<open>\<forall>i p. \<not> has_snapshotted (S t i) p\<close> by blast
 qed
 
 lemma recv_marker_means_snapshotted:
   assumes
     "trace init t final" and
     "ev = RecvMarker cid p q" and
     "(S t i) \<turnstile> ev \<mapsto> (S t (Suc i))"
   shows
     "has_snapshotted (S t i) q"
 proof -
   have "Marker = hd (msgs (S t i) cid) \<and> length (msgs (S t i) cid) > 0" 
   proof -
     have "Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid"
       using assms(2) assms(3) next_recv_marker by blast
     then show ?thesis 
       by (metis length_greater_0_conv list.discI list.sel(1))
   qed
   then have "Marker \<in> set (msgs (S t i) cid)" 
     using hd_in_set by fastforce
   then show "has_snapshotted (S t i) q"
   proof -
     have "channel cid = Some (q, p)" using assms can_occur_def by auto
     then show ?thesis 
       using \<open>Marker \<in> set (msgs (S t i) cid)\<close> assms(1) no_marker_if_no_snapshot by blast
   qed
 qed
 
 lemma recv_marker_means_cs_Done:
   assumes
     "trace init t final" and
     "t ! i = RecvMarker cid p q" and
     "i < length t"
   shows
     "snd (cs (S t (i+1)) cid) = Done"
 proof -
   have "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     using assms(1) assms(3) step_Suc by auto
   then show ?thesis 
     by (simp add: assms(2))
 qed
 
 lemma snapshot_produces_marker:
   assumes
     "trace init t final" and
     "~ has_snapshotted (S t i) p" and
     "has_snapshotted (S t (Suc i)) p" and
     "channel cid = Some (p, q)"
   shows
     "Marker : set (msgs (S t (Suc i)) cid) \<or> has_snapshotted (S t i) q"
 proof -
   obtain ev where ex_ev: "(S t i) \<turnstile> ev \<mapsto> (S t (Suc i))"
     by (metis append_Nil2 append_take_drop_id assms(1) assms(2) assms(3) distributed_system.step_Suc distributed_system_axioms drop_eq_Nil less_Suc_eq_le nat_le_linear not_less_eq s_def)
   then have "occurs_on ev = p" 
     using assms(2) assms(3) no_state_change_if_no_event by force
   then show ?thesis
   using assms ex_ev proof (cases ev)
     case (Snapshot r)
     then have "Marker \<in> set (msgs (S t (Suc i)) cid)" 
       using ex_ev assms(2) assms(3) assms(4) by fastforce
     then show ?thesis by simp
   next
     case (RecvMarker cid' r s)
     have "r = p" using \<open>occurs_on ev = p\<close> 
       by (simp add: RecvMarker)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "has_snapshotted (S t i) q" 
         using RecvMarker RecvMarker_implies_Marker_in_set assms(1) assms(2) assms(4) ex_ev no_marker_if_no_snapshot by blast
       then show ?thesis by simp
     next
       case False
       then have "\<exists>s. channel cid = Some (r, s)" using RecvMarker assms can_occur_def \<open>r = p\<close> by simp
       then have "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Marker]"
         using RecvMarker assms ex_ev \<open>r = p\<close> False by simp
       then show ?thesis by simp
     qed
   qed auto
 qed
 
 lemma exists_snapshot_for_all_p:
   assumes
     "trace init t final"
   shows
     "\<exists>i. ~ has_snapshotted (S t i) p \<and> has_snapshotted (S t (Suc i)) p" (is ?Q)
 proof -
   obtain i where "has_snapshotted (S t i) p" using l2 assms by blast
   let ?j = "LEAST j. has_snapshotted (S t j) p"
   have "?j \<noteq> 0"
   proof -
     have "~ has_snapshotted (S t 0) p" 
       by (metis exists_trace_for_any_i list.discI no_initial_process_snapshot s_def take_eq_Nil trace.simps)
     then show ?thesis 
       by (metis (mono_tags, lifting) \<open>has_snapshotted (S t i) p\<close> wellorder_Least_lemma(1))
   qed
   have "?j \<le> i" 
     by (meson Least_le \<open>has_snapshotted (S t i) p\<close>)
   have "\<not> has_snapshotted (S t (?j - 1)) p" (is ?P)
   proof (rule ccontr)
     assume "\<not> ?P"
     then have "has_snapshotted (S t (?j - 1)) p" by simp
     then have "\<exists>j. j < ?j \<and> has_snapshotted (S t j) p" 
       by (metis One_nat_def \<open>(LEAST j. ps (S t j) p \<noteq> None) \<noteq> 0\<close> diff_less lessI not_gr_zero)
     then show False 
       using not_less_Least by blast
   qed
   show ?thesis
   proof (rule ccontr)
     assume "\<not> ?Q"
     have "\<forall>i. \<not> has_snapshotted (S t i) p"
     proof (rule allI)
       fix i'
       show "\<not> has_snapshotted (S t i') p"
       proof (induct i')
         case 0
         then show ?case 
           using \<open>(LEAST j. ps (S t j) p \<noteq> None) \<noteq> 0\<close> by force
       next
         case (Suc i'')
         then show ?case 
           using \<open>\<nexists>i. \<not> ps (S t i) p \<noteq> None \<and> ps (S t (Suc i)) p \<noteq> None\<close> by blast
       qed
     qed
     then show False 
       using \<open>ps (S t i) p \<noteq> None\<close> by blast
   qed
 qed
 
 lemma all_processes_snapshotted_in_final_state:
   assumes
     "trace init t final"
   shows
     "has_snapshotted final p"
 proof -
   obtain i where "has_snapshotted (S t i) p \<and> i \<le> length t"
     using assms l2 by blast
   moreover have "final = (S t (length t))"
     by (metis (no_types, lifting) assms exists_trace_for_any_i le_Suc_eq length_Cons take_Nil take_all trace.simps trace_and_start_determines_end)
   ultimately show ?thesis 
     using assms exists_trace_for_any_i_j snapshot_stable by blast
 qed
 
 definition next_marker_free_state where
   "next_marker_free_state t i cid = (LEAST j. j \<ge> i \<and> Marker \<notin> set (msgs (S t j) cid))"
 
 lemma exists_next_marker_free_state:
   assumes
     "channel cid = Some (p, q)"
     "trace init t final"
   shows
     "\<exists>!j. next_marker_free_state t i cid = j \<and> j \<ge> i \<and> Marker \<notin> set (msgs (S t j) cid)"
 proof (cases "Marker \<in> set (msgs (S t i) cid)")
   case False
   then have "next_marker_free_state t i cid = i" unfolding next_marker_free_state_def
     by (metis (no_types, lifting) Least_equality order_refl)
   then show ?thesis using False assms by blast
 next
   case True
   then obtain j where "j \<ge> i" "Marker \<notin> set (msgs (S t j) cid)" using l1 assms by blast
   then show ?thesis
     by (metis (no_types, lifting) LeastI_ex next_marker_free_state_def)
 qed
 
 theorem snapshot_algorithm_must_terminate:
   assumes
     "trace init t final"
   shows
     "\<exists>phi. ((\<forall>p. has_snapshotted (S t phi) p)
           \<and> (\<forall>cid. Marker \<notin> set (msgs (S t phi) cid)))"
 proof -
   let ?i = "{i. i \<le> length t \<and> (\<forall>p. has_snapshotted (S t i) p)}"
   have fin_i: "finite ?i" by auto
   moreover have "?i \<noteq> empty"
   proof -
     have "\<forall>p. has_snapshotted (S t (length t)) p" 
       by (meson assms exists_trace_for_any_i_j l2 snapshot_stable_2)
     then show ?thesis by blast
   qed
   then obtain i where asm: "\<forall>p. has_snapshotted (S t i) p" by blast
   have f: "\<forall>j. j \<ge> i \<longrightarrow> (\<forall>p. has_snapshotted (S t j) p)"
     using snapshot_stable asm exists_trace_for_any_i_j valid assms by blast
   let ?s = "(\<lambda>cid. (next_marker_free_state t i cid)) ` { cid. channel cid \<noteq> None }"
   have "?s \<noteq> empty" using exists_some_channel by auto
   have fin_s: "finite ?s" using finite_channels by simp
   let ?phi = "Max ?s"
   have "?phi \<ge> i"
   proof (rule ccontr)
     assume asm: "\<not> ?phi \<ge> i"
     obtain cid p q where g: "channel cid = Some (p, q)" using exists_some_channel by auto
     then have "next_marker_free_state t i cid \<ge> i" using exists_next_marker_free_state assms by blast
     then have "Max ?s \<ge> i" using Max_ge_iff g fin_s by fast
     then show False using asm by simp
   qed
   then have "\<And>cid. Marker \<notin> set (msgs (S t ?phi) cid)"
   proof -
     fix cid
     show "Marker \<notin> set (msgs (S t ?phi) cid)"
     proof (cases "Marker : set (msgs (S t i) cid)")
       case False
       then show ?thesis
         using \<open>i \<le> Max ?s\<close> asm assms exists_trace_for_any_i_j no_markers_if_all_snapshotted by blast
     next
       case True
       then have cpq: "channel cid \<noteq> None" using no_messages_if_no_channel assms by fastforce
       then obtain p q where chan: "channel cid = Some (p, q)" by auto
       then obtain j where i: "j = next_marker_free_state t i cid" "Marker \<notin> set (msgs (S t j) cid)"
         using exists_next_marker_free_state assms by fast
       have "j \<le> ?phi" using cpq fin_s i(1) pair_imageI by simp
       then show "Marker \<notin> set (msgs (S t ?phi) cid)"
       proof -
         have "trace (S t j) (take (?phi - j) (drop j t)) (S t ?phi)" 
           using \<open>j \<le> ?phi\<close> assms exists_trace_for_any_i_j by blast
         moreover have "\<forall>p. has_snapshotted (S t j) p" 
           by (metis assms chan f computation.exists_next_marker_free_state computation_axioms i(1))
         ultimately show ?thesis 
           using i(2) no_markers_if_all_snapshotted by blast
       qed
     qed
   qed
   thus ?thesis using f \<open>?phi \<ge> i\<close> by blast
 qed
 
 subsection \<open>Correctness\<close>
 
 text \<open>The greatest part of this work is spent on the correctness
 of the Chandy-Lamport algorithm. We prove that the snapshot is
 consistent, i.e.\ there exists a permutation $t'$ of the trace $t$ and an intermediate
 configuration $c'$ of $t'$ such that the configuration recorded in the snapshot
 corresponds to the snapshot taken during execution of $t$, which is given as Theorem 1
 in~\cite{chandy}.\<close>
 
 lemma snapshot_stable_ver_2:
   shows "trace init t final \<Longrightarrow> has_snapshotted (S t i) p \<Longrightarrow> j \<ge> i \<Longrightarrow> has_snapshotted (S t j) p"
   using exists_trace_for_any_i_j snapshot_stable by blast
 
 lemma snapshot_stable_ver_3:
   shows "trace init t final \<Longrightarrow> ~ has_snapshotted (S t i) p \<Longrightarrow> i \<ge> j \<Longrightarrow> ~ has_snapshotted (S t j) p"
   using snapshot_stable_ver_2 by blast
 
 lemma marker_must_stay_if_no_snapshot:
   assumes
     "trace init t final" and
     "has_snapshotted (S t i) p" and
     "~ has_snapshotted (S t i) q" and
     "channel cid = Some (p, q)"
   shows
     "Marker : set (msgs (S t i) cid)"
 proof -
   obtain j where "~ has_snapshotted (S t j) p \<and> has_snapshotted (S t (Suc j)) p"
     using exists_snapshot_for_all_p assms by blast
   have "j \<le> i"
   proof (rule ccontr)
     assume asm: "~ j \<le> i"
     then have "~ has_snapshotted (S t i) p" 
       using \<open>\<not> has_snapshotted (S t j) p \<and> has_snapshotted (S t (Suc j)) p\<close> assms(1) less_imp_le_nat snapshot_stable_ver_3 
       by (meson nat_le_linear)
     then show False using assms(2) by simp
   qed
   have "i \<le> length t"
   proof (rule ccontr)
     assume "~ i \<le> length t"
     then have "i > length t" 
       using not_less by blast
     obtain i' where a: "\<forall>p. has_snapshotted (S t i') p" using assms snapshot_algorithm_must_terminate by blast
     have "i' \<ge> i" 
       using \<open>\<forall>p. has_snapshotted (S t i') p\<close> assms(1) assms(3) nat_le_linear snapshot_stable_ver_3 by blast
     have "(S t i') \<noteq> (S t i)" using assms a by force
     then have "i \<le> length t" 
       using \<open>i \<le> i'\<close> assms(1) computation.no_change_if_ge_length_t computation_axioms nat_le_linear by fastforce
     then show False using \<open>~ i \<le> length t\<close> by simp
   qed
   have marker_in_set: "Marker : set (msgs (S t (Suc j)) cid)" 
     using \<open>\<not> has_snapshotted (S t j) p \<and> has_snapshotted (S t (Suc j)) p\<close> \<open>j \<le> i\<close> assms(1) assms(3) assms(4) snapshot_produces_marker snapshot_stable_ver_3 by blast
   show ?thesis
   proof (rule ccontr)
     assume asm: "Marker \<notin> set (msgs (S t i) cid)"
     then have range: "(Suc j) < i" 
       by (metis Suc_lessI \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (Suc j)) p \<noteq> None\<close> \<open>j \<le> i\<close> assms(2) marker_in_set order.order_iff_strict)
     let ?k = "LEAST k. k \<ge> (Suc j) \<and> Marker \<notin> set (msgs (S t k) cid)"
     have range_k: "(Suc j) < ?k \<and> ?k \<le> i"
     proof -
       have "j < (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid))"
         by (metis (full_types) Suc_le_eq assms(1) assms(4) exists_next_marker_free_state next_marker_free_state_def)
       then show ?thesis
       proof -
         assume a1: "j < (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid))"
         have "j < i"
           using local.range by linarith (* 4 ms *)
         then have "(Suc j \<le> i \<and> Marker \<notin> set (msgs (S t i) cid)) \<and> (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) \<noteq> Suc j"
           by (metis (lifting) Suc_leI asm marker_in_set wellorder_Least_lemma(1)) (* 64 ms *)
         then show ?thesis
           using a1 by (simp add: wellorder_Least_lemma(2)) (* 16 ms *)
       qed
     qed
     have a: "Marker : set (msgs (S t (?k-1)) cid)" 
     proof -
       obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
         "\<forall>x0 x1. (\<exists>v2. x0 = Suc (x1 + v2)) = (x0 = Suc (x1 + nn x0 x1))"
         by moura
       then have f1: "(LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) = Suc (Suc j + nn (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) (Suc j))"
         using \<open>Suc j < (LEAST k. Suc j \<le> k \<and> Marker \<notin> set (msgs (S t k) cid)) \<and> (LEAST k. Suc j \<le> k \<and> Marker \<notin> set (msgs (S t k) cid)) \<le> i\<close> less_iff_Suc_add by fastforce
       have f2: "Suc j \<le> Suc j + nn (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) (Suc j)"
         by simp
       have f3: "\<forall>p n. \<not> p (n::nat) \<or> Least p \<le> n"
         by (meson wellorder_Least_lemma(2))
       have "\<not> (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) \<le> Suc j + nn (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) (Suc j)"
         using f1 by linarith
       then have f4: "\<not> (Suc j \<le> Suc j + nn (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) (Suc j) \<and> Marker \<notin> set (msgs (S t (Suc j + nn (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) (Suc j))) cid))"
         using f3 by force
       have "Suc j + nn (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) (Suc j) = (LEAST n. Suc j \<le> n \<and> Marker \<notin> set (msgs (S t n) cid)) - 1"
         using f1 by linarith
       then show ?thesis
         using f4 f2 by presburger
     qed
     have b: "Marker \<notin> set (msgs (S t ?k) cid)" 
       using assms(1) assms(4) exists_next_marker_free_state next_marker_free_state_def by fastforce
     have "?k - 1 < i" using range_k by auto
     then obtain ev where step: "(S t (?k-1)) \<turnstile> ev \<mapsto> (S t (Suc (?k-1)))" 
       by (meson Suc_le_eq \<open>i \<le> length t\<close> assms(1) le_trans step_Suc)
     then show False
       using a assms(1) assms(3) assms(4) b computation.snapshot_stable_ver_3 computation_axioms less_iff_Suc_add range_k recv_marker_means_snapshotted_2 by fastforce
   qed
 qed
 
 subsubsection \<open>Pre- and postrecording events\<close>
 
 definition prerecording_event:
   "prerecording_event t i \<equiv>
       i < length t \<and> regular_event (t ! i)
     \<and> ~ has_snapshotted (S t i) (occurs_on (t ! i))"
 
 definition postrecording_event:
   "postrecording_event t i \<equiv>
       i < length t \<and> regular_event (t ! i)
     \<and> has_snapshotted (S t i) (occurs_on (t ! i))"
 
 abbreviation neighboring where
   "neighboring t i j \<equiv> i < j \<and> j < length t \<and> regular_event (t ! i) \<and> regular_event (t ! j)
                      \<and> (\<forall>k. i < k \<and> k < j \<longrightarrow> ~ regular_event (t ! k))"
 
 lemma pre_if_regular_and_not_post:
   assumes
     "regular_event (t ! i)" and
     "~ postrecording_event t i" and
     "i < length t"
   shows
     "prerecording_event t i"
   using assms computation.postrecording_event computation_axioms prerecording_event by metis
 
 lemma post_if_regular_and_not_pre:
   assumes
     "regular_event (t ! i)" and
     "~ prerecording_event t i" and
     "i < length t"
   shows
     "postrecording_event t i"
   using assms computation.postrecording_event computation_axioms prerecording_event by metis
 
 lemma post_before_pre_different_processes:
   assumes
     "i < j" and
     "j < length t" and
     neighboring: "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     post_ei: "postrecording_event t i" and
     pre_ej: "prerecording_event t j" and
     valid: "trace init t final"
   shows
     "occurs_on (t ! i) \<noteq> occurs_on (t ! j)"
 proof -
   let ?p = "occurs_on (t ! i)"
   let ?q = "occurs_on (t ! j)"
   have sp: "has_snapshotted (S t i) ?p"
     using assms postrecording_event prerecording_event by blast
   have nsq: "~ has_snapshotted (S t j) ?q"
     using assms postrecording_event prerecording_event by blast
   show "?p \<noteq> ?q"
   proof -
     have "~ has_snapshotted (S t i) ?q"
     proof (rule ccontr)
       assume sq: "~ ~ has_snapshotted (S t i) ?q"
       from \<open>i < j\<close> have "i \<le> j" using less_imp_le by blast
       then obtain tr where ex_trace: "trace (S t i) tr (S t j)"
         using exists_trace_for_any_i_j valid by blast
       then have "has_snapshotted (S t j) ?q" using ex_trace snapshot_stable sq by blast
       then show False using nsq by simp
     qed
     then show ?thesis using sp by auto
   qed
 qed
 
 lemma post_before_pre_neighbors:
   assumes
     "i < j" and
     "j < length t" and
     neighboring: "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     post_ei: "postrecording_event t i" and
     pre_ej: "prerecording_event t j" and
     valid: "trace init t final"
   shows
     "Ball (set (take (j - (i+1)) (drop (i+1) t))) (%ev. ~ regular_event ev \<and> ~ occurs_on ev = occurs_on (t ! j))"
 proof -
   let ?p = "occurs_on (t ! i)"
   let ?q = "occurs_on (t ! j)"
   let ?between = "take (j - (i+1)) (drop (i+1) t)"
   show ?thesis
   proof (unfold Ball_def, rule allI, rule impI)
     fix ev
     assume "ev : set ?between"
     have len_nr: "length ?between = (j - (i+1))" using assms(2) by auto
     then obtain l where "?between ! l = ev" and range_l: "0 \<le> l \<and> l < (j - (i+1))" 
       by (metis \<open>ev \<in> set (take (j - (i + 1)) (drop (i + 1) t))\<close> gr_zeroI in_set_conv_nth le_numeral_extra(3) less_le)
     let ?k = "l + (i+1)"
     have "?between ! l = (t ! ?k)"
     proof -
       have "j < length t"
         by (metis assms(2))
       then show ?thesis
         by (metis (no_types) Suc_eq_plus1 Suc_leI add.commute assms(1) drop_take length_take less_diff_conv less_imp_le_nat min.absorb2 nth_drop nth_take range_l)
     qed
     have "~ regular_event ev" 
       by (metis (no_types, lifting) assms(3) range_l One_nat_def Suc_eq_plus1 \<open>take (j - (i + 1)) (drop (i + 1) t) ! l = ev\<close> \<open>take (j - (i + 1)) (drop (i + 1) t) ! l = t ! (l + (i + 1))\<close> add.left_commute add_lessD1 lessI less_add_same_cancel2 less_diff_conv order_le_less)
     have step_ev: "(S t ?k) \<turnstile> ev \<mapsto> (S t (?k+1))" 
     proof -
       have "j \<le> length t"
         by (metis assms(2) less_or_eq_imp_le)
       then have "l + (i + 1) < length t"
         by (meson less_diff_conv less_le_trans range_l)
       then show ?thesis
         by (metis (no_types) Suc_eq_plus1 \<open>take (j - (i + 1)) (drop (i + 1) t) ! l = ev\<close> \<open>take (j - (i + 1)) (drop (i + 1) t) ! l = t ! (l + (i + 1))\<close> distributed_system.step_Suc distributed_system_axioms valid)
     qed
     obtain cid s r where f: "ev = RecvMarker cid s r \<or> ev = Snapshot r" using \<open>~ regular_event ev\<close>
       by (meson isRecvMarker_def isSnapshot_def nonregular_event)
     from f have "occurs_on ev \<noteq> ?q"
     proof (elim disjE)
       assume snapshot: "ev = Snapshot r"
       show ?thesis
       proof (rule ccontr)
         assume occurs_on_q: "~ occurs_on ev \<noteq> ?q"
         then have "?q = r" using snapshot by auto
         then have q_snapshotted: "has_snapshotted (S t (?k+1)) ?q"
           using snapshot step_ev by auto
         then show False 
         proof -
           have "l + (i + 1) < j"
             by (meson less_diff_conv range_l)
           then show ?thesis
             by (metis (no_types) Suc_eq_plus1 Suc_le_eq computation.snapshot_stable_ver_2 computation_axioms pre_ej prerecording_event q_snapshotted valid)
         qed
       qed
     next
       assume RecvMarker: "ev = RecvMarker cid s r"
       show ?thesis
       proof (rule ccontr)
         assume occurs_on_q: "~ occurs_on ev \<noteq> ?q"
         then have "s = ?q" using RecvMarker by auto
         then have q_snapshotted: "has_snapshotted (S t (?k+1)) ?q"
         proof (cases "has_snapshotted (S t ?k) ?q")
           case True
           then show ?thesis using snapshot_stable_ver_2 step_Suc step_ev valid by auto
         next
           case False
           then show "has_snapshotted (S t (?k+1)) ?q"
             using \<open>s = ?q\<close> next_recv_marker RecvMarker step_ev by auto
         qed
         then show False 
         proof -
           have "l + (i + 1) < j"
             using less_diff_conv range_l by blast
           then show ?thesis
             by (metis (no_types) Suc_eq_plus1 Suc_le_eq computation.snapshot_stable_ver_2 computation_axioms pre_ej prerecording_event q_snapshotted valid)
         qed
       qed
     qed
     then show "\<not> regular_event ev \<and> occurs_on ev \<noteq> ?q"
       using \<open>~ regular_event ev\<close> by simp
   qed
 qed
 
 lemma can_swap_neighboring_pre_and_postrecording_events:
   assumes
     "i < j" and
     "j < length t" and
     "occurs_on (t ! i) = p" and
     "occurs_on (t ! j) = q" and
     neighboring: "\<forall>k. (i < k \<and> k < j)
                    \<longrightarrow> ~ regular_event (t ! k)" and
     post_ei: "postrecording_event t i" and
     pre_ej: "prerecording_event t j" and
     valid: "trace init t final"
   shows
     "can_occur (t ! j) (S t i)"
 proof -
   have "p \<noteq> q" using post_before_pre_different_processes assms by auto
   have sp: "has_snapshotted (S t i) p" 
     using assms(3) post_ei postrecording_event prerecording_event by blast
   have nsq: "~ has_snapshotted (S t j) q" 
     using assms(4) pre_ej prerecording_event by auto
   let ?nr = "take (j - (Suc i)) (drop (Suc i) t)"
   have valid_subtrace: "trace (S t (Suc i)) ?nr (S t j)"
     using assms(1) exists_trace_for_any_i_j valid by fastforce
   have "Ball (set ?nr) (%ev. ~ occurs_on ev = q \<and> ~ regular_event ev)"
   proof -
     have "?nr = take (j - (i+1)) (drop (i+1) t)" by auto
     then show ?thesis
       by (metis assms(1) assms(2) assms(4) neighboring post_ei pre_ej valid post_before_pre_neighbors)
   qed
   then have la: "list_all (%ev. ~ occurs_on ev = q) ?nr"
       by (meson list_all_length nth_mem)
   have tj_to_tSi: "can_occur (t ! j) (S t (Suc i))"
   proof - 
     have "list_all (%ev. ~ isSend ev) ?nr"
     proof -
       have "list_all (%ev. ~ regular_event ev) ?nr" 
         using \<open>\<forall>ev\<in>set (take (j - (Suc i)) (drop (Suc i) t)). occurs_on ev \<noteq> q \<and> \<not> regular_event ev\<close> \<open>list_all (\<lambda>ev. occurs_on ev \<noteq> q) (take (j - (Suc i)) (drop (Suc i) t))\<close> list.pred_mono_strong by fastforce
       then show ?thesis
         by (simp add: list.pred_mono_strong)
     qed
     moreover have "~ isRecvMarker (t ! j)" using prerecording_event assms by auto
     moreover have "can_occur (t ! j) (S t j)" 
     proof -
       have "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (Suc j))" 
         using assms(2) step_Suc valid by auto
       then show ?thesis 
         using happen_implies_can_occur by blast
     qed
     ultimately show "can_occur (t ! j) (S t (Suc i))" 
       using assms(4) event_can_go_back_if_no_sender_trace valid_subtrace la by blast
   qed
   show "can_occur (t ! j) (S t i)"
   proof (cases "isSend (t ! i)")
     case False
     have "~ isRecvMarker (t ! j)" using assms prerecording_event by auto
     moreover have "~ isSend (t ! i)" using False by simp
     ultimately show ?thesis 
       by (metis \<open>p \<noteq> q\<close> assms(3) assms(4) event_can_go_back_if_no_sender post_ei postrecording_event step_Suc tj_to_tSi valid)
   next
     case True
     obtain cid s u u' m where Send: "t ! i = Send cid p s u u' m" 
       by (metis True isSend_def assms(3) event.sel(2))
     have chan: "channel cid = Some (p, s)"
     proof -
       have "can_occur (t ! i) (S t i)" 
         by (meson computation.postrecording_event computation_axioms happen_implies_can_occur post_ei step_Suc valid)
       then show ?thesis using can_occur_def Send by simp
     qed
     have n: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (Suc i))" 
       using assms(1) assms(2) step_Suc valid True by auto
     have st: "states (S t i) q = states (S t (Suc i)) q" 
       using Send \<open>p \<noteq> q\<close> n by auto
     have "isTrans (t ! j) \<or> isSend (t ! j) \<or> isRecv (t ! j)"
       using assms(7) computation.prerecording_event computation_axioms regular_event by blast
     then show ?thesis 
     proof (elim disjE)
       assume "isTrans (t ! j)"
       then show ?thesis
         by (metis (no_types, lifting) tj_to_tSi st can_occur_def assms(4) event.case(1) event.collapse(1))
     next
       assume "isSend (t ! j)"
       then obtain cid' s' u'' u''' m' where Send: "t ! j = Send cid' q s' u'' u''' m'" 
         by (metis (no_types, lifting) assms(4) event.sel(2) isSend_def)
       have co_tSi: "can_occur (Send cid' q s' u'' u''' m') (S t (Suc i))" 
         using Send tj_to_tSi by auto
       then have "channel cid' = Some (q, s') \<and> send cid' q s' u'' u''' m'"
         using Send can_occur_def by simp
       then show ?thesis using can_occur_def st Send assms co_tSi by auto
     next
       assume "isRecv (t ! j)"
       then obtain cid' s' u'' u''' m' where Recv: "t ! j = Recv cid' q s' u'' u''' m'"
         by (metis assms(4) event.sel(3) isRecv_def)
       have co_tSi: "can_occur (Recv cid' q s' u'' u''' m') (S t (Suc i))" 
         using Recv tj_to_tSi by auto
       then have a: "channel cid' = Some (s', q) \<and> length (msgs (S t (Suc i)) cid') > 0
                   \<and> hd (msgs (S t (Suc i)) cid') = Msg m'"
         using can_occur_def co_tSi by fastforce
       show "can_occur (t ! j) (S t i)"
       proof (cases "cid = cid'")
         case False
         with Send n have "msgs (S t (Suc i)) cid' = msgs (S t i) cid'" by auto
         then have b: "length (msgs (S t i) cid') > 0 \<and> hd (msgs (S t i) cid') = Msg m'"
           using a by simp
         with can_occur_Recv co_tSi st a Recv show ?thesis
           unfolding can_occur_def by auto
       next
         case True (* This is the interesting case *)
         have stu: "states (S t i) q = u''" 
           using can_occur_Recv co_tSi st by blast
         show ?thesis
         proof (rule ccontr)
           have marker_in_set: "Marker \<in> set (msgs (S t i) cid)"
           proof -
             have "(s', q) = (p, q)" 
               using True a chan by auto
             then show ?thesis
               by (metis (no_types, lifting) True \<open>p \<noteq> q\<close> a assms(3) marker_must_stay_if_no_snapshot n no_state_change_if_no_event nsq snapshot_stable_2 sp valid valid_subtrace)
           qed
           assume asm: "~ can_occur (t ! j) (S t i)"
           then show False
           proof (unfold can_occur_def, (auto simp add: marker_in_set True Recv stu))
             assume "msgs (S t i) cid' = []"
             then show False using marker_in_set 
               by (simp add: True)
           next
             assume "hd (msgs (S t i) cid') \<noteq> Msg m'"
             have "msgs (S t i) cid \<noteq> []" using marker_in_set by auto
             then have "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Msg m]"
               using Send True n chan by auto
             then have "hd (msgs (S t (Suc i)) cid) \<noteq> Msg m'" 
               using True \<open>hd (msgs (S t i) cid') \<noteq> Msg m'\<close> \<open>msgs (S t i) cid \<noteq> []\<close> by auto
             then have "~ can_occur (t ! j) (S t (Suc i))" 
               using True a by blast
             then show False 
               using tj_to_tSi by blast
           next
             assume "~ recv cid' q s' u'' u''' m'"
             then show False 
               using can_occur_Recv co_tSi by blast
           next
             assume "channel cid' \<noteq> Some (s', q)"
             then show False using can_occur_def tj_to_tSi Recv by simp
           qed
         qed
       qed
     qed
   qed
 qed
 
 subsubsection \<open>Event swapping\<close>
 
 lemma swap_events:
   shows "\<lbrakk> i < j; j < length t;
           \<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k);
           postrecording_event t i; prerecording_event t j;
           trace init t final \<rbrakk>
         \<Longrightarrow> trace init (swap_events i j t) final
           \<and> (\<forall>k. k \<ge> j + 1 \<longrightarrow> S (swap_events i j t) k = S t k)
           \<and> (\<forall>k. k \<le> i \<longrightarrow> S (swap_events i j t) k = S t k)
           \<and> prerecording_event (swap_events i j t) i
           \<and> postrecording_event (swap_events i j t) (i+1)
           \<and> (\<forall>k. k > i+1 \<and> k < j+1
                \<longrightarrow> ~ regular_event ((swap_events i j t) ! k))"
 proof (induct "j - (i+1)" arbitrary: j t)
   case 0
   let ?p = "occurs_on (t ! i)"
   let ?q = "occurs_on (t ! j)"
   have "j = (i+1)"
     using "0.prems" "0.hyps" by linarith
   let ?subt = "take (j - (i+1)) (drop (i+1) t)"
   have "t = take i t @ [t ! i] @ ?subt @ [t ! j] @ drop (j+1) t" 
   proof -
     have "take (Suc i) t = take i t @ [t ! i]"
       using "0.prems"(2) \<open>j = i + 1\<close> add_lessD1 take_Suc_conv_app_nth by blast
     then show ?thesis
       by (metis (no_types) "0.hyps" "0.prems"(2) Suc_eq_plus1 \<open>j = i + 1\<close> append_assoc append_take_drop_id self_append_conv2 take_Suc_conv_app_nth take_eq_Nil)
   qed
   have sp: "has_snapshotted (S t i) ?p"
     using "0.prems" postrecording_event prerecording_event by blast
   have nsq: "~ has_snapshotted (S t j) ?q"
     using "0.prems" postrecording_event prerecording_event by blast
   have "?p \<noteq> ?q"
     using "0.prems" computation.post_before_pre_different_processes computation_axioms by blast
   have "?subt = Nil"
     by (simp add: \<open>j = i + 1\<close>)
   have reg_step_1: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t j)" 
     by (metis "0.prems"(2) "0.prems"(6) Suc_eq_plus1 \<open>j = i + 1\<close> add_lessD1 step_Suc)
   have reg_step_2: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
     using "0.prems"(2) "0.prems"(6) step_Suc by auto
   have "can_occur (t ! j) (S t i)" 
     using "0.prems" can_swap_neighboring_pre_and_postrecording_events by blast
   then obtain d' where new_step1: "(S t i) \<turnstile> (t ! j) \<mapsto> d'"
     using exists_next_if_can_occur by blast
 
   have st: "states d' ?p = states (S t i) ?p" 
     using \<open>(S t i) \<turnstile> t ! j \<mapsto> d'\<close> \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> no_state_change_if_no_event by auto
   then have "can_occur (t ! i) d'" 
     using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> event_stays_valid_if_no_occurrence happen_implies_can_occur new_step1 reg_step_1 by auto
   then obtain e where new_step2: "d' \<turnstile> (t ! i) \<mapsto> e" 
     using exists_next_if_can_occur by blast
 
   have "states e = states (S t (j+1))"
   proof (rule ext)
     fix p
     show "states e p = states (S t (j+1)) p"
     proof (cases "p = ?p \<or> p = ?q")
       case True
       then show ?thesis
       proof (elim disjE)
         assume "p = ?p"
         then have "states d' p = states (S t i) p" 
           by (simp add: st)
         thm same_state_implies_same_result_state
         then have "states e p = states (S t j) p"
           using "0.prems"(2) "0.prems"(6) new_step2 reg_step_1 by (blast intro:same_state_implies_same_result_state[symmetric])
         moreover have "states (S t j) p = states (S t (j+1)) p" 
           using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> \<open>p = occurs_on (t ! i)\<close> no_state_change_if_no_event reg_step_2 by auto
         ultimately show ?thesis by simp
       next
         assume "p = ?q"
         then have "states (S t j) p = states (S t i) p" 
           using reg_step_1 \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> no_state_change_if_no_event by auto
         then have "states d' p = states (S t (j+1)) p" 
           using "0.prems"(5) prerecording_event computation_axioms new_step1 reg_step_2 same_state_implies_same_result_state by blast
         moreover have "states e p = states (S t (j+1)) p" 
           using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> \<open>p = occurs_on (t ! j)\<close> calculation new_step2 no_state_change_if_no_event by auto
         ultimately show ?thesis by simp
       qed
     next
       case False
       then have "states (S t i) p = states (S t j) p" 
         using no_state_change_if_no_event reg_step_1 by auto
       moreover have "... = states (S t (j+1)) p" 
         using False no_state_change_if_no_event reg_step_2 by auto
       moreover have "... = states d' p" 
         using False calculation new_step1 no_state_change_if_no_event by auto
       moreover have "... = states e p" 
         using False new_step2 no_state_change_if_no_event by auto
       ultimately show ?thesis by simp 
     qed
   qed
 
   moreover have "msgs e = msgs (S t (j+1))"
   proof (rule ext)
     fix cid
     have "isTrans (t ! i) \<or> isSend (t ! i) \<or> isRecv (t ! i)"
       using "0.prems"(4) computation.postrecording_event computation_axioms regular_event by blast
     moreover have "isTrans (t ! j) \<or> isSend (t ! j) \<or> isRecv (t ! j)" 
       using "0.prems"(5) computation.prerecording_event computation_axioms regular_event by blast
     ultimately show "msgs e cid = msgs (S t (j+1)) cid"
     proof (elim disjE, goal_cases)
       case 1
       then have "msgs d' cid = msgs (S t j) cid" 
         by (metis Trans_msg new_step1 reg_step_1)
       then show ?thesis 
         using Trans_msg \<open>isTrans (t ! i)\<close> \<open>isTrans (t ! j)\<close> new_step2 reg_step_2 by auto
     next
       case 2
       then show ?thesis 
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Trans_Send by auto
     next
       case 3
       then show ?thesis 
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Trans_Recv by auto
     next
       case 4
       then show ?thesis
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Send_Trans by auto
     next
       case 5
       then show ?thesis 
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Recv_Trans by auto
     next
       case 6
       then show ?thesis
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 by (blast intro:swap_msgs_Send_Send[symmetric])
     next
       case 7
       then show ?thesis 
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Send_Recv by auto
     next
       case 8
       then show ?thesis 
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Send_Recv by simp
     next
       case 9
       then show ?thesis
         using \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> new_step1 new_step2 reg_step_1 reg_step_2 by (blast intro:swap_msgs_Recv_Recv[symmetric])
     qed
   qed
 
   moreover have "process_snapshot e = process_snapshot (S t (j+1))"
   proof (rule ext)
     fix p
     have "process_snapshot d' p = process_snapshot (S t j) p" 
       by (metis "0.prems"(4) "0.prems"(5) computation.postrecording_event computation.prerecording_event computation_axioms new_step1 reg_step_1 regular_event_preserves_process_snapshots)
     then show "process_snapshot e p = process_snapshot (S t (j+1)) p"
       by (metis "0.prems"(4) "0.prems"(5) computation.postrecording_event computation.prerecording_event computation_axioms new_step2 reg_step_2 regular_event_preserves_process_snapshots)
   qed
 
   moreover have "channel_snapshot e = channel_snapshot (S t (j+1))"
   proof (rule ext)
     fix cid
     show "cs e cid = cs (S t (j+1)) cid"
     proof (cases "isRecv (t ! i)"; cases "isRecv (t ! j)", goal_cases)
       case 1
       then show ?thesis
         using \<open>?p \<noteq> ?q\<close> new_step1 new_step2 reg_step_1 reg_step_2
         by (blast intro:regular_event_implies_same_channel_snapshot_Recv_Recv[symmetric])
     next
       case 2
       moreover have "regular_event (t ! j)" using prerecording_event 0 by simp
       ultimately show ?thesis 
         using \<open>?p \<noteq> ?q\<close> new_step1 new_step2 reg_step_1 reg_step_2 regular_event_implies_same_channel_snapshot_Recv by auto
     next
       assume 3: "~ isRecv (t ! i)" "isRecv (t ! j)"
       moreover have "regular_event (t ! i)" using postrecording_event 0 by simp
       ultimately show ?thesis 
         using \<open>?p \<noteq> ?q\<close> new_step1 new_step2 reg_step_1 reg_step_2 regular_event_implies_same_channel_snapshot_Recv by auto
 
     next
       assume 4: "~ isRecv (t ! i)" "~ isRecv (t ! j)"
       moreover have "regular_event (t ! j)" using prerecording_event 0 by simp
       moreover have "regular_event (t ! i)" using postrecording_event 0 by simp
       ultimately show ?thesis 
         using \<open>?p \<noteq> ?q\<close> new_step1 new_step2 reg_step_1 reg_step_2 
         by (metis no_cs_change_if_no_event)
     qed
   qed
   ultimately have "e = S t (j+1)" by simp
   then have "(S t i) \<turnstile> (t ! j) \<mapsto> d' \<and> d' \<turnstile> (t ! i) \<mapsto> (S t (j+1))"
     using new_step1 new_step2 by blast
   then have swap: "trace (S t i) [t ! j, t ! i] (S t (j+1))" 
     by (meson trace.simps)
   have "take (j-1) t @ [t ! j, t ! i] = ((take (j+1) t)[i := t ! j])[j := t ! i]"
   proof -
     have "i = j - 1" 
       by (simp add: \<open>j = i + 1\<close>)
     show ?thesis
     proof (subst (1 2 3) \<open>i = j - 1\<close>)
       have "j < length t" using "0.prems" by auto
       then have "take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t = t[j - 1 := t ! j, j := t ! (j - 1)]"
         by (metis Suc_eq_plus1 \<open>i = j - 1\<close> \<open>j = i + 1\<close> add_Suc_right arith_special(3) swap_neighbors)
       then show "take (j - 1) t @ [t ! j, t ! (j - 1)] = (take (j+1) t)[j - 1 := t ! j, j := t ! (j - 1)]"
       proof -
         assume a1: "take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t = t [j - 1 := t ! j, j := t ! (j - 1)]"
         have f2: "t[j - 1 := t ! j, j := t ! (j - 1)] = take j (t[j - 1 := t ! j]) @ t ! (j - 1) # drop (Suc j) (t[j - 1 := t ! j])"
           by (metis (no_types) "0.prems"(2) length_list_update upd_conv_take_nth_drop) (* 32 ms *)
         have f3: "\<forall>n na. \<not> n < na \<or> Suc n \<le> na"
           using Suc_leI by blast (* 0.0 ms *)
         then have "min (length t) (j + 1) = j + 1"
           by (metis (no_types) "0.prems"(2) Suc_eq_plus1 min.absorb2) (* 16 ms *)
         then have f4: "length ((take (j + 1) t)[j - 1 := t ! j]) = j + 1"
           by simp (* 4 ms *)
         have f5: "j + 1 \<le> length (t[j - 1 := t ! j])"
           using f3 by (metis (no_types) "0.prems"(2) Suc_eq_plus1 length_list_update) (* 8 ms *)
         have "Suc j \<le> j + 1"
           by linarith (* 0.0 ms *)
         then have "(take (j + 1) (t[j - 1 := t ! j]))[j := t ! (j - 1)] = take j (t[j - 1 := t ! j]) @ t ! (j - 1) # [] @ []"
           using f5 f4 by (metis (no_types) Suc_eq_plus1 add_diff_cancel_right' butlast_conv_take butlast_take drop_eq_Nil lessI self_append_conv2 take_update_swap upd_conv_take_nth_drop) (* 180 ms *)
         then show ?thesis
           using f2 a1 by (simp add: take_update_swap) (* 120 ms *)
       qed
     qed
   qed
   have s: "trace init (take i t) (S t i)" 
     using "0.prems"(6) exists_trace_for_any_i by blast
   have e: "trace (S t (j+1)) (take (length t - (j+1)) (drop (j+1) t)) final"
   proof -
     have "trace init (take (length t) t) final" 
       by (simp add: "0.prems"(6))
     then show ?thesis 
       by (metis "0.prems"(2) Suc_eq_plus1 Suc_leI exists_trace_for_any_i exists_trace_for_any_i_j nat_le_linear take_all trace_and_start_determines_end)
   qed
   have "trace init (take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) final"
   proof -
     from s swap have "trace init (take i t @ [t ! j,t ! i]) (S t (j+1))" using trace_trans by blast
     then have "trace init (take i t @ [t ! j, t ! i] @ (take (length t - (j+1)) (drop (j+1) t))) final"
       using e trace_trans by fastforce
     moreover have "take (length t - (j+1)) (drop (j+1) t) = drop (j+1) t" by simp
     ultimately show ?thesis by simp
   qed
   moreover have "take i t @ [t ! j] @ [t ! i] @ drop (j+1) t = (t[i := t ! j])[j := t ! i]"
   proof -
     have "length (take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) = length ((t[i := t ! j])[j := t ! i])"
       by (metis (mono_tags, lifting) \<open>t = take i t @ [t ! i] @ take (j - (i + 1)) (drop (i + 1) t) @ [t ! j] @ drop (j + 1) t\<close> \<open>take (j - (i + 1)) (drop (i + 1) t) = []\<close> length_append length_list_update list.size(4) self_append_conv2)
     moreover have "\<And>k. k < length ((t[i := t ! j])[j := t ! i]) \<Longrightarrow> (take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) ! k = ((t[i := t ! j])[j := t ! i]) ! k"
     proof -
       fix k
       assume "k < length ((t[i := t ! j])[j := t ! i])"
       show "(take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) ! k = ((t[i := t ! j])[j := t ! i]) ! k"
       proof (cases "k = i \<or> k = j")
         case True
         then show ?thesis
         proof (elim disjE)
           assume "k = i"
           then show ?thesis 
             by (metis (no_types, lifting) \<open>k < length (t[i := t ! j, j := t ! i])\<close> append_Cons le_eq_less_or_eq length_list_update length_take min.absorb2 nth_append_length nth_list_update_eq nth_list_update_neq)
         next
           assume "k = j"
           then show ?thesis 
             by (metis (no_types, lifting) "0.prems"(4) Suc_eq_plus1 \<open>j = i + 1\<close> \<open>k < length (t[i := t ! j, j := t ! i])\<close> append.assoc append_Cons le_eq_less_or_eq length_append_singleton length_list_update length_take min.absorb2 nth_append_length nth_list_update postrecording_event)
         qed
       next
         case knij: False
         then show ?thesis
         proof (cases "k < i")
           case True
           then show ?thesis 
             by (metis (no_types, lifting) "0.prems"(2) \<open>j = i + 1\<close> add_lessD1 length_take less_imp_le_nat min.absorb2 not_less nth_append nth_list_update_neq nth_take)
         next
           case False
           then have "k > j" 
             using \<open>j = i + 1\<close> knij by linarith
           then have "(take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) ! k = drop (j+1) t ! (k-(j+1))"
           proof -
             assume a1: "j < k"
             have f2: "\<forall>n na. ((n::nat) < na) = (n \<le> na \<and> n \<noteq> na)"
               using nat_less_le by blast (* 0.0 ms *)
             have f3: "i + 0 = min (length t) i + (0 + 0)"
               using "0.prems"(2) \<open>j = i + 1\<close> by linarith (* 8 ms *)
             have f4: "min (length t) i + Suc (0 + 0) = length (take i t) + length [t ! j]"
               by force (* 4 ms *)
             have f5: "take i t @ [t ! j] @ [] = take i t @ [t ! j]"
               by auto (* 0.0 ms *)
             have "j = length (take i t @ [t ! j] @ [])"
               using f3 by (simp add: \<open>j = i + 1\<close>) (* 4 ms *)
             then have "j + 1 = length (take i t @ [t ! j] @ [t ! i])"
               by fastforce (* 4 ms *)
             then show ?thesis
               using f5 f4 f3 f2 a1 by (metis (no_types) One_nat_def \<open>j = i + 1\<close> add_Suc_right append.assoc length_append less_antisym list.size(3) not_less nth_append) (* 284 ms *)
           qed
           moreover have "(t[i := t ! j])[j := t ! i] ! k = drop (j+1) ((t[i := t ! j])[j := t ! i]) ! (k-(j+1))" 
             using "0.prems"(2) \<open>j < k\<close> by auto
           moreover have "drop (j+1) ((t[i := t ! j])[j := t ! i]) = drop (j+1) t" 
             using "0.prems"(1) by auto
           ultimately show ?thesis by simp
         qed
       qed
     qed
     ultimately show ?thesis by (simp add: list_eq_iff_nth_eq)
   qed
   moreover have "\<forall>k. k \<ge> j + 1 \<longrightarrow> S t k = S ((t[i := t ! j])[j := t ! i]) k"
   proof (rule allI, rule impI)
     fix k
     assume "k \<ge> j + 1"
     let ?newt = "((t[i := t ! j])[j := t ! i])"
     have "trace init (take k ?newt) (S ?newt k)" 
       using calculation(1) calculation(2) exists_trace_for_any_i by auto
     have "take k ?newt = take (j+1) ?newt @ take (k - (j+1)) (drop (j+1) ?newt)"
       by (metis \<open>j + 1 \<le> k\<close> le_add_diff_inverse take_add)
     have same_traces: "drop (j+1) t = drop (j+1) ?newt" 
       by (metis "0.prems"(1) Suc_eq_plus1 \<open>j = i + 1\<close> drop_update_cancel less_SucI less_add_same_cancel1)
     have "trace init (take (j+1) ((t[i := t ! j])[j := t ! i])) (S t (j+1))"
       by (metis (no_types, lifting) \<open>j = i + 1\<close> \<open>take (j - 1) t @ [t ! j, t ! i] = (take (j + 1) t)[i := t ! j, j := t ! i]\<close> add_diff_cancel_right' local.swap s take_update_swap trace_trans)
     moreover have "trace init (take (j+1) ?newt) (S ?newt (j+1))"  
       using \<open>take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\<close> \<open>trace init (take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t) final\<close> exists_trace_for_any_i by auto
     ultimately have "S ?newt (j+1) = S t (j+1)" 
       using trace_and_start_determines_end by blast
     have "trace (S t (j+1)) (take (k - (j+1)) (drop (j+1) t)) (S t k)" 
       using "0.prems"(6) \<open>j + 1 \<le> k\<close> exists_trace_for_any_i_j by blast
     moreover have "trace (S ?newt (j+1)) (take (k - (j+1)) (drop (j+1) ?newt)) (S ?newt k)" 
       using \<open>j + 1 \<le> k\<close> \<open>take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\<close> \<open>trace init (take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t) final\<close> exists_trace_for_any_i_j by fastforce
     ultimately show "S t k = S ?newt k" 
       using \<open>S (t[i := t ! j, j := t ! i]) (j + 1) = S t (j + 1)\<close> same_traces trace_and_start_determines_end by auto
   qed
   moreover have "\<forall>k. k \<le> i \<longrightarrow> S t k = S ((t[i := t ! j])[j := t ! i]) k"
   proof (rule allI, rule impI)
     fix k
     assume "k \<le> i"
     let ?newt = "((t[i := t ! j])[j := t ! i])"
     have "trace init (take k t) (S t k)" 
       using "0.prems"(6) exists_trace_for_any_i by blast
     moreover have "trace init (take k ?newt) (S ?newt k)" 
       using \<open>take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\<close> \<open>trace init (take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t) final\<close> exists_trace_for_any_i by auto
     moreover have "take k t = take k ?newt" 
       using "0.prems"(1) \<open>k \<le> i\<close> by auto
     ultimately show "S t k = S ?newt k" 
       by (simp add: trace_and_start_determines_end)
   qed
   moreover have "prerecording_event (swap_events i j t) i"
   proof -
     have "~ has_snapshotted (S ((t[i := t ! j])[j := t ! i]) i) ?q" 
       by (metis "0.prems"(6) \<open>j = i + 1\<close> add.right_neutral calculation(4) le_add1 nsq snapshot_stable_ver_3)
     moreover have "regular_event ((t[i := t ! j])[j := t ! i] ! i)" 
       by (metis "0.prems"(4) "0.prems"(5) \<open>occurs_on (t ! i) \<noteq> occurs_on (t ! j)\<close> nth_list_update_eq nth_list_update_neq postrecording_event prerecording_event)
     moreover have "i < length ((t[i := t ! j])[j := t ! i])" 
       using "0.prems"(1) "0.prems"(2) by auto
     ultimately show ?thesis unfolding prerecording_event 
       by (metis (no_types, hide_lams) "0.prems"(1) \<open>take (j - (i + 1)) (drop (i + 1) t) = []\<close> \<open>take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\<close> append_Cons length_list_update nat_less_le nth_list_update_eq nth_list_update_neq self_append_conv2)
   qed
   moreover have "postrecording_event (swap_events i j t) (i+1)"
   proof -
     have "has_snapshotted (S ((t[i := t ! j])[j := t ! i]) (i+1)) ?p" 
       by (metis "0.prems"(4) add.right_neutral calculation(1) calculation(2) calculation(4) le_add1 postrecording_event snapshot_stable_ver_3)
     moreover have "regular_event ((t[i := t ! j])[j := t ! i] ! j)" 
       using "0.prems"(2) "0.prems"(4) length_list_update postrecording_event by auto
     moreover have "j < length t" using "0.prems" by auto
     ultimately show ?thesis unfolding postrecording_event 
       by (metis \<open>j = i + 1\<close> length_list_update nth_list_update_eq swap_neighbors_2)
   qed
   moreover have "\<forall>k. k > i+1 \<and> k < j+1 \<longrightarrow> ~ regular_event ((swap_events i j t) ! k)" using "0" by force
   ultimately show ?case using \<open>j = i + 1\<close> by force
 next
   case (Suc n)
   let ?p = "occurs_on (t ! i)"
   let ?q = "occurs_on (t ! j)"
   let ?t = "take ((j+1) - i) (drop i t)"
   let ?subt = "take (j - (i+1)) (drop (i+1) t)"
   let ?subt' = "take ((j-1) - (i+1)) (drop (i+1) t)"
   have sp: "has_snapshotted (S t i) ?p"
     using Suc.prems postrecording_event prerecording_event by blast
   have nsq: "~ has_snapshotted (S t j) ?q"
     using Suc.prems postrecording_event prerecording_event by blast
   have "?p \<noteq> ?q"
     using Suc.prems computation.post_before_pre_different_processes computation_axioms by blast
   have "?subt \<noteq> Nil" 
     using Suc.hyps(2) Suc.prems(1) Suc.prems(2) by auto
   have "?subt' = butlast ?subt" 
     by (metis Suc.prems(2) Suc_eq_plus1 butlast_drop butlast_take drop_take less_imp_le_nat)
   have "?t = t ! i # ?subt @ [t ! j]" 
   proof -
     have f1: "Suc j - i = Suc (j - i)"
       using Suc.prems(1) Suc_diff_le le_simps(1) by presburger
     have f2: "t ! i # drop (Suc i) t = drop i t"
       by (meson Cons_nth_drop_Suc Suc.prems(1) Suc.prems(2) less_trans)
     have f3: "t ! j # drop (Suc j) t = drop j t"
       using Cons_nth_drop_Suc Suc.prems(2) by blast
     have f4: "j - (i + 1) + (i + 1) = j"
       using Suc.prems(1) by force
     have "j - (i + 1) + Suc 0 = j - i"
       using Suc.prems(1) Suc_diff_Suc by presburger
     then show ?thesis
       using f4 f3 f2 f1 by (metis One_nat_def Suc.hyps(2) Suc_eq_plus1 drop_drop take_Suc_Cons take_add take_eq_Nil)
   qed
   then have "trace (S t i) ?t (S t (j+1))" 
     by (metis Suc.prems(1) Suc.prems(6) Suc_eq_plus1 exists_trace_for_any_i_j less_SucI nat_less_le)
   then have reg_tr_1:  "trace (S t i) (t ! i # ?subt) (S t j)" 
     by (metis (no_types, hide_lams) Suc.hyps(2) Suc.prems(1) Suc.prems(4) Suc.prems(6) Suc_eq_plus1 discrete exists_trace_for_any_i_j postrecording_event step_Suc tr_step)
   have reg_st_2: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
     using Suc.prems(2) Suc.prems(6) step_Suc by auto
   have "?subt = ?subt' @ [t ! (j-1)]"
   proof -
     have f1: "\<forall>n es. \<not> n < length es \<or> take n es @ [hd (drop n es)::('a, 'b, 'c) event] = take (Suc n) es"
       by (meson take_hd_drop) (* 0.0 ms *)
     have f2: "j - 1 - (i + 1) = n"
       by (metis (no_types) Suc.hyps(2) Suc_eq_plus1 diff_Suc_1 diff_diff_left plus_1_eq_Suc) (* 28 ms *)
     have f3: "\<forall>n na. \<not> n < na \<or> Suc n \<le> na"
       using Suc_leI by blast (* 0.0 ms *)
     then have f4: "Suc i \<le> j - 1"
       by (metis (no_types) Suc.hyps(2) Suc_eq_plus1 diff_diff_left plus_1_eq_Suc zero_less_Suc zero_less_diff) (* 12 ms *)
     have f5: "i + 1 < j"
       by (metis Suc.hyps(2) zero_less_Suc zero_less_diff) (* 4 ms *)
     then have f6: "t ! (j - 1) = hd (drop n (drop (i + 1) t))"
       using f4 f3 by (metis (no_types) Suc.hyps(2) Suc.prems(2) Suc_eq_plus1 Suc_lessD add_Suc_right diff_Suc_1 drop_drop hd_drop_conv_nth le_add_diff_inverse2 plus_1_eq_Suc) (* 140 ms *)
     have "n < length (drop (i + 1) t)"
       using f5 f3 by (metis (no_types) Suc.hyps(2) Suc.prems(2) Suc_eq_plus1 Suc_lessD drop_drop le_add_diff_inverse2 length_drop zero_less_diff) (* 144 ms *)
     then show ?thesis
       using f6 f2 f1 Suc.hyps(2) by presburger (* 4 ms *)
   qed
   then have reg_tr: "trace (S t i) (t ! i # ?subt') (S t (j-1))" 
   proof -
     have f1: "j - Suc i = Suc n"
       using Suc.hyps(2) by presburger
     have f2: "length (take j t) = j"
       by (metis (no_types) Suc.prems(2) length_take min.absorb2 nat_le_linear not_less)
     have f3: "(t ! i # drop (Suc i) (take j t)) @ [t ! j] = drop i (take (Suc j) t)"
       by (metis (no_types) Suc_eq_plus1 \<open>take (j + 1 - i) (drop i t) = t ! i # take (j - (i + 1)) (drop (i + 1) t) @ [t ! j]\<close> append_Cons drop_take)
     have f4: "Suc (i + n) = j - 1"
       using f1 by (metis (no_types) Suc.prems(1) Suc_diff_Suc add_Suc_right diff_Suc_1 le_add_diff_inverse nat_le_linear not_less)
     have "Suc (j - 1) = j"
       using f1 by simp
     then have f5: "butlast (take (Suc j) t) = take j t"
       using f4 f3 f2 f1 by (metis (no_types) Groups.add_ac(2) One_nat_def append_eq_conv_conj append_take_drop_id butlast_take diff_Suc_1 drop_drop length_append length_drop list.size(3) list.size(4) order_refl plus_1_eq_Suc plus_nat.simps(2) take_add take_all)
     have f6: "butlast (take j t) = take (j - 1) t"
       by (meson Suc.prems(2) butlast_take nat_le_linear not_less)
     have "drop (Suc i) (take j t) \<noteq> []"
       by (metis (no_types) Nil_is_append_conv Suc_eq_plus1 \<open>take (j - (i + 1)) (drop (i + 1) t) = take (j - 1 - (i + 1)) (drop (i + 1) t) @ [t ! (j - 1)]\<close> drop_take list.distinct(1))
     then show ?thesis
       using f6 f5 f4 f3 by (metis (no_types) Suc.prems(6) Suc_eq_plus1 butlast.simps(2) butlast_drop butlast_snoc drop_take exists_trace_for_any_i_j less_add_Suc1 nat_le_linear not_less)
   qed
 
   have reg_st_1: "(S t (j-1)) \<turnstile> (t ! (j-1)) \<mapsto> (S t j)" 
     by (metis Suc.prems(1) Suc.prems(2) Suc.prems(6) Suc_lessD diff_Suc_1 less_imp_Suc_add step_Suc)
   have "~ regular_event (t ! (j-1))" 
     using Suc.prems(3) \<open>take (j - (i + 1)) (drop (i + 1) t) \<noteq> []\<close> less_diff_conv by auto
   moreover have "regular_event (t ! j)" 
     using Suc.prems(5) computation.prerecording_event computation_axioms by blast
   moreover have "can_occur (t ! j) (S t j)" 
     using happen_implies_can_occur reg_tr_1 reg_st_2 by blast
   moreover have njmiq: "occurs_on (t ! (j-1)) \<noteq> ?q"
   proof (rule ccontr)
     assume "~ occurs_on (t ! (j-1)) \<noteq> ?q"
     then have "occurs_on (t ! (j-1)) = ?q" by simp
     then have "has_snapshotted (S t j) ?q" 
       using Suc.prems(6) calculation(1) diff_le_self nonregular_event_induces_snapshot reg_st_1 snapshot_stable_ver_2 by blast
     then show False using nsq by simp
   qed
   ultimately have "can_occur (t ! j) (S t (j-1))"
     using reg_tr reg_st_1 event_can_go_back_if_no_sender by auto
   then obtain d where new_st_1: "(S t (j-1)) \<turnstile> (t ! j) \<mapsto> d" 
     using exists_next_if_can_occur by blast
   then have "trace (S t i) (t ! i # ?subt' @ [t ! j]) d" using reg_tr trace_snoc by fastforce
   moreover have "can_occur (t ! (j-1)) d" 
     using \<open>(S t (j-1)) \<turnstile> t ! j \<mapsto> d\<close> \<open>occurs_on (t ! (j - 1)) \<noteq> occurs_on (t ! j)\<close> event_stays_valid_if_no_occurrence happen_implies_can_occur reg_st_1 by auto
   moreover obtain e where new_st_2: "d \<turnstile> (t ! (j-1)) \<mapsto> e" 
     using calculation(2) exists_next_if_can_occur by blast
 
   have pre_swap: "e = (S t (j+1))"
   proof -
     have "states e = states (S t (j+1))"
     proof (rule ext)
       fix p
       have "states (S t (j-1)) p = states (S t j) p"
         using no_state_change_if_nonregular_event\<open>~ regular_event (t ! (j-1))\<close> reg_st_1 by auto
       moreover have "states d p = states e p"
         using no_state_change_if_nonregular_event\<open>~ regular_event (t ! (j-1))\<close> new_st_2 by auto
       moreover have "states d p = states (S t (j+1)) p" 
       proof -
         have "\<forall>a. states (S t (j + 1)) a = states d a"
           by (meson \<open>\<not> regular_event (t ! (j - 1))\<close> new_st_1 no_state_change_if_nonregular_event reg_st_1 reg_st_2 same_state_implies_same_result_state)
         then show ?thesis
           by presburger
       qed
       ultimately show "states e p = states (S t (j+1)) p" by simp
     qed
 
     moreover have "msgs e = msgs (S t (j+1))"
     proof (rule ext)
       fix cid
       have "isTrans (t ! j) \<or> isSend (t ! j) \<or> isRecv (t ! j)" 
         using \<open>regular_event (t ! j)\<close> by auto
       moreover have "isSnapshot (t ! (j-1)) \<or> isRecvMarker (t ! (j-1))"
         using nonregular_event \<open>~ regular_event (t ! (j-1))\<close> by auto
       ultimately show "msgs e cid = msgs (S t (j+1)) cid"
       proof (elim disjE, goal_cases)
         case 1
         then show ?case 
           using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_Trans_Snapshot by auto
       next
         case 2
         then show ?case 
           using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_msgs_Trans_RecvMarker by auto
       next
         case 3
         then show ?case 
           using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_Send_Snapshot by auto
       next
         case 4
         then show ?case 
           using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_Recv_Snapshot by auto
       next
         case 5
         then show ?case 
           using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_msgs_Send_RecvMarker by auto
       next
         case 6
         then show ?case 
           using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_msgs_Recv_RecvMarker by auto
       qed
     qed
 
     moreover have "process_snapshot e = process_snapshot (S t (j+1))"
     proof (rule ext)
       fix p
       have "process_snapshot (S t j) p = process_snapshot (S t (j+1)) p" 
         using \<open>regular_event (t ! j)\<close> reg_st_2 regular_event_preserves_process_snapshots by blast
       moreover have "process_snapshot (S t (j-1)) p = process_snapshot d p" 
         using \<open>regular_event (t ! j)\<close> new_st_1 regular_event_preserves_process_snapshots by blast
       moreover have "process_snapshot e p = process_snapshot (S t j) p" 
       proof -
         have "occurs_on (t ! j) = p \<longrightarrow> ps e p = ps (S t j) p"
           using calculation(2) new_st_2 njmiq no_state_change_if_no_event reg_st_1 by force
         then show ?thesis
           by (meson new_st_1 new_st_2 no_state_change_if_no_event reg_st_1 same_snapshot_state_implies_same_result_snapshot_state)
       qed
       ultimately show "process_snapshot e p = process_snapshot (S t (j+1)) p" by simp
     qed
 
     moreover have "cs e = cs (S t (j+1))"
     proof (rule ext)
       fix cid
       have "isTrans (t ! j) \<or> isSend (t ! j) \<or> isRecv (t ! j)" 
         using \<open>regular_event (t ! j)\<close> by auto
       moreover have "isSnapshot (t ! (j-1)) \<or> isRecvMarker (t ! (j-1))"
         using nonregular_event \<open>~ regular_event (t ! (j-1))\<close> by auto
       ultimately show "cs e cid = cs (S t (j+1)) cid"
       proof (elim disjE, goal_cases)
         case 1
         then show ?case 
           using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Trans_Snapshot by auto
       next
         case 2
         then show ?case
           using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Trans_RecvMarker by auto
       next
         case 3
         then show ?case
           using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Send_Snapshot by auto
       next
         case 4
         then show ?case
           using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Recv_Snapshot njmiq by auto
       next
         case 5
         then show ?case
           using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Send_RecvMarker by auto
       next
         case 6
         then show ?case
           using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Recv_RecvMarker njmiq by auto
       qed
     qed
     ultimately show ?thesis by auto
   qed
 
   let ?it = "(t[j-1 := t ! j])[j := t ! (j-1)]"
   have same_prefix: "take (j-1) ?it = take (j-1) t" by simp
   have same_suffix: "drop (j+1) ?it = drop (j+1) t" by simp
   have trace_prefix: "trace init (take (j-1) ?it) (S t (j-1))"
     using Suc.prems(6) exists_trace_for_any_i by auto
   have "?it = take (j-1) t @ [t ! j, t ! (j-1)] @ drop (j+1) t" 
   proof -
     have "1 < j"
       by (metis (no_types) Suc.hyps(2) Suc_eq_plus1 add_lessD1 plus_1_eq_Suc zero_less_Suc zero_less_diff) (* 12 ms *)
     then have "j - 1 + 1 = j"
       by (metis (no_types) le_add_diff_inverse2 nat_less_le) (* 4 ms *)
     then show ?thesis
       by (metis (no_types) Suc.prems(2) Suc_eq_plus1 add_Suc_right one_add_one swap_neighbors) (* 76 ms *)
   qed
   have "trace (S t (j-1)) [t ! j, t ! (j-1)] (S t (j+1))" 
     by (metis new_st_1 new_st_2 pre_swap trace.simps)
   have "trace init (take (j+1) t @ drop (j+1) t) final" 
     by (simp add: Suc.prems(6))
   then have "trace init (take (j+1) t) (S t (j+1)) \<and> trace (S t (j+1)) (drop (j+1) t) final" 
     using Suc.prems(6) exists_trace_for_any_i split_trace trace_and_start_determines_end by blast
   then have trace_suffix: "trace (S t (j+1)) (drop (j+1) ?it) final" using same_suffix by simp
   have "trace init ?it final" 
     by (metis (no_types, lifting) \<open>t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\<close> \<open>trace (S t (j + 1)) (drop (j + 1) (t[j - 1 := t ! j, j := t ! (j - 1)])) final\<close> \<open>trace (S t (j - 1)) [t ! j, t ! (j - 1)] (S t (j + 1))\<close> \<open>trace init (take (j - 1) (t[j - 1 := t ! j, j := t ! (j - 1)])) (S t (j - 1))\<close> same_prefix same_suffix trace_trans)
   have suffix_same_states: "\<forall>k. k > j \<longrightarrow> S t k = S ?it k"
   proof (rule allI, rule impI)
     fix k
     assume "k > j"
     have eq_trace: "drop (j+1) t = drop (j+1) ?it" by simp
     have "trace init (take (j+1) ?it) (S ?it (j+1))" 
       using \<open>trace init (t[j - 1 := t ! j, j := t ! (j - 1)]) final\<close> exists_trace_for_any_i by blast
     moreover have "trace init (take (j+1) ?it) (S t (j+1))" 
     proof -
       have f1: "\<forall>es esa esb esc. (esb::('a, 'b, 'c) event list) @ es \<noteq> esa @ esc @ es \<or> esa @ esc = esb"
         by auto
       have f2: "take (j + 1) (t[j - 1 := t ! j, j := t ! (j - 1)]) @ drop (j + 1) t = t [j - 1 := t ! j, j := t ! (j - 1)]"
         by (metis append_take_drop_id same_suffix)
       have "trace init (take (j - 1) t @ [t ! j, t ! (j - 1)]) (S t (j + 1))"
         using \<open>trace (S t (j - 1)) [t ! j, t ! (j - 1)] (S t (j + 1))\<close> same_prefix trace_prefix trace_trans by presburger
       then show ?thesis
         using f2 f1 by (metis (no_types) \<open>t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\<close>)
     qed
     ultimately have eq_start: "S ?it (j+1) = S t (j+1)" 
       using trace_and_start_determines_end by blast
     then have "take k ?it = take (j+1) ?it @ take (k - (j+1)) (drop (j+1) ?it)" 
       by (metis Suc_eq_plus1 Suc_leI \<open>j < k\<close> le_add_diff_inverse take_add)
     have "trace (S ?it (j+1)) (take (k - (j+1)) (drop (j+1) ?it)) (S ?it k)" 
       by (metis Suc_eq_plus1 Suc_leI \<open>j < k\<close> \<open>trace init (t[j - 1 := t ! j, j := t ! (j - 1)]) final\<close> exists_trace_for_any_i_j)
     moreover have "trace (S t (j+1)) (take (k - (j+1)) (drop (j+1) t)) (S t k)" 
       using Suc.prems(6) \<open>j < k\<close> exists_trace_for_any_i_j by fastforce
     ultimately show "S t k = S ?it k" 
       using eq_start trace_and_start_determines_end by auto
   qed
   have prefix_same_states: "\<forall>k. k < j \<longrightarrow> S t k = S ?it k"
   proof (rule allI, rule impI)
     fix k
     assume "k < j"
     have "trace init (take k t) (S t k)" 
       using Suc.prems(6) exists_trace_for_any_i by blast
     moreover have "trace init (take k ?it) (S ?it k)" 
       by (meson \<open>trace init (t[j - 1 := t ! j, j := t ! (j - 1)]) final\<close> exists_trace_for_any_i)
     ultimately show "S t k = S ?it k" 
       using \<open>k < j\<close> s_def by auto
   qed
   moreover have "j - 1 < length ?it"
     using Suc.prems(2) by auto
   moreover have "prerecording_event ?it (j-1)" 
   proof -
     have f1: "t[j - 1 := t ! j, j := t ! (j - 1)] ! (j - 1) = t[j - 1 := t ! j] ! (j - 1)"
       by (metis (no_types) njmiq nth_list_update_neq) (* 28 ms *)
     have "j \<noteq> 0"
       by (metis (no_types) Suc.prems(1) not_less_zero) (* 0.0 ms *)
     then have "\<not> j < 1"
       by blast (* 0.0 ms *)
     then have "S t (j - 1) = S (t[j - 1 := t ! j, j := t ! (j - 1)]) (j - 1)"
       by (simp add: prefix_same_states) (* 8 ms *)
     then show ?thesis
       using f1 by (metis \<open>regular_event (t ! j)\<close> calculation(4) computation.prerecording_event computation_axioms length_list_update njmiq no_state_change_if_no_event nsq nth_list_update_eq reg_st_1) (* 456 ms *)
   qed
   moreover have "postrecording_event ?it i"
   proof -
     have "i < length ?it" 
       using Suc.prems(4) postrecording_event by auto
     then show ?thesis 
     proof -
       assume "i < length (t[j - 1 := t ! j, j := t ! (j - 1)])"
       have "i < j - 1"
         by (metis (no_types) Suc.hyps(2) cancel_ab_semigroup_add_class.diff_right_commute diff_diff_left zero_less_Suc zero_less_diff)
       then show ?thesis
         using Suc.prems(1) Suc.prems(4) postrecording_event prefix_same_states by auto
     qed
   qed
   moreover have "i < j - 1"
     using Suc.hyps(2) by auto
   moreover have "\<forall>k. i < k \<and> k < (j-1) \<longrightarrow> ~ regular_event (?it ! k)"
   proof (rule allI, rule impI)
     fix k
     assume "i < k \<and> k < (j-1)"
     show "~ regular_event (?it ! k)" 
       using Suc.prems(3) \<open>i < k \<and> k < j - 1\<close> by force
   qed
   moreover have "(j-1) - (i+1) = n" using Suc.prems Suc.hyps by auto
   ultimately have ind: "trace init (swap_events i (j-1) ?it) final
                         \<and> (\<forall>k. k \<ge> (j-1)+1 \<longrightarrow> S (swap_events i (j-1) ?it) k = S ?it k)
                         \<and> (\<forall>k. k \<le> i \<longrightarrow> S (swap_events i (j-1) ?it) k = S ?it k)
                         \<and> prerecording_event (swap_events i (j-1) ?it) i
                         \<and> postrecording_event (swap_events i (j-1) ?it) (i+1)
                         \<and> (\<forall>k. k > i+1 \<and> k < (j-1)+1 \<longrightarrow> ~ regular_event ((swap_events i (j-1) ?it) ! k))"
     using Suc.hyps \<open>trace init ?it final\<close> by blast
   then have new_trace: "trace init (swap_events i (j-1) ?it) final" by blast
   have equal_suffix_states: "\<forall>k. k \<ge> j \<longrightarrow> S (swap_events i (j-1) ?it) k = S ?it k" 
     using Suc.prems(1) ind by simp
   have equal_prefix_states: "\<forall>k. k \<le> i \<longrightarrow> S (swap_events i (j-1) ?it) k = S ?it k"
     using ind by blast
   have neighboring_events_shifted: "\<forall>k. k > i+1 \<and> k < j \<longrightarrow> ~ regular_event ((swap_events i (j-1) ?it) ! k)"
     using ind by force
 
   let ?itn = "swap_events i (j-1) ?it"
   have "?itn = swap_events i j t"
   proof -
     have f1: "i \<le> j - 1"
       using \<open>i < j - 1\<close> less_imp_le_nat by blast
     have "t ! j # [t ! (j - 1)] @ drop (j + 1) t = drop (j - 1) (take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t)"
       using \<open>t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\<close> same_prefix by force
     then have f2: "t[j - 1 := t ! j, j := t ! (j - 1)] ! (j - 1) = t ! j \<and> drop (j - 1 + 1) (t[j - 1 := t ! j, j := t ! (j - 1)]) = t ! (j - 1) # [] @ drop (j + 1) t"
       by (metis (no_types) Cons_nth_drop_Suc Suc_eq_plus1 \<open>j - 1 < length (t[j - 1 := t ! j, j := t ! (j - 1)])\<close> \<open>t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\<close> append_Cons list.inject)
     have "t ! i = t[j - 1 := t ! j, j := t ! (j - 1)] ! i"
       by (metis (no_types) Suc.prems(1) \<open>i < j - 1\<close> nat_neq_iff nth_list_update_neq)
     then show ?thesis
       using f2 f1 by (metis (no_types) Suc.prems(1) \<open>take (j - (i + 1)) (drop (i + 1) t) = take (j - 1 - (i + 1)) (drop (i + 1) t) @ [t ! (j - 1)]\<close> append.assoc append_Cons drop_take less_imp_le_nat same_prefix take_update_cancel)
   qed
 
   moreover have "\<forall>k. k \<le> i \<longrightarrow> S t k = S ?itn k" 
     using Suc.prems(1) equal_prefix_states prefix_same_states by auto
   moreover have "\<forall>k. k \<ge> j + 1 \<longrightarrow> S t k = S ?itn k" 
     by (metis (no_types, lifting) Suc_eq_plus1 add_lessD1 equal_suffix_states lessI nat_less_le suffix_same_states)
   moreover have "\<forall>k. k > i+1 \<and> k < j+1 \<longrightarrow> ~ regular_event (?itn ! k)"
   proof -
     have "~ regular_event (?itn ! j)" 
     proof -
       have f1: "j - 1 < length t"
         using \<open>j - 1 < length (t[j - 1 := t ! j, j := t ! (j - 1)])\<close> by force
       have f2: "\<And>n na es. \<not> n < na \<or> \<not> na < length es \<or> drop (Suc na) (take n es @ [hd (drop na es), es ! n::('a, 'b, 'c) event] @ take (na - Suc n) (drop (Suc n) es) @ drop (Suc na) es) = drop (Suc na) es"
         by (metis Suc_eq_plus1 hd_drop_conv_nth swap_identical_tails)
       have f3: "t ! j = hd (drop j t)"
         by (simp add: Suc.prems(2) hd_drop_conv_nth)
       have "\<not> j < 1"
         using Suc.prems(1) by blast
       then have "\<not> regular_event (hd (drop j (take i (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)]) @ [hd (drop (j - 1) (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)])), t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)] ! i] @ take (j - 1 - Suc i) (drop (Suc i) (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)])) @ drop (Suc (j - 1)) (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)]))))"
         using f2 f1 by (metis (no_types) Suc.prems(2) \<open>\<not> regular_event (t ! (j - 1))\<close> \<open>i < j - 1\<close> add_diff_inverse_nat hd_drop_conv_nth length_list_update nth_list_update_eq plus_1_eq_Suc)
       then show ?thesis
         using f3 f1 by (metis Suc.prems(2) Suc_eq_plus1 \<open>i < j - 1\<close> hd_drop_conv_nth length_list_update swap_identical_length)
     qed
     then show ?thesis 
       by (metis Suc_eq_plus1 less_Suc_eq neighboring_events_shifted)
   qed
 
   ultimately show ?case using ind by presburger
 qed
 
 subsubsection \<open>Relating configurations and the computed snapshot\<close>
 
 definition ps_equal_to_snapshot where
   "ps_equal_to_snapshot c c' \<equiv>
      \<forall>p. Some (states c p) = process_snapshot c' p"
 
 definition cs_equal_to_snapshot where
   "cs_equal_to_snapshot c c' \<equiv>
      \<forall>cid. channel cid \<noteq> None
        \<longrightarrow> filter ((\<noteq>) Marker) (msgs c cid)
            = map Msg (fst (channel_snapshot c' cid))"
 
 definition state_equal_to_snapshot where
   "state_equal_to_snapshot c c' \<equiv>
      ps_equal_to_snapshot c c' \<and> cs_equal_to_snapshot c c'"
 
 lemma init_is_s_t_0:
   assumes
     "trace init t final"
   shows
     "init = (S t 0)"
   by (metis assms exists_trace_for_any_i take_eq_Nil tr_init trace_and_start_determines_end)
 
 lemma final_is_s_t_len_t:
   assumes
     "trace init t final"
   shows
     "final = S t (length t)"
   by (metis assms exists_trace_for_any_i order_refl take_all trace_and_start_determines_end)
 
 lemma snapshot_event:
   assumes
     "trace init t final" and
     "~ has_snapshotted (S t i) p" and
     "has_snapshotted (S t (i+1)) p"
   shows
     "isSnapshot (t ! i) \<or> isRecvMarker (t ! i)"
 proof -
   have "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis Suc_eq_plus1 assms(1) assms(2) assms(3) distributed_system.step_Suc computation_axioms computation_def nat_less_le not_less not_less_eq s_def take_all)
   then show ?thesis 
     using assms(2) assms(3) nonregular_event regular_event_cannot_induce_snapshot by blast
 qed
 
 lemma snapshot_state:
   assumes
     "trace init t final" and
     "states (S t i) p = u" and
     "~ has_snapshotted (S t i) p" and
     "has_snapshotted (S t (i+1)) p"
   shows
     "ps (S t (i+1)) p = Some u"
 proof -
   have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis add.commute assms(1) assms(3) assms(4) le_SucI le_eq_less_or_eq le_refl nat_neq_iff no_change_if_ge_length_t plus_1_eq_Suc step_Suc)
   let ?q = "occurs_on (t ! i)"
   have qp: "?q = p"
   proof (rule ccontr)
     assume "?q \<noteq> p"
     then have "has_snapshotted (S t (i+1)) p = has_snapshotted (S t i) p" 
       using local.step no_state_change_if_no_event by auto
     then show False using assms by simp
   qed
   have "isSnapshot (t ! i) \<or> isRecvMarker (t ! i)" using assms snapshot_event by auto
   then show ?thesis
   proof (elim disjE, goal_cases)
     case 1
     then have "t ! i = Snapshot p"
       by (metis event.collapse(4) qp)
     then show ?thesis 
       using assms(2) local.step by auto
   next
     case 2
     then obtain cid' q where "t ! i = RecvMarker cid' p q"
       by (metis event.collapse(5) qp)
     then show ?thesis using assms step by auto
   qed
 qed
 
 lemma snapshot_state_unchanged_trace_2:
   shows
     "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
        ps (S t i) p = Some u
      \<rbrakk> \<Longrightarrow> ps (S t j) p = Some u"
 proof (induct i j rule:S_induct)
   case S_init
   then show ?case by simp
 next
   case S_step
   then show ?case using snapshot_state_unchanged by auto
 qed
 
 lemma no_recording_cs_if_not_snapshotted:
   shows
     "\<lbrakk> trace init t final; ~ has_snapshotted (S t i) p;
        channel cid = Some (q, p) \<rbrakk> \<Longrightarrow> cs (S t i) cid = cs init cid"
 proof (induct i)
   case 0
   then show ?case 
     by (metis exists_trace_for_any_i list.discI take_eq_Nil trace.simps)
 next
   case (Suc i)
   have "Suc i < length t"
   proof -
     have "has_snapshotted final p" 
       using all_processes_snapshotted_in_final_state valid by blast
     show ?thesis
     proof (rule ccontr)
       assume "~ Suc i < length t"
       then have "Suc i \<ge> length t" by simp
       then have "has_snapshotted (S t (Suc i)) p" 
         using Suc.prems(1) \<open>ps final p \<noteq> None\<close> final_is_s_t_len_t snapshot_stable_ver_3 by blast
       then show False using Suc by simp
     qed
   qed
 
   then have t_dec: "trace init (take i t) (S t i) \<and> (S t i) \<turnstile> (t ! i) \<mapsto> (S t (Suc i))"
     using Suc.prems(1) exists_trace_for_any_i step_Suc by auto
   moreover have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (Suc i))" using calculation by simp
 
   ultimately have IH: "cs (S t i) cid = cs init cid" 
     using Suc.hyps Suc.prems(1) Suc.prems(2) Suc.prems(3) snapshot_state_unchanged by fastforce
 
   then show ?case
   proof (cases "t ! i")
     case (Snapshot r)
     have "r \<noteq> p"
     proof (rule ccontr)
       assume "~ r \<noteq> p"
       then have "r = p" by simp
       then have "has_snapshotted (S t (Suc i)) p" 
         using Snapshot step by auto
       then show False using Suc by simp
     qed
     then have "cs (S t i) cid = cs (S t (Suc i)) cid" 
       using Snapshot Suc.prems(3) local.step by auto
     then show ?thesis using IH by simp
   next
     case (RecvMarker cid' r s)
     have "r \<noteq> p"
     proof (rule ccontr)
       assume "~ r \<noteq> p"
       then have "r = p" by simp
       then have "has_snapshotted (S t (Suc i)) p"
         using RecvMarker t_dec recv_marker_means_snapshotted_1 by blast
       then show False using Suc by simp
     qed
     have "cid' \<noteq> cid"
     proof (rule ccontr)
       assume "~ cid' \<noteq> cid"
       then have "channel cid' = Some (s, r)" using t_dec can_occur_def RecvMarker by simp
       then show False 
         using Suc.prems(3) \<open>\<not> cid' \<noteq> cid\<close> \<open>r \<noteq> p\<close> by auto
     qed
     then have "cs (S t i) cid = cs (S t (Suc i)) cid"
     proof -
       have "\<nexists>s. channel cid = Some (s, r)" using \<open>r \<noteq> p\<close> Suc by simp
       with RecvMarker t_dec \<open>cid' \<noteq> cid\<close> \<open>r \<noteq> p\<close> Suc.prems(3) show ?thesis
         by (cases "has_snapshotted (S t i) r", auto)
     qed
     then show ?thesis using IH by simp
   next
     case (Trans r u u')
     then show ?thesis 
       using IH t_dec by auto
   next
     case (Send cid' r s u u' m)
     then show ?thesis 
       using IH local.step by auto
   next
     case (Recv cid' r s u u' m)
     then have "snd (cs (S t i) cid) = NotStarted" 
       by (simp add: IH no_initial_channel_snapshot)
     with Recv step Suc show ?thesis by (cases "cid' = cid", auto) 
   qed
 qed
 
 lemma cs_done_implies_has_snapshotted:
   assumes
     "trace init t final" and
     "snd (cs (S t i) cid) = Done" and
     "channel cid = Some (p, q)"
   shows
     "has_snapshotted (S t i) q"
 proof -
   show ?thesis 
     using assms no_initial_channel_snapshot no_recording_cs_if_not_snapshotted by fastforce
 qed
 
 lemma exactly_one_snapshot:
   assumes
     "trace init t final"
   shows
     "\<exists>!i. ~ has_snapshotted (S t i) p \<and> has_snapshotted (S t (i+1)) p" (is ?P)
 proof -
   have "~ has_snapshotted init p" 
     using no_initial_process_snapshot by auto
   moreover have "has_snapshotted final p" 
     using all_processes_snapshotted_in_final_state valid by blast
   moreover have "trace (S t 0) t (S t (length t))" 
     using assms final_is_s_t_len_t init_is_s_t_0 by auto
   ultimately have ex_snap: "\<exists>i. ~ has_snapshotted (S t i) p \<and> has_snapshotted (S t (i+1)) p" 
     using assms exists_snapshot_for_all_p by auto
   show ?thesis
   proof (rule ccontr)
     assume "~ ?P"
     then have "\<exists>i j. (i \<noteq> j) \<and> ~ has_snapshotted (S t i) p \<and> has_snapshotted (S t (i+1)) p \<and>
                                 ~ has_snapshotted (S t j) p \<and> has_snapshotted (S t (j+1)) p"
       using ex_snap by blast
     then have "\<exists>i j. (i < j) \<and> ~ has_snapshotted (S t i) p \<and> has_snapshotted (S t (i+1)) p \<and>
                                 ~ has_snapshotted (S t j) p \<and> has_snapshotted (S t (j+1)) p"
       by (meson linorder_neqE_nat)
     then obtain i j where "i < j" "~ has_snapshotted (S t i) p" "has_snapshotted (S t (i+1)) p"
                                   "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p"
       by blast
     have "trace (S t (i+1)) (take (j - (i+1)) (drop (i+1) t)) (S t j)" 
       using \<open>i < j\<close> assms exists_trace_for_any_i_j by fastforce
     then have "has_snapshotted (S t j) p" 
       using \<open>ps (S t (i + 1)) p \<noteq> None\<close> snapshot_stable by blast
     then show False using \<open>~ has_snapshotted (S t j) p\<close> by simp
   qed
 qed
 
 lemma initial_cs_changes_implies_nonregular_event:
   assumes
     "trace init t final" and
     "snd (cs (S t i) cid) = NotStarted" and
     "snd (cs (S t (i+1)) cid) \<noteq> NotStarted" and
     "channel cid = Some (p, q)"
   shows
     "~ regular_event (t ! i)"
 proof -
   have "i < length t"
   proof (rule ccontr)
     assume "~ i < length t"
     then have "S t i = S t (i+1)" 
       using assms(1) no_change_if_ge_length_t by auto
     then show False using assms by presburger
     qed
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     using assms(1) step_Suc by auto
   show ?thesis
   proof (rule ccontr)
     assume "~ ~ regular_event (t ! i)"
     then have "regular_event (t ! i)" by simp
     then have "cs (S t i) cid = cs (S t (i+1)) cid"
     proof (cases "isRecv (t ! i)")
       case False
       then show ?thesis 
         using \<open>regular_event (t ! i)\<close> local.step no_cs_change_if_no_event by blast
     next
       case True
       then obtain cid' r s u u' m where Recv: "t ! i = Recv cid' r s u u' m" by (meson isRecv_def)
       with assms step show ?thesis
       proof (cases "cid = cid'")
         case True
         then show ?thesis using assms step Recv by simp
       next
         case False
         then show ?thesis using assms step Recv by simp
       qed
     qed
     then show False using assms by simp
   qed
 qed
 
 lemma cs_in_initial_state_implies_not_snapshotted:
   assumes
     "trace init t final" and
     "snd (cs (S t i) cid) = NotStarted" and
     "channel cid = Some (p, q)"
   shows
     "~ has_snapshotted (S t i) q"
 proof (rule ccontr)
   assume "~ ~ has_snapshotted (S t i) q"
   then obtain j where "j < i" "~ has_snapshotted (S t j) q" "has_snapshotted (S t (j+1)) q" 
     by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p computation.snapshot_stable_ver_3 computation_axioms nat_le_linear order_le_less)
   have step_j: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
     by (metis \<open>\<not> \<not> ps (S t i) q \<noteq> None\<close> \<open>\<not> ps (S t j) q \<noteq> None\<close> \<open>j < i\<close> add.commute assms(1) linorder_neqE_nat no_change_if_ge_length_t order_le_less order_refl plus_1_eq_Suc step_Suc)
   have tr_j_i: "trace (S t (j+1)) (take (i - (j+1)) (drop (j+1) t)) (S t i)" 
     using \<open>j < i\<close> assms(1) exists_trace_for_any_i_j by fastforce
   have "~ regular_event (t ! j)" 
     using step_j \<open>\<not> ps (S t j) q \<noteq> None\<close> \<open>ps (S t (j + 1)) q \<noteq> None\<close> regular_event_cannot_induce_snapshot by blast
   then have "isSnapshot (t ! j) \<or> isRecvMarker (t ! j)" 
     using nonregular_event by auto
   then have "snd (cs (S t (j+1)) cid) \<noteq> NotStarted"
   proof (elim disjE, goal_cases)
     case 1
     have "occurs_on (t ! j) = q" 
       using \<open>\<not> ps (S t j) q \<noteq> None\<close> \<open>ps (S t (j + 1)) q \<noteq> None\<close> distributed_system.no_state_change_if_no_event distributed_system_axioms step_j by fastforce
     with 1 have "t ! j = Snapshot q" using isSnapshot_def by auto
     then show ?thesis using step_j assms by simp
   next
     case 2
     have "occurs_on (t ! j) = q" 
       using \<open>\<not> ps (S t j) q \<noteq> None\<close> \<open>ps (S t (j + 1)) q \<noteq> None\<close> distributed_system.no_state_change_if_no_event distributed_system_axioms step_j by fastforce
     with 2 obtain cid' s where RecvMarker: "t ! j = RecvMarker cid' q s"
       by (metis event.collapse(5))
     then show ?thesis
     proof (cases "cid' = cid")
       case True
       then show ?thesis using RecvMarker step_j assms by simp
     next
       case False
       have "~ has_snapshotted (S t j) q" 
         using \<open>\<not> ps (S t j) q \<noteq> None\<close> by auto
       moreover have "\<exists>r. channel cid = Some (r, q)" 
         by (simp add: assms(3))
       ultimately show ?thesis using RecvMarker step_j assms False by simp
     qed
   qed
   then have "snd (cs (S t i) cid) \<noteq> NotStarted"
     using tr_j_i cs_not_not_started_stable_trace assms by blast
   then show False using assms by simp
 qed
 
 lemma nonregular_event_in_initial_state_implies_cs_changed:
   assumes
     "trace init t final" and
     "snd (cs (S t i) cid) = NotStarted" and
     "~ regular_event (t ! i)" and
     "occurs_on (t ! i) = q" and
     "channel cid = Some (p, q)" and
     "i < length t"
   shows
     "snd (cs (S t (i+1)) cid) \<noteq> NotStarted"
 proof -
   have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" using step_Suc assms by auto
   have "isSnapshot (t ! i) \<or> isRecvMarker (t ! i)" 
     using assms(3) nonregular_event by blast
   then show ?thesis
   proof (elim disjE, goal_cases)
     case 1
     then show ?thesis 
       using assms cs_in_initial_state_implies_not_snapshotted local.step nonregular_event_induces_snapshot by blast
   next
     case 2
     then show ?thesis 
       by (metis assms(1) assms(2) assms(3) assms(4) assms(5) cs_in_initial_state_implies_not_snapshotted local.step nonregular_event_induces_snapshot)
   qed
 qed
 
 lemma cs_recording_implies_snapshot:
   assumes
     "trace init t final" and
     "snd (cs (S t i) cid) = Recording" and
     "channel cid = Some (p, q)"
   shows
     "has_snapshotted (S t i) q"
 proof (rule ccontr)
   assume "~ has_snapshotted (S t i) q"
   have "\<lbrakk> trace init t final; ~ has_snapshotted (S t i) p; channel cid = Some (p, q) \<rbrakk>
         \<Longrightarrow> snd (cs (S t i) cid) = NotStarted"
   proof (induct i)
     case 0
     then show ?case 
       using init_is_s_t_0 no_initial_channel_snapshot by auto
   next
     case (Suc n)
     have step: "(S t n) \<turnstile> (t ! n) \<mapsto> (S t (n+1))" 
       by (metis Suc.prems(2) Suc_eq_plus1 all_processes_snapshotted_in_final_state assms(1) distributed_system.step_Suc distributed_system_axioms final_is_s_t_len_t le_add1 not_less snapshot_stable_ver_3)
     have "snd (cs (S t n) cid) = NotStarted" 
       using Suc.hyps Suc.prems(2) assms snapshot_state_unchanged computation_axioms local.step by fastforce
     then show ?case 
       by (metis Suc.prems(1) \<open>\<not> ps (S t i) q \<noteq> None\<close> assms(2) assms(3) cs_not_not_started_stable_trace exists_trace_for_any_i no_recording_cs_if_not_snapshotted recording_state.simps(2))
   qed
   then show False 
     using \<open>\<not> ps (S t i) q \<noteq> None\<close> assms computation.no_initial_channel_snapshot computation_axioms no_recording_cs_if_not_snapshotted by fastforce
 qed
 
 lemma cs_done_implies_both_snapshotted:
   assumes
     "trace init t final" and
     "snd (cs (S t i) cid) = Done" and
     "i < length t" and
     "channel cid = Some (p, q)"
   shows
     "has_snapshotted (S t i) p"
     "has_snapshotted (S t i) q"
 proof -
   have "trace init (take i t) (S t i)" 
     using assms(1) exists_trace_for_any_i by blast
   then have "RecvMarker cid q p : set (take i t)" 
     by (metis assms(1,2,4) cs_done_implies_has_snapshotted done_only_from_recv_marker_trace computation.no_initial_process_snapshot computation_axioms init_is_s_t_0 list.discI trace.simps)
   then obtain k where "t ! k = RecvMarker cid q p" "0 \<le> k" "k < i" 
     by (metis add.right_neutral add_diff_cancel_right' append_Nil append_take_drop_id assms(1) exists_index take0)
   then have "has_snapshotted (S t (k+1)) q" 
     by (metis (no_types, lifting) Suc_eq_plus1 Suc_leI assms(1,2,4) computation.cs_done_implies_has_snapshotted computation.no_change_if_ge_length_t computation_axioms less_le not_less_eq recv_marker_means_cs_Done)
   then show "has_snapshotted (S t i) q" 
     using assms cs_done_implies_has_snapshotted by blast
   have step_k: "(S t k) \<turnstile> (t ! k) \<mapsto> (S t (k+1))" 
     by (metis Suc_eq_plus1 \<open>k < i\<close> add_lessD1 assms(1) assms(3) distributed_system.step_Suc distributed_system_axioms less_imp_add_positive)
   then have "Marker : set (msgs (S t k) cid)"
   proof -
     have "can_occur (t ! k) (S t k)" using happen_implies_can_occur step_k by blast
     then show ?thesis unfolding can_occur_def \<open>t ! k = RecvMarker cid q p\<close> 
       using hd_in_set by fastforce
   qed
   then have "has_snapshotted (S t k) p" 
     using assms(1,4) no_marker_if_no_snapshot by blast
   then show "has_snapshotted (S t i) p" 
     using \<open>k < i\<close> assms(1) less_imp_le_nat snapshot_stable_ver_3 by blast
 qed
 
 lemma cs_done_implies_same_snapshots:
   assumes "trace init t final" "i \<le> j" "j \<le> length t"
   shows "snd (cs (S t i) cid) = Done \<Longrightarrow> channel cid = Some (p, q) \<Longrightarrow> cs (S t i) cid = cs (S t j) cid"
 using assms proof (induct i j rule: S_induct)
   case (S_init i)
   then show ?case by auto
 next
   case (S_step i j)
   have snap_p: "has_snapshotted (S t i) p" 
     using S_step.hyps(1) S_step.hyps(2) S_step.prems(1,2) assms(1) cs_done_implies_both_snapshotted(1) by auto
   have snap_q: "has_snapshotted (S t i) q" 
     using S_step.prems(1,2) assms(1) cs_done_implies_has_snapshotted by blast
   from S_step have "cs (S t i) cid = cs (S t (Suc i)) cid"
   proof (cases "t ! i")
     case (Snapshot r)
     from Snapshot S_step.hyps(3) snap_p have False if "r = p" using that by (auto simp: can_occur_def)
     moreover
     from Snapshot S_step.hyps(3) snap_q have False if "r = q" using that by (auto simp: can_occur_def)
     ultimately show ?thesis using Snapshot S_step by force
   next
     case (RecvMarker cid' r s)
     then show ?thesis
     proof (cases "has_snapshotted (S t i) r")
       case True
       with RecvMarker S_step show ?thesis
       proof (cases "cid = cid'")
         case True
         then have "cs (S t (Suc i)) cid = (fst (cs (S t i) cid), Done)"
           using RecvMarker S_step by simp
         then show ?thesis 
           by (metis S_step.prems(1) prod.collapse)
       qed auto
     next
       case no_snap: False
       then show ?thesis
       proof (cases "cid = cid'")
         case True
         then have "cs (S t (Suc i)) cid = (fst (cs (S t i) cid), Done)"
           using RecvMarker S_step by simp
         then show ?thesis 
           by (metis S_step.prems(1) prod.collapse)
       next
         case False
         then have "r \<noteq> p" using no_snap snap_p by auto
         moreover have "\<nexists>s. channel cid = Some (s, r)" 
           using S_step(5) assms(1) cs_done_implies_has_snapshotted no_snap by blast
         ultimately show ?thesis using RecvMarker S_step False no_snap by simp
       qed
     qed
   next
     case (Recv cid' r s u u' m)
     with S_step show ?thesis by (cases "cid = cid'", auto)
   qed auto
   with S_step show ?case by auto
 qed
 
 lemma snapshotted_and_not_done_implies_marker_in_channel:
   assumes
     "trace init t final" and
     "has_snapshotted (S t i) p" and
     "snd (cs (S t i) cid) \<noteq> Done" and
     "i \<le> length t" and
     "channel cid = Some (p, q)"
   shows
     "Marker : set (msgs (S t i) cid)"
 proof -
   obtain j where jj: "j < i" "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" 
     by (metis Suc_eq_plus1 assms(1) assms(2) exists_snapshot_for_all_p computation.snapshot_stable_ver_2 computation_axioms le_eq_less_or_eq nat_neq_iff)
   have step: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
     by (metis \<open>\<not> ps (S t j) p \<noteq> None\<close> \<open>j < i\<close> add.commute assms(1) assms(2) linorder_neqE_nat no_change_if_ge_length_t order_le_less order_refl plus_1_eq_Suc step_Suc)
   then have "Marker : set (msgs (S t (j+1)) cid)"
   proof -
     have "~ regular_event (t ! j)" 
       by (meson \<open>\<not> ps (S t j) p \<noteq> None\<close> \<open>ps (S t (j + 1)) p \<noteq> None\<close> distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms local.step)
     then have "isSnapshot (t ! j) \<or> isRecvMarker (t ! j)" using nonregular_event by blast
     then show ?thesis
     proof (elim disjE, goal_cases)
       case 1
       then obtain r where Snapshot: "t ! j = Snapshot r" by (meson isSnapshot_def)
       then have "r = p" 
         using jj(2) jj(3) local.step by auto
       then show ?thesis using Snapshot assms step by simp
     next
       case 2
       then obtain cid' s where RecvMarker: "t ! j = RecvMarker cid' p s" 
         by (metis jj(2,3) distributed_system.no_state_change_if_no_event distributed_system_axioms event.sel(5) isRecvMarker_def local.step)
       moreover have "cid \<noteq> cid'"
       proof (rule ccontr)
         assume "~ cid \<noteq> cid'"
         then have "snd (cs (S t (j+1)) cid) = Done" using RecvMarker step by simp
         then have "snd (cs (S t i) cid) = Done" 
         proof -
           assume a1: "snd (cs (S t (j + 1)) cid) = Done"
           have f2: "ps (S t j) p = None"
             using jj(2) by blast
           have "j < length t"
             using assms(4) jj(1) by linarith
           then have "t ! j = RecvMarker cid q p"
             using f2 a1 assms(1) assms(5) cs_done_implies_both_snapshotted(1) done_only_from_recv_marker local.step by blast
           then show ?thesis
             using f2 by (metis (no_types) Suc_eq_plus1 assms(1) local.step recv_marker_means_snapshotted)
         qed
         then show False using assms by simp
       qed
       ultimately show ?thesis using jj assms step by auto
     qed
   qed
   show ?thesis
   proof (rule ccontr)
     let ?t = "take (i - (j+1)) (drop (j+1) t)"
     have tr_j: "trace (S t (j+1)) ?t (S t i)" 
       by (metis \<open>j < i\<close> assms(1) discrete exists_trace_for_any_i_j)
     assume "~ Marker : set (msgs (S t i) cid)"
     then obtain ev where "ev \<in> set ?t" "\<exists>p q. ev = RecvMarker cid p q" 
       using \<open>Marker \<in> set (msgs (S t (j + 1)) cid)\<close> marker_must_be_delivered_2_trace tr_j assms by blast
     obtain k where "t ! k = ev" "j < k" "k < i"
       using \<open>ev \<in> set (take (i - (j + 1)) (drop (j + 1) t))\<close> assms(1) exists_index by fastforce
     have step_k: "(S t k) \<turnstile> (t ! k) \<mapsto> (S t (k+1))"
     proof -
       have "k < length t" 
         using \<open>k < i\<close> assms(4) by auto
       then show ?thesis using step_Suc assms by simp
     qed
     have "ev = RecvMarker cid q p" using assms step_k can_occur_def 
       using \<open>\<exists>p q. ev = RecvMarker cid p q\<close> \<open>t ! k = ev\<close> by auto
     then have "snd (cs (S t (k+1)) cid) = Done" 
       using \<open>k < i\<close> \<open>t ! k = ev\<close> assms(1) assms(4) recv_marker_means_cs_Done by auto
     moreover have "trace (S t (k+1)) (take (i - (k+1)) (drop (k+1) t)) (S t i)" 
       by (meson \<open>k < i\<close> assms(1) discrete exists_trace_for_any_i_j)
     ultimately have "snd (cs (S t i) cid) = Done" 
       by (metis \<open>k < i\<close> assms(1) assms(4) assms(5) cs_done_implies_same_snapshots discrete)
     then show False using assms by simp
   qed
 qed
 
 lemma no_marker_left_in_final_state:
   assumes
     "trace init t final"
   shows
     "Marker \<notin> set (msgs final cid)" (is ?P)
 proof (rule ccontr)
   assume "~ ?P"
   then obtain i where "i > length t" "Marker \<notin> set (msgs (S t i) cid)" using assms l1 
     by (metis final_is_s_t_len_t le_neq_implies_less)
   then have "S t (length t) \<noteq> S t i"
   proof -
     have "msgs (S t i) cid \<noteq> msgs final cid"
       using \<open>Marker \<notin> set (msgs (S t i) cid)\<close> \<open>~ ?P\<close> by auto
     then show ?thesis using final_is_s_t_len_t assms by auto
   qed
   moreover have "S t (length t) = S t i"
     using assms \<open>i > length t\<close> less_imp_le no_change_if_ge_length_t by simp
   ultimately show False by simp
 qed
 
 lemma all_channels_done_in_final_state:
   assumes
     "trace init t final" and
     "channel cid = Some (p, q)"
   shows
     "snd (cs final cid) = Done"
 proof (rule ccontr)
   assume cs_not_done: "~ snd (cs final cid) = Done"
   obtain i where snap_p: "~ has_snapshotted (S t i) p" "has_snapshotted (S t (i+1)) p"
     by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p)
   have "i < length t"
   proof -
     have "S t i \<noteq> S t (i+1)" using snap_p by auto
     then show ?thesis 
       by (meson assms(1) computation.no_change_if_ge_length_t computation_axioms le_add1 not_less)
   qed
   let ?t = "take (length t - (i+1)) (drop (i+1) t)"
   have tr: "trace (S t (i+1)) ?t (S t (length t))" 
     by (meson \<open>i < length t\<close> assms(1) discrete exists_trace_for_any_i_j)
   have "Marker \<in> set (msgs (S t (i+1)) cid)"
   proof -
     have n_done: "snd (cs (S t (i+1)) cid) \<noteq> Done"
     proof (rule ccontr)
       assume "~ snd (cs (S t (i+1)) cid) \<noteq> Done"
       then have "snd (cs final cid) = Done" 
         by (metis Suc_eq_plus1 Suc_leI \<open>i < length t\<close> assms final_is_s_t_len_t computation.cs_done_implies_same_snapshots computation_axioms order_refl)
       then show False using cs_not_done by simp
     qed
     then show ?thesis using snapshotted_and_not_done_implies_marker_in_channel snap_p assms
     proof -
       have "i+1 \<le> length t" using \<open>i < length t\<close> by auto
       then show ?thesis
         using snapshotted_and_not_done_implies_marker_in_channel snap_p assms n_done by simp
     qed
   qed
   moreover have "Marker \<notin> set (msgs (S t (length t)) cid)" using final_is_s_t_len_t no_marker_left_in_final_state assms by blast
   ultimately have rm_prov: "\<exists>ev \<in> set ?t. (\<exists>q p. ev = RecvMarker cid q p)" using tr message_must_be_delivered_2_trace assms 
     by (simp add: marker_must_be_delivered_2_trace)
   then obtain k where "\<exists>q p. t ! k = RecvMarker cid q p" "i+1 \<le> k" "k < length t" 
     by (metis assms(1) exists_index)
   then have step: "(S t k) \<turnstile> (t ! k) \<mapsto> (S t (k+1))" 
     by (metis Suc_eq_plus1_left add.commute assms(1) step_Suc)
   then have RecvMarker: "t ! k = RecvMarker cid q p" 
     by (metis RecvMarker_given_channel \<open>\<exists>q p. t ! k = RecvMarker cid q p\<close> assms(2) event.disc(25) event.sel(10) happen_implies_can_occur)
   then have "snd (cs (S t (k+1)) cid) = Done" 
     using step \<open>k < length t\<close> assms(1) recv_marker_means_cs_Done by blast
   then have "snd (cs final cid) = Done" 
     using \<open>Marker \<notin> set (msgs (S t (length t)) cid)\<close> all_processes_snapshotted_in_final_state assms(1) assms(2) final_is_s_t_len_t snapshotted_and_not_done_implies_marker_in_channel by fastforce
   then show False using cs_not_done by simp
 qed
 
 lemma cs_NotStarted_implies_empty_cs:
   shows
     "\<lbrakk> trace init t final; channel cid = Some (p, q); i < length t; ~ has_snapshotted (S t i) q \<rbrakk>
      \<Longrightarrow> cs (S t i) cid = ([], NotStarted)"
   by (simp add: no_initial_channel_snapshot no_recording_cs_if_not_snapshotted)
 
 lemma fst_changed_by_recv_recording_trace:
   assumes
     "i < j" and
     "j \<le> length t" and
     "trace init t final" and
     "fst (cs (S t i) cid) \<noteq> fst (cs (S t j) cid)" and
     "channel cid = Some (p, q)"
   shows
     "\<exists>k. i \<le> k \<and> k < j \<and> (\<exists>p q u u' m. t ! k = Recv cid q p u u' m) \<and> (snd (cs (S t k) cid) = Recording)" (is ?P)
 proof (rule ccontr)
   assume "~ ?P"
   have "\<lbrakk> i < j; j \<le> length t; ~ ?P; trace init t final; channel cid = Some (p, q) \<rbrakk> \<Longrightarrow> fst (cs (S t i) cid) = fst (cs (S t j) cid)"
   proof (induct "j - i" arbitrary: i)
     case 0
     then show ?case by linarith
   next
     case (Suc n)
     then have step: "(S t i) \<turnstile> t ! i \<mapsto> (S t (Suc i))" 
       using step_Suc by auto
     then have "fst (cs (S t (Suc i)) cid) = fst (cs (S t i) cid)" 
       by (metis Suc.prems(1) Suc.prems(3) assms(5) fst_cs_changed_by_recv_recording le_eq_less_or_eq)
     also have "fst (cs (S t (Suc i)) cid) = fst (cs (S t j) cid)"
     proof -
       have "j - Suc i = n" using Suc by simp
       moreover have "~ (\<exists>k. (Suc i) \<le> k \<and> k < j \<and> (\<exists>p q u u' m. t ! k = Recv cid q p u u' m) \<and> (snd (cs (S t k) cid) = Recording))"
         using \<open>~ ?P\<close> Suc.prems(3) Suc_leD by blast
       ultimately show ?thesis using Suc by (metis Suc_lessI)
     qed
     finally show ?case by simp
   qed
   then show False using assms \<open>~ ?P\<close> by blast
 qed
 
 lemma cs_not_nil_implies_postrecording_event:
   assumes
     "trace init t final" and
     "fst (cs (S t i) cid) \<noteq> []" and
     "i \<le> length t" and
     "channel cid = Some (p, q)"
   shows
     "\<exists>j. j < i \<and> postrecording_event t j"
 proof -
   have "fst (cs init cid) = []" using no_initial_channel_snapshot by auto
   then have diff_cs: "fst (cs (S t 0) cid) \<noteq> fst (cs (S t i) cid)" 
     using assms(1) assms(2) init_is_s_t_0 by auto
   moreover have "0 < i"
   proof (rule ccontr)
     assume "~ 0 < i"
     then have "0 = i" by auto
     then have "fst (cs (S t 0) cid) = fst (cs (S t i) cid)" 
       by blast
     then show False using diff_cs by simp
   qed
   ultimately obtain j where "j < i" and Recv: "\<exists>p q u u' m. t ! j = Recv cid q p u u' m" "snd (cs (S t j) cid) = Recording"
     using assms(1) assms(3) assms(4) fst_changed_by_recv_recording_trace by blast
   then have "has_snapshotted (S t j) q" 
     using assms(1) assms(4) cs_recording_implies_snapshot by blast
   moreover have "regular_event (t ! j)" using Recv by auto
   moreover have "occurs_on (t ! j) = q"
   proof -
     have "can_occur (t ! j) (S t j)" 
       by (meson Suc_le_eq \<open>j < i\<close> assms(1) assms(3) happen_implies_can_occur le_trans step_Suc)
     then show ?thesis using Recv Recv_given_channel assms(4) by force
   qed
   ultimately have "postrecording_event t j" unfolding postrecording_event using \<open>j < i\<close> assms(3) by simp
   then show ?thesis using \<open>j < i\<close> by auto
 qed
 
 subsubsection \<open>Relating process states\<close>
 
 lemma snapshot_state_must_have_been_reached:
   assumes
     "trace init t final" and
     "ps final p = Some u" and
     "~ has_snapshotted (S t i) p" and
     "has_snapshotted (S t (i+1)) p" and
     "i < length t"
   shows
     "states (S t i) p = u"
 proof (rule ccontr)
   assume "states (S t i) p \<noteq> u"
   then have "ps (S t (i+1)) p \<noteq> Some u" 
     using assms(1) assms(3) snapshot_state by force
   then have "ps final p \<noteq> Some u"
     by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right assms(1) assms(3) assms(4) assms(5) final_is_s_t_len_t order_refl snapshot_state snapshot_state_unchanged_trace_2)
   then show False using assms by simp
 qed
 
 lemma ps_after_all_prerecording_events:
   assumes
     "trace init t final" and
     "\<forall>i'. i' \<ge> i \<longrightarrow> ~ prerecording_event t i'" and
     "\<forall>j'. j' < i \<longrightarrow> ~ postrecording_event t j'"
   shows
     "ps_equal_to_snapshot (S t i) final"
 proof (unfold ps_equal_to_snapshot_def, rule allI)
   fix p
   show "Some (states (S t i) p) = ps final p"
   proof (rule ccontr)
     obtain s where "ps final p = Some s \<or> ps final p = None" by auto
     moreover assume "Some (states (S t i) p) \<noteq> ps final p"
     ultimately have "ps final p = None \<or> states (S t i) p \<noteq> s" by auto
     then show False
     proof (elim disjE)
       assume "ps final p = None"
       then show False 
         using assms all_processes_snapshotted_in_final_state by blast
     next
       assume st: "states (S t i) p \<noteq> s"
       then obtain j where "~ has_snapshotted (S t j) p \<and> has_snapshotted (S t (j+1)) p" 
         using Suc_eq_plus1 assms(1) exists_snapshot_for_all_p by presburger
       then show False
       proof (cases "has_snapshotted (S t i) p")
         case False
         then have "j \<ge> i"
           by (metis Suc_eq_plus1 \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (j + 1)) p \<noteq> None\<close> assms(1) not_less_eq_eq snapshot_stable_ver_3)
 
         let ?t = "take (j-i) (drop i t)"
         have "\<exists>ev. ev \<in> set ?t \<and> regular_event ev \<and> occurs_on ev = p"
         proof (rule ccontr)
           assume "~ (\<exists>ev. ev \<in> set ?t \<and> regular_event ev \<and> occurs_on ev = p)"
           moreover have "trace (S t i) ?t (S t j)" 
             using \<open>i \<le> j\<close> assms(1) exists_trace_for_any_i_j by blast
           ultimately have "states (S t j) p = states (S t i) p"
             using no_state_change_if_only_nonregular_events st by blast
           then show False 
             by (metis \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (j + 1)) p \<noteq> None\<close> \<open>ps final p = Some s \<or> ps final p = None\<close> assms(1) final_is_s_t_len_t computation.all_processes_snapshotted_in_final_state computation.snapshot_stable_ver_3 computation_axioms linorder_not_le snapshot_state_must_have_been_reached st)
         qed
 
         then obtain ev where "ev \<in> set ?t \<and> regular_event ev \<and> occurs_on ev = p"
           by blast
         then obtain k where t_ind: "0 \<le> k \<and> k < length ?t \<and> ev = ?t ! k"
           by (metis in_set_conv_nth not_le not_less_zero)
         moreover have "length ?t \<le> j - i" by simp
         ultimately have "?t ! k = (drop i t) ! k" 
           using less_le_trans nth_take by blast
         also have "... = t ! (k+i)" 
           by (metis \<open>ev \<in> set (take (j - i) (drop i t)) \<and> regular_event ev \<and> occurs_on ev = p\<close> add.commute drop_eq_Nil length_greater_0_conv length_pos_if_in_set nat_le_linear nth_drop take_eq_Nil)
         finally have "?t ! k = t ! (k+i)" by simp
         have "prerecording_event t (k+i)"
         proof -
           have "regular_event (?t ! k)" 
             using \<open>ev \<in> set (take (j - i) (drop i t)) \<and> regular_event ev \<and> occurs_on ev = p\<close> t_ind by blast
           moreover have "occurs_on (?t ! k) = p" 
             using \<open>ev \<in> set (take (j - i) (drop i t)) \<and> regular_event ev \<and> occurs_on ev = p\<close> t_ind by blast
           moreover have "~ has_snapshotted (S t (k+i)) p"
           proof -
             have "k+i \<le> j"
               using \<open>length (take (j - i) (drop i t)) \<le> j - i\<close> t_ind by linarith
             show ?thesis 
               using \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (j + 1)) p \<noteq> None\<close> \<open>k+i \<le> j\<close> assms(1) snapshot_stable_ver_3 by blast
           qed
           ultimately show ?thesis 
             using \<open>take (j - i) (drop i t) ! k = t ! (k + i)\<close> prerecording_event t_ind by auto
         qed
 
         then show False using assms by auto
       next
         case True
 
         have "j < i"
         proof (rule ccontr)
           assume "~ j < i"
           then have "j \<ge> i" by simp
           moreover have "~ has_snapshotted (S t j) p" 
             using \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (j + 1)) p \<noteq> None\<close> by blast
           moreover have "trace (S t i) (take (j - i) (drop i t)) (S t j)" 
             using assms(1) calculation(1) exists_trace_for_any_i_j by blast
           ultimately have "~ has_snapshotted (S t i) p" 
             using snapshot_stable by blast
           then show False using True by simp
         qed
 
         let ?t = "take (i-j) (drop j t)"
         have "\<exists>ev. ev \<in> set ?t \<and> regular_event ev \<and> occurs_on ev = p"
         proof (rule ccontr)
           assume "~ (\<exists>ev. ev \<in> set ?t \<and> regular_event ev \<and> occurs_on ev = p)"
           moreover have "trace (S t j) ?t (S t i)" 
             using \<open>j < i\<close> assms(1) exists_trace_for_any_i_j less_imp_le by blast
           ultimately have "states (S t j) p = states (S t i) p" 
             using no_state_change_if_only_nonregular_events by auto
           moreover have "states (S t j) p = s" 
             by (metis \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (j + 1)) p \<noteq> None\<close> \<open>ps final p = Some s \<or> ps final p = None\<close> assms(1) final_is_s_t_len_t computation.all_processes_snapshotted_in_final_state computation.snapshot_stable_ver_3 computation_axioms linorder_not_le snapshot_state_must_have_been_reached)
           ultimately show False using \<open>states (S t i) p \<noteq> s\<close> by simp
         qed
 
         then obtain ev where ev: "ev \<in> set ?t \<and> regular_event ev \<and> occurs_on ev = p" by blast
         then obtain k where t_ind: "0 \<le> k \<and> k < length ?t \<and> ev = ?t ! k" 
           by (metis in_set_conv_nth le0)
         have "length ?t \<le> i - j" by simp
         have "?t ! k = (drop j t) ! k" 
           using t_ind by auto
         also have "... = t ! (k + j)" 
           by (metis \<open>ev \<in> set (take (i - j) (drop j t)) \<and> regular_event ev \<and> occurs_on ev = p\<close> add.commute drop_eq_Nil length_greater_0_conv length_pos_if_in_set nat_le_linear nth_drop take_eq_Nil)
         finally have "?t ! k = t ! (k+j)" by simp
         have "postrecording_event t (k+j)"
         proof -
           have "trace (S t j) (take k (drop j t)) (S t (k+j))" 
             by (metis add_diff_cancel_right' assms(1) exists_trace_for_any_i_j le_add_same_cancel2 t_ind)
           then have "has_snapshotted (S t (k+j)) p"
             by (metis Suc_eq_plus1 Suc_leI \<open>\<not> ps (S t j) p \<noteq> None \<and> ps (S t (j + 1)) p \<noteq> None\<close> \<open>take (i - j) (drop j t) ! k = t ! (k + j)\<close> assms(1) drop_eq_Nil ev computation.snapshot_stable_ver_3 computation_axioms le_add_same_cancel2 length_greater_0_conv length_pos_if_in_set linorder_not_le order_le_less regular_event_preserves_process_snapshots step_Suc t_ind take_eq_Nil)
           then show ?thesis 
             using \<open>take (i - j) (drop j t) ! k = t ! (k + j)\<close> ev postrecording_event t_ind by auto
         qed
         moreover have "k + j < i" 
           using \<open>length (take (i - j) (drop j t)) \<le> i - j\<close> t_ind by linarith
         ultimately show False using assms(3) by simp
       qed
     qed
   qed
 qed
 
 subsubsection \<open>Relating channel states\<close>
 
 lemma cs_when_recording:
   shows
     "\<lbrakk> i < j; j \<le> length t; trace init t final;
        has_snapshotted (S t i) p;
        snd (cs (S t i) cid) = Recording;
        snd (cs (S t j) cid) = Done;
        channel cid = Some (p, q) \<rbrakk>
      \<Longrightarrow> map Msg (fst (cs (S t j) cid))
          = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)"
 proof (induct "j - (i+1)" arbitrary: i)
   case 0
   then have "j = i+1" by simp
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t j)" using "0.prems" step_Suc by simp
   then have rm: "\<exists>q p. t ! i = RecvMarker cid q p" using done_only_from_recv_marker "0.prems" by force
   then have RecvMarker: "t ! i = RecvMarker cid q p"
     by (metis "0.prems"(7) RecvMarker_given_channel event.collapse(5) event.disc(25) event.inject(5) happen_implies_can_occur local.step)
   then have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = []"
   proof -
     have "can_occur (t ! i) (S t i)" using happen_implies_can_occur step by simp
     then show ?thesis
     proof -
       have "\<And>p ms. takeWhile p ms = [] \<or> p (hd ms::'c message)"
         by (metis (no_types) hd_append2 hd_in_set set_takeWhileD takeWhile_dropWhile_id)
       then show ?thesis
         using \<open>can_occur (t ! i) (S t i)\<close> can_occur_def rm by fastforce
     qed
   qed
   then show ?case 
     using local.step rm by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis Suc_eq_plus1 less_SucI nat_induct_at_least step_Suc)
   have ib: "i+1 < j \<and> j \<le> length t \<and> has_snapshotted (S t (i+1)) p \<and> snd (cs (S t j) cid) = Done"
     using Suc.hyps(2) Suc.prems(2) Suc.prems(4) Suc.prems(6) local.step snapshot_state_unchanged by auto
   have snap_q: "has_snapshotted (S t i) q" 
     using Suc(7) Suc.prems(3) Suc cs_recording_implies_snapshot by blast
   then show ?case
   proof (cases "t ! i")
     case (Snapshot r)
     then have "r \<noteq> p" 
       using Suc.prems(4) can_occur_def local.step by auto
     then have "msgs (S t (i+1)) cid = msgs (S t i) cid" 
       using Snapshot local.step Suc.prems(7) by auto
     moreover have "cs (S t (i+1)) cid = cs (S t i) cid"
     proof -
       have "r \<noteq> q" using Snapshot can_occur_def snap_q step by auto
       then show ?thesis using Snapshot local.step Suc.prems(7) by auto
     qed
     ultimately show ?thesis using Suc ib by force
   next
     case (RecvMarker cid' r s)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = []"
       proof -
         have "can_occur (t ! i) (S t i)" using happen_implies_can_occur step by simp
         then show ?thesis
         proof -
           have "\<And>p ms. takeWhile p ms = [] \<or> p (hd ms::'c message)"
             by (metis (no_types) hd_append2 hd_in_set set_takeWhileD takeWhile_dropWhile_id)
           then show ?thesis
             using RecvMarker True \<open>can_occur (t ! i) (S t i)\<close> can_occur_def by fastforce
         qed
       qed
       moreover have "snd (cs (S t (i+1)) cid) = Done" 
         using RecvMarker Suc.prems(1) Suc.prems(2) Suc.prems(3) True recv_marker_means_cs_Done by auto
       moreover have "fst (cs (S t i) cid) = fst (cs (S t (i+1)) cid)" 
         using RecvMarker True local.step by auto
       ultimately show ?thesis 
         by (metis Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(7) Suc_eq_plus1 Suc_leI append_Nil2 cs_done_implies_same_snapshots)
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid"
       proof (cases "has_snapshotted (S t i) r")
         case True
         then show ?thesis using RecvMarker step Suc False by auto
       next
         case False
         with RecvMarker step Suc \<open>cid \<noteq> cid'\<close> show ?thesis by (cases "s = p", auto)
       qed
       moreover have "cs (S t i) cid = cs (S t (i+1)) cid"
       proof (cases "has_snapshotted (S t i) r")
         case True
         then show ?thesis using RecvMarker step Suc False by auto
       next
         case no_snap: False
         then show ?thesis
         proof (cases "r = q")
           case True
           then show ?thesis using snap_q no_snap \<open>r = q\<close> by simp
         next
           case False
           then show ?thesis using RecvMarker step Suc no_snap False \<open>cid \<noteq> cid'\<close> by simp
         qed
       qed
       ultimately show ?thesis using Suc ib by simp
     qed
   next
     case (Trans r u u')
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step by auto
     moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Trans by auto
     ultimately show ?thesis using Suc ib by simp
   next
     case (Send cid' r s u u' m)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       have marker_in_msgs: "Marker \<in> set (msgs (S t i) cid)"
       proof -
         have "has_snapshotted (S t i) p" using Suc by simp
         moreover have "i < length t" 
           using Suc.prems(1) Suc.prems(2) less_le_trans by blast
         moreover have "snd (cs (S t i) cid) \<noteq> Done" using Suc by simp
         ultimately show ?thesis using snapshotted_and_not_done_implies_marker_in_channel less_imp_le using Suc by blast
       qed
       then have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)"
       proof -
         have "butlast (msgs (S t (i+1)) cid) = msgs (S t i) cid" using step True Send by auto
         then show ?thesis
         proof -
           have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid @ [last (msgs (S t (i + 1)) cid)]) = takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)"
             using marker_in_msgs by force
           then show ?thesis
             by (metis (no_types) \<open>butlast (msgs (S t (i + 1)) cid) = msgs (S t i) cid\<close> append_butlast_last_id in_set_butlastD length_greater_0_conv length_pos_if_in_set marker_in_msgs)
         qed
       qed
       moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Send by auto
       ultimately show ?thesis using ib Suc by simp
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Send by auto
       moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Send by auto
       ultimately show ?thesis using Suc ib by simp
     qed
   next
     case (Recv cid' r s u u' m)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have msgs_ip1: "Msg m # msgs (S t (i+1)) cid = msgs (S t i) cid"
         using Suc Recv step by auto
       moreover have cs_ip1: "cs (S t (i+1)) cid = (fst (cs (S t i) cid) @ [m], Recording)"
         using True Suc Recv step by auto
       ultimately show ?thesis
       proof -
         have "map Msg (fst (cs (S t j) cid))
             = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)"
           using Suc ib cs_ip1 by force
         moreover have "map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)
                      = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)"
         proof -
           have "takeWhile ((\<noteq>) Marker) (Msg m # msgs (S t (i+1)) cid) = Msg m # takeWhile ((\<noteq>) Marker) (msgs (S t (i + 1)) cid)"
             by auto
           then have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = Msg m # takeWhile ((\<noteq>) Marker) (msgs (S t (i + 1)) cid)"
             by (metis msgs_ip1)
           then show ?thesis
             using cs_ip1 by auto
         qed
         ultimately show ?thesis by simp
       qed
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Recv by auto
       moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Recv False by auto
       ultimately show ?thesis using Suc ib by simp
     qed
   qed
 qed
 
 lemma cs_when_recording_2:
   shows
     "\<lbrakk> i \<le> j; trace init t final;
        ~ has_snapshotted (S t i) p;
        \<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = p;
        snd (cs (S t i) cid) = Recording;
        channel cid = Some (p, q) \<rbrakk>
      \<Longrightarrow> map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
          = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)
          \<and> snd (cs (S t j) cid) = Recording"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis Suc_eq_plus1 all_processes_snapshotted_in_final_state distributed_system.step_Suc distributed_system_axioms computation.final_is_s_t_len_t computation_axioms linorder_not_le snapshot_stable_ver_3)
   have ib: "i+1 \<le> j \<and> ~ has_snapshotted (S t (i+1)) p
          \<and> (\<forall>k. (i+1) \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = p) \<and> j - (i+1) = n" 
     by (metis Suc.hyps(2) Suc.prems(1) Suc.prems(3) Suc.prems(4) diff_Suc_1 diff_diff_left Suc_eq_plus1 Suc_leD Suc_le_eq Suc_neq_Zero cancel_comm_monoid_add_class.diff_cancel le_neq_implies_less le_refl local.step no_state_change_if_no_event)
   have snap_q: "has_snapshotted (S t i) q" 
     using Suc.prems(5,6) Suc.prems(2) cs_recording_implies_snapshot by blast
   then show ?case
   proof (cases "t ! i")
     case (Snapshot r)
     then have "r \<noteq> p" using Suc by auto
     then have "msgs (S t (i+1)) cid = msgs (S t i) cid" 
       using Snapshot local.step Suc.prems(6) by auto
     moreover have "cs (S t (i+1)) cid = cs (S t i) cid"
     proof -
       have "r \<noteq> q" using step can_occur_def Snapshot snap_q by auto
       then show ?thesis using Snapshot step Suc by simp
     qed
     ultimately show ?thesis using Suc ib by auto
   next
     case (RecvMarker cid' r s)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "Marker \<in> set (msgs (S t i) cid)" 
         using RecvMarker RecvMarker_implies_Marker_in_set local.step by blast
       then have "has_snapshotted (S t i) p" 
         using Suc.prems(2) no_marker_if_no_snapshot Suc by blast
       then show ?thesis using Suc.prems by simp
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid"
       proof (cases "has_snapshotted (S t i) r")
         case True
         then show ?thesis using RecvMarker step Suc False by auto
       next
         case False
         with RecvMarker step Suc \<open>cid \<noteq> cid'\<close> show ?thesis by (cases "s = p", auto)
       qed
       moreover have "cs (S t i) cid = cs (S t (i+1)) cid"
       proof (cases "has_snapshotted (S t i) r")
         case True
         then show ?thesis using RecvMarker step Suc False by auto
       next
         case no_snap: False
         then show ?thesis
         proof (cases "r = q")
           case True
           then show ?thesis using snap_q no_snap \<open>r = q\<close> by simp
         next
           case False
           then show ?thesis using RecvMarker step Suc no_snap False \<open>cid \<noteq> cid'\<close> by simp
         qed
       qed
       ultimately show ?thesis using Suc ib by auto
     qed
   next
     case (Trans r u u')
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step by auto
     moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Trans by auto
     ultimately show ?thesis using Suc ib by auto
   next
     case (Send cid' r s u u' m)
     then have "r \<noteq> p" 
       using Suc.hyps(2) Suc.prems(4) Suc by auto
     have "cid \<noteq> cid'"
     proof (rule ccontr)
       assume "~ cid \<noteq> cid'"
       then have "channel cid = channel cid'" by auto
       then have "(p, q) = (r, s)" using can_occur_def step Send Suc by auto
       then show False using \<open>r \<noteq> p\<close> by simp
     qed
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Send by simp
     moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Send by auto
     ultimately show ?thesis using Suc ib by auto
   next
     case (Recv cid' r s u u' m)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have msgs_ip1: "Msg m # msgs (S t (i+1)) cid = msgs (S t i) cid"
         using Suc Recv step by auto
       moreover have cs_ip1: "cs (S t (i+1)) cid = (fst (cs (S t i) cid) @ [m], Recording)"
         using True Suc Recv step by auto
       ultimately show ?thesis
       proof -
         have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
             = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)
             \<and> snd (cs (S t j) cid) = Recording"
           using Suc ib cs_ip1 by auto
         moreover have "map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)
                      = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)"
         proof -
           have "takeWhile ((\<noteq>) Marker) (Msg m # msgs (S t (i + 1)) cid) = Msg m # takeWhile ((\<noteq>) Marker) (msgs (S t (i + 1)) cid)"
             by fastforce
           then have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = Msg m # takeWhile ((\<noteq>) Marker) (msgs (S t (i + 1)) cid)"
             by (metis msgs_ip1)
           then show ?thesis
             using cs_ip1 by force
         qed
         ultimately show ?thesis using cs_ip1 by simp
       qed
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Recv by auto
       moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Recv False by auto
       ultimately show ?thesis using Suc ib by auto
     qed
   qed
 qed
 
 lemma cs_when_recording_3:
   shows
     "\<lbrakk> i \<le> j; trace init t final;
        ~ has_snapshotted (S t i) q;
        \<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = q;
        snd (cs (S t i) cid) = NotStarted;
        has_snapshotted (S t i) p;
        Marker : set (msgs (S t i) cid);
        channel cid = Some (p, q) \<rbrakk>
      \<Longrightarrow> map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
          = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)
          \<and> snd (cs (S t j) cid) = NotStarted"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis Suc_eq_plus1 all_processes_snapshotted_in_final_state distributed_system.step_Suc distributed_system_axioms computation.final_is_s_t_len_t computation_axioms linorder_not_le snapshot_stable_ver_3)
   have ib: "i+1 \<le> j \<and> ~ has_snapshotted (S t (i+1)) q \<and> has_snapshotted (S t (i+1)) p
          \<and> (\<forall>k. (i+1) \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = q) \<and> j - (i+1) = n
          \<and> Marker : set (msgs (S t (i+1)) cid) \<and> cs (S t i) cid = cs (S t (i+1)) cid" 
   proof -
     have "i+1 \<le> j \<and> ~ has_snapshotted (S t (i+1)) q
          \<and> (\<forall>k. (i+1) \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = q) \<and> j - (i+1) = n" 
       by (metis Suc.hyps(2) Suc.prems(1) Suc.prems(3) Suc.prems(4) diff_Suc_1 diff_diff_left Suc_eq_plus1 Suc_leD Suc_le_eq Suc_neq_Zero cancel_comm_monoid_add_class.diff_cancel le_neq_implies_less le_refl local.step no_state_change_if_no_event)
     moreover have "has_snapshotted (S t (i+1)) p" 
       using Suc.prems(6) local.step snapshot_state_unchanged by auto
     moreover have "Marker : set (msgs (S t (i+1)) cid)" 
       using Suc calculation(1) local.step recv_marker_means_snapshotted_2 by blast
     moreover have "cs (S t i) cid = cs (S t (i+1)) cid" 
       using Suc calculation(1) no_recording_cs_if_not_snapshotted by auto
     ultimately show ?thesis by simp
   qed
   then show ?case
   proof (cases "t ! i")
     case (Snapshot r)
     then have "r \<noteq> q" using Suc by auto
     then have "takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid) = takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)" 
     proof (cases "occurs_on (t ! i) = p")
       case True
       then show ?thesis
         by (metis (mono_tags, lifting) Snapshot Suc.prems(6) distributed_system.can_occur_def event.sel(4) event.simps(29) computation_axioms computation_def happen_implies_can_occur local.step)
     next
       case False
       then have "msgs (S t (i+1)) cid = msgs (S t i) cid" 
         using Snapshot local.step Suc by auto
       then show ?thesis by simp
     qed
     then show ?thesis using Suc ib by metis
   next
     case (RecvMarker cid' r s)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "snd (cs (S t i) cid) = Done"
         by (metis RecvMarker Suc.prems(2) Suc_eq_plus1 Suc_le_eq exactly_one_snapshot computation.no_change_if_ge_length_t computation.recv_marker_means_cs_Done computation.snapshot_stable_ver_2 computation_axioms ib nat_le_linear)
       then show ?thesis using Suc.prems by simp
     next
       case False
       then have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)"
       proof (cases "has_snapshotted (S t i) r")
         case True
         with RecvMarker False step show ?thesis by auto
       next
         case no_snap: False
         then have "r \<noteq> p" 
           using Suc.prems(6) by auto
         then show ?thesis using no_snap RecvMarker step Suc.prems False by auto
       qed
       then show ?thesis using Suc ib by metis
     qed
   next
     case (Trans r u u')
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step by auto
     then show ?thesis using Suc ib by auto
   next
     case (Send cid' r s u u' m)
     then have "r \<noteq> q" 
       using Suc.hyps(2) Suc.prems(4) by auto
     have marker: "Marker \<in> set (msgs (S t i) cid)" using Suc by simp
     with step Send marker have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = takeWhile ((\<noteq>) Marker) (msgs (S t (i+1)) cid)"
       by (cases "cid = cid'", auto)
     then show ?thesis using Suc ib by auto
   next
     case (Recv cid' r s u u' m)
     then have "cid' \<noteq> cid" 
       by (metis Suc.hyps(2) Suc.prems(4) Suc.prems(8) distributed_system.can_occur_Recv distributed_system_axioms event.sel(3) happen_implies_can_occur local.step option.inject order_refl prod.inject zero_less_Suc zero_less_diff)
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Recv Suc by simp
     then show ?thesis using Suc ib by auto
   qed
 qed
 
 lemma at_most_one_marker:
   shows
     "\<lbrakk> trace init t final; channel cid = Some (p, q) \<rbrakk>
      \<Longrightarrow> Marker \<notin> set (msgs (S t i) cid)
        \<or> (\<exists>!j. j < length (msgs (S t i) cid) \<and> msgs (S t i) cid ! j = Marker)"
 proof (induct i)
   case 0
   then show ?case using no_initial_Marker init_is_s_t_0 by auto
 next
   case (Suc i)
   then show ?case
   proof (cases "i < length t")
     case False
     then show ?thesis 
       by (metis Suc.prems(1) final_is_s_t_len_t computation.no_change_if_ge_length_t computation_axioms le_refl less_imp_le_nat no_marker_left_in_final_state not_less_eq)
   next
     case True
     then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (Suc i))" using step_Suc Suc.prems by blast
     moreover have "Marker \<notin> set (msgs (S t i) cid)
                 \<or> (\<exists>!j. j < length (msgs (S t i) cid) \<and> msgs (S t i) cid ! j = Marker)"
       using Suc.hyps Suc.prems(1) Suc.prems(2) by linarith
     moreover have "Marker \<notin> set (msgs (S t (Suc i)) cid)
                 \<or> (\<exists>!j. j < length (msgs (S t (Suc i)) cid) \<and> msgs (S t (Suc i)) cid ! j = Marker)"
     proof (cases "Marker \<notin> set (msgs (S t i) cid)")
       case no_marker: True
       then show ?thesis
       proof (cases "t ! i")
         case (Snapshot r)
         then show ?thesis
         proof (cases "r = p")
           case True
           then have new_msgs: "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Marker]"
             using step Snapshot Suc by auto
           then show ?thesis using util_exactly_one_element no_marker by fastforce
         next
           case False
           then show ?thesis 
             using Snapshot local.step no_marker Suc by auto
         qed
       next
         case (RecvMarker cid' r s)
         then show ?thesis
         proof (cases "cid = cid'")
           case True
           then show ?thesis 
             using RecvMarker RecvMarker_implies_Marker_in_set local.step no_marker by blast
         next
           case False
           then show ?thesis
           proof (cases "has_snapshotted (S t i) r")
             case True
             then show ?thesis using RecvMarker step Suc False by simp
           next
             case no_snap: False
             then show ?thesis
             proof (cases "r = p")
               case True
               then have "msgs (S t (i+1)) cid = msgs (S t i) cid @ [Marker]" using RecvMarker step Suc.prems no_snap \<open>cid \<noteq> cid'\<close> by simp
               then show ?thesis
               proof -
                 assume a1: "msgs (S t (i + 1)) cid = msgs (S t i) cid @ [Marker]"
                 { fix nn :: "nat \<Rightarrow> nat"
                   have "\<forall>ms m. \<exists>n. \<forall>na. ((m::'c message) \<in> set ms \<or> n < length (ms @ [m])) \<and> (m \<in> set ms \<or> (ms @ [m]) ! n = m) \<and> (\<not> na < length (ms @ [m]) \<or> (ms @ [m]) ! na \<noteq> m \<or> m \<in> set ms \<or> na = n)"
                     by (metis (no_types) util_exactly_one_element)
                   then have "\<exists>n. n < length (msgs (S t (Suc i)) cid) \<and> nn n = n \<and> msgs (S t (Suc i)) cid ! n = Marker \<or> n < length (msgs (S t (Suc i)) cid) \<and> msgs (S t (Suc i)) cid ! n = Marker \<and> \<not> nn n < length (msgs (S t (Suc i)) cid) \<or> n < length (msgs (S t (Suc i)) cid) \<and> msgs (S t (Suc i)) cid ! n = Marker \<and> msgs (S t (Suc i)) cid ! nn n \<noteq> Marker"
                     using a1 by (metis Suc_eq_plus1 no_marker) }
                 then show ?thesis
                   by (metis (no_types))
               qed
             next
               case False
               then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using RecvMarker step Suc.prems \<open>cid \<noteq> cid'\<close> no_snap by simp
               then show ?thesis using Suc by simp
             qed
           qed
         qed
       next
         case (Trans r u u')
         then show ?thesis using no_marker step by auto
       next
         case (Send cid' r s u u' m)
         then show ?thesis
         proof (cases "cid = cid'")
           case True
           then have "Marker \<notin> set (msgs (S t (Suc i)) cid)" using step no_marker Send by auto
           then show ?thesis by simp
         next
           case False
           then have "Marker \<notin> set (msgs (S t (Suc i)) cid)" using step no_marker Send by auto
           then show ?thesis by simp
         qed
       next
         case (Recv cid' r s u u' m)
         with step no_marker Recv show ?thesis by (cases "cid = cid'", auto)
       qed
     next
       case False
       then have asm: "\<exists>!j. j < length (msgs (S t i) cid) \<and> msgs (S t i) cid ! j = Marker"
         using Suc by simp
       have len_filter: "length (filter ((=) Marker) (msgs (S t i) cid)) = 1" 
         by (metis False \<open>Marker \<notin> set (msgs (S t i) cid) \<or> (\<exists>!j. j < length (msgs (S t i) cid) \<and> msgs (S t i) cid ! j = Marker)\<close> exists_one_iff_filter_one)
       have snap_p: "has_snapshotted (S t i) p" 
         using False Suc.prems no_marker_if_no_snapshot by blast
       show ?thesis
       proof (cases "t ! i")
         case (Snapshot r)
         have "r \<noteq> p"
         proof (rule ccontr)
           assume "~ r \<noteq> p"
           moreover have "can_occur (t ! i) (S t i)" using happen_implies_can_occur step by blast
           ultimately show False using snap_p can_occur_def Snapshot by auto
         qed
         then have "msgs (S t (Suc i)) cid = msgs (S t i) cid" using step Snapshot Suc by auto
         then show ?thesis using asm by simp
       next
         case (RecvMarker cid' r s)
         then show ?thesis
         proof (cases "cid = cid'")
           case True
           then have "Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid"
             using RecvMarker step by auto
           then have "Marker \<notin> set (msgs (S t (Suc i)) cid)"
           proof -
             have "\<forall>j. j \<noteq> 0 \<and> j < length (msgs (S t i) cid) \<longrightarrow> msgs (S t i) cid ! j \<noteq> Marker" 
               by (metis False \<open>Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid\<close> asm length_pos_if_in_set nth_Cons_0)
             then show ?thesis 
             proof -
               assume a1: "\<forall>j. j \<noteq> 0 \<and> j < length (msgs (S t i) cid) \<longrightarrow> msgs (S t i) cid ! j \<noteq> Marker"
               have "\<And>ms n. ms \<noteq> msgs (S t i) cid \<or> length (msgs (S t (Suc i)) cid) \<noteq> n \<or> length ms = Suc n"
                 by (metis \<open>Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid\<close> length_Suc_conv)
               then show ?thesis
                 using a1 by (metis (no_types) Suc_mono Zero_not_Suc \<open>Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid\<close> in_set_conv_nth nth_Cons_Suc)
             qed
           qed
           then show ?thesis by simp
         next
           case cid_neq_cid': False
           then show ?thesis
           proof (cases "has_snapshotted (S t i) r")
             case True
             then have "msgs (S t (Suc i)) cid = msgs (S t i) cid" 
               using cid_neq_cid' RecvMarker local.step snap_p by auto
             then show ?thesis using asm by simp
           next
             case False
             then have "r \<noteq> p" 
               using snap_p by blast
             then have "msgs (S t (Suc i)) cid = msgs (S t i) cid" using cid_neq_cid' RecvMarker step False Suc by auto
             then show ?thesis using asm by simp
           qed
         qed
       next
         case (Trans r u u')
         then show ?thesis using step asm by auto
       next
         case (Send cid' r s u u' m)
         then show ?thesis
         proof (cases "cid = cid'")
           case True
           then have new_messages: "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Msg m]"
             using step Send by auto
           then have "\<exists>!j. j < length (msgs (S t (Suc i)) cid) \<and> msgs (S t (Suc i)) cid ! j = Marker"
           proof -
             have "length (filter ((=) Marker) (msgs (S t (Suc i)) cid))
                 = length (filter ((=) Marker) (msgs (S t i) cid))
                 + length (filter ((=) Marker) [Msg m])" 
               by (simp add: new_messages)
             then have "length (filter ((=) Marker) (msgs (S t (Suc i)) cid)) = 1"
               using len_filter by simp
             then show ?thesis using exists_one_iff_filter_one by metis
           qed
           then show ?thesis by simp
         next
           case False
           then show ?thesis using step Send asm by auto
         qed
       next
         case (Recv cid' r s u u' m)
        then show ?thesis
         proof (cases "cid = cid'")
           case True
           then have new_msgs: "Msg m # msgs (S t (Suc i)) cid = msgs (S t i) cid" using step Recv by auto
           then show ?thesis
           proof -
             have "length (filter ((=) Marker) (msgs (S t i) cid))
                 = length (filter ((=) Marker) [Msg m])
                 + length (filter ((=) Marker) (msgs (S t (Suc i)) cid))" 
               by (metis append_Cons append_Nil filter_append len_filter length_append new_msgs)
             then have "length (filter ((=) Marker) (msgs (S t (Suc i)) cid)) = 1"
               using len_filter by simp
             then show ?thesis using exists_one_iff_filter_one by metis
           qed
         next
           case False
           then show ?thesis using step Recv asm by auto
         qed
       qed
     qed
     then show ?thesis by simp
   qed
 qed
 
 lemma last_changes_implies_send_when_msgs_nonempty:
   assumes
     "trace init t final" and
     "msgs (S t i) cid \<noteq> []" and
     "msgs (S t (i+1)) cid \<noteq> []" and
     "last (msgs (S t i) cid) = Marker" and
     "last (msgs (S t (i+1)) cid) \<noteq> Marker" and
     "channel cid = Some (p, q)"
   shows
     "(\<exists>u u' m. t ! i = Send cid p q u u' m)"
 proof -
   have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis Suc_eq_plus1_left add.commute assms(1) assms(4) assms(5) le_Suc_eq nat_le_linear nat_less_le no_change_if_ge_length_t step_Suc)
   then show ?thesis
   proof (cases "t ! i")
     case (Snapshot r)
     then show ?thesis 
       by (metis assms(4) assms(5) last_snoc local.step next_snapshot)
   next
     case (RecvMarker cid' r s)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "last (msgs (S t i) cid) = last (msgs (S t (i+1)) cid)" 
       proof -
         have "Marker # msgs (S t (i + 1)) cid = msgs (S t i) cid"
           using RecvMarker local.step True by auto
         then show ?thesis
           by (metis assms(3) last_ConsR)
       qed
       then show ?thesis using assms by simp
     next
       case no_snap: False
       then have "last (msgs (S t i) cid) = last (msgs (S t (i+1)) cid)"
       proof (cases "has_snapshotted (S t i) r")
         case True
         then show ?thesis using RecvMarker step no_snap by simp
       next
         case False
         with RecvMarker step no_snap \<open>cid \<noteq> cid'\<close> assms show ?thesis by (cases "p = r", auto)
       qed
       then show ?thesis using assms by simp
     qed
   next
     case (Trans r u u')
     then show ?thesis 
       using assms(4) assms(5) local.step by auto
   next
     case (Send cid' r s u u' m)
     then have "cid = cid'" 
       by (metis (no_types, hide_lams) assms(4) assms(5) local.step next_send)
     moreover have "(p, q) = (r, s)"
     proof -
       have "channel cid = channel cid'" using \<open>cid = cid'\<close> by simp
       moreover have "channel cid = Some (p, q)" using assms by simp
       moreover have "channel cid' = Some (r, s)" using Send step can_occur_def by auto
       ultimately show ?thesis by simp
     qed
     ultimately show ?thesis using Send by auto
   next
     case (Recv cid' r s u u' m)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "last (msgs (S t i) cid) = last (msgs (S t (i+1)) cid)" 
         by (metis (no_types, lifting) Recv assms(3) assms(4) last_ConsR local.step next_recv)
       then show ?thesis using assms by simp
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using Recv step by auto
       then show ?thesis using assms by simp
     qed
   qed
 qed
 
 lemma no_marker_after_RecvMarker:
   assumes
     "trace init t final" and
     "(S t i) \<turnstile> RecvMarker cid p q \<mapsto> (S t (i+1))" and
     "channel cid = Some (q, p)"
   shows
     "Marker \<notin> set (msgs (S t (i+1)) cid)"
 proof -
   have new_msgs: "msgs (S t i) cid = Marker # msgs (S t (i+1)) cid" 
     using assms(2) by auto
   have one_marker: "\<exists>!j. j < length (msgs (S t i) cid) \<and> msgs (S t i) cid ! j = Marker" 
     by (metis assms(1,3) at_most_one_marker list.set_intros(1) new_msgs)
   then obtain j where "j < length (msgs (S t i) cid)" "msgs (S t i) cid ! j = Marker" by blast
   then have "j = 0" using one_marker new_msgs by auto
   then have "\<forall>j. j \<noteq> 0 \<and> j < length (msgs (S t i) cid) \<longrightarrow> msgs (S t i) cid ! j \<noteq> Marker"
     using one_marker 
     using \<open>j < length (msgs (S t i) cid)\<close> \<open>msgs (S t i) cid ! j = Marker\<close> by blast
   then have "\<forall>j. j < length (msgs (S t (i+1)) cid) \<longrightarrow> msgs (S t (i+1)) cid ! j \<noteq> Marker"
     by (metis One_nat_def Suc_eq_plus1 Suc_le_eq Suc_mono le_zero_eq list.size(4) new_msgs not_less0 nth_Cons_Suc)
   then show ?thesis 
     by (simp add: in_set_conv_nth)
 qed
 
 lemma no_marker_and_snapshotted_implies_no_more_markers_trace:
   shows
     "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
        has_snapshotted (S t i) p;
        Marker \<notin> set (msgs (S t i) cid);
        channel cid = Some (p, q) \<rbrakk>
      \<Longrightarrow> Marker \<notin> set (msgs (S t j) cid)"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis (no_types, hide_lams) Suc_eq_plus1 cancel_comm_monoid_add_class.diff_cancel distributed_system.step_Suc distributed_system_axioms less_le_trans linorder_not_less old.nat.distinct(2) order_eq_iff)
   then have "Marker \<notin> set (msgs (S t (i+1)) cid)"
     using no_marker_and_snapshotted_implies_no_more_markers Suc step by blast
   moreover have "has_snapshotted (S t (i+1)) p" 
     using Suc.prems(4) local.step snapshot_state_unchanged by auto
   ultimately show ?case 
   proof -
     assume a1: "ps (S t (i + 1)) p \<noteq> None"
     assume a2: "Marker \<notin> set (msgs (S t (i + 1)) cid)"
     have f3: "j \<noteq> i"
       using Suc.hyps(2) by force
     have "j - Suc i = n"
       by (metis (no_types) Suc.hyps(2) Suc.prems(2) add.commute add_Suc_right add_diff_cancel_left' le_add_diff_inverse)
     then show ?thesis
       using f3 a2 a1 by (metis Suc.hyps(1) Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(6) Suc_eq_plus1_left add.commute less_Suc_eq linorder_not_less)
   qed
 qed
 
 lemma marker_not_vanishing_means_always_present:
   shows
     "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
        Marker : set (msgs (S t i) cid);
        Marker : set (msgs (S t j) cid);
        channel cid = Some (p, q)
      \<rbrakk> \<Longrightarrow> \<forall>k. i \<le> k \<and> k \<le> j \<longrightarrow> Marker : set (msgs (S t k) cid)"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis (no_types, lifting) Suc_eq_plus1 add_lessD1 distributed_system.step_Suc distributed_system_axioms le_add_diff_inverse order_le_less zero_less_Suc zero_less_diff)
   have "Marker : set (msgs (S t (i+1)) cid)"
   proof (rule ccontr)
     assume asm: "~ Marker : set (msgs (S t (i+1)) cid)"
     have snap_p: "has_snapshotted (S t i) p" 
       using Suc.prems(1) Suc.prems(4,6) no_marker_if_no_snapshot by blast
     then have "has_snapshotted (S t (i+1)) p" 
       using local.step snapshot_state_unchanged by auto
     then have "Marker \<notin> set (msgs (S t j) cid)"
       by (metis Suc.hyps(2) Suc.prems(1) Suc.prems(3) Suc.prems(6) asm discrete no_marker_and_snapshotted_implies_no_more_markers_trace zero_less_Suc zero_less_diff)
     then show False using Suc.prems by simp
   qed
   then show ?case
     by (meson Suc.prems(1) Suc.prems(3) Suc.prems(4) Suc.prems(5) Suc.prems(6) computation.snapshot_stable_ver_3 computation_axioms no_marker_and_snapshotted_implies_no_more_markers_trace no_marker_if_no_snapshot)
 qed
 
 lemma last_stays_if_no_recv_marker_and_no_send:
   shows "\<lbrakk> trace init t final; i < j; j \<le> length t;
            last (msgs (S t i) cid) = Marker;
            Marker : set (msgs (S t i) cid);
            Marker : set (msgs (S t j) cid);
            \<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ (\<exists>u u' m. t ! k = Send cid p q u u' m);
            channel cid = Some (p, q) \<rbrakk>
          \<Longrightarrow> last (msgs (S t j) cid) = Marker"
 proof (induct "j - (i+1)" arbitrary: i)
   case 0
   then have "j = i+1" by simp
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis "0"(2) "0.prems"(2) "0.prems"(3) Suc_eq_plus1 distributed_system.step_Suc distributed_system_axioms less_le_trans)
   have "Marker = last (msgs (S t (i+1)) cid)"
   proof (rule ccontr)
     assume "~ Marker = last (msgs (S t (i+1)) cid)"
     then have "\<exists>u u' m. t ! i = Send cid p q u u' m"
     proof -
       have "msgs (S t (i+1)) cid \<noteq> []" using "0" \<open>j = i+1\<close> by auto
       moreover have "msgs (S t i) cid \<noteq> []" using "0" by auto
       ultimately show ?thesis 
         using "0.prems"(1) "0.prems"(4) "0.prems"(8) \<open>Marker \<noteq> last (msgs (S t (i + 1)) cid)\<close> last_changes_implies_send_when_msgs_nonempty by auto
     qed
     then show False using 0 by auto
   qed
   then show ?case using \<open>j = i+1\<close> by simp
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis (no_types, hide_lams) Suc_eq_plus1 distributed_system.step_Suc distributed_system_axioms less_le_trans)
   have marker_present: "Marker : set (msgs (S t (i+1)) cid)" 
     by (meson Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(5) Suc.prems(6) Suc.prems(8) discrete le_add1 less_imp_le_nat marker_not_vanishing_means_always_present)
   moreover have "Marker = last (msgs (S t (i+1)) cid)"
   proof (rule ccontr)
     assume asm: "~ Marker = last (msgs (S t (i+1)) cid)"
     then have "\<exists>u u' m. t ! i = Send cid p q u u' m"
     proof -
       have "msgs (S t (i+1)) cid \<noteq> []" using marker_present by auto
       moreover have "msgs (S t i) cid \<noteq> []" using Suc by auto
       ultimately show ?thesis 
         using Suc.prems(1) Suc.prems(4) Suc.prems(8) asm last_changes_implies_send_when_msgs_nonempty by auto
     qed
     then show False using Suc by auto
   qed
   moreover have "\<forall>k. i+1 \<le> k \<and> k < j \<longrightarrow> ~ (\<exists>u u' m. t ! k = Send cid p q u u' m)"
     using Suc.prems by force
   moreover have "i+1 < j" using Suc by auto
   moreover have "j \<le> length t" using Suc by auto
   moreover have "trace init t final" using Suc by auto
   moreover have "Marker : set (msgs (S t j) cid)" using Suc by auto
   ultimately show ?case using Suc 
     by (metis diff_Suc_1 diff_diff_left)
 qed
 
 lemma last_changes_implies_send_when_msgs_nonempty_trace:
   assumes
     "trace init t final"
     "i < j"
     "j \<le> length t"
     "Marker : set (msgs (S t i) cid)"
     "Marker : set (msgs (S t j) cid)"
     "last (msgs (S t i) cid) = Marker"
     "last (msgs (S t j) cid) \<noteq> Marker"
     "channel cid = Some (p, q)"
   shows
     "\<exists>k u u' m. i \<le> k \<and> k < j \<and> t ! k = Send cid p q u u' m"
 proof (rule ccontr)
   assume "~ (\<exists>k u u' m. i \<le> k \<and> k < j \<and> t ! k = Send cid p q u u' m)"
   then have "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ (\<exists>u u' m. t ! k = Send cid p q u u' m)" by blast
   then have "last (msgs (S t j) cid) = Marker" using assms last_stays_if_no_recv_marker_and_no_send by blast
   then show False using assms by simp
 qed
 
 lemma msg_after_marker_and_nonempty_implies_postrecording_event:
   assumes
     "trace init t final" and
     "Marker : set (msgs (S t i) cid)" and
     "Marker \<noteq> last (msgs (S t i) cid)" and
     "i \<le> length t" and
     "channel cid = Some (p, q)"
   shows
     "\<exists>j. j < i \<and> postrecording_event t j" (is ?P)
 proof -
   let ?len = "length (msgs (S t i) cid)"
   have "?len \<noteq> 0" using assms(2) by auto
   have snap_p_i: "has_snapshotted (S t i) p" 
     using assms no_marker_if_no_snapshot by blast
   obtain j where snap_p: "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" 
     by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p)
   have "j < i" 
     by (meson assms(1) computation.snapshot_stable_ver_2 computation_axioms not_less snap_p(1) snap_p_i)
   have step_snap: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
     by (metis Suc_eq_plus1 assms(1) l2 nat_le_linear nat_less_le snap_p(1) snapshot_stable_ver_2 step_Suc)
   have re: "~ regular_event (t ! j)" 
     by (meson distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(1) snap_p(2) step_snap)
   have op: "occurs_on (t ! j) = p" 
     using no_state_change_if_no_event snap_p(1) snap_p(2) step_snap by force
   have marker_last: "Marker = last (msgs (S t (j+1)) cid) \<and> msgs (S t (j+1)) cid \<noteq> []"
   proof -
     have "isSnapshot (t ! j) \<or> isRecvMarker (t ! j)" using re nonregular_event by auto
     then show ?thesis
     proof (elim disjE, goal_cases)
       case 1
       then have "t ! j = Snapshot p" 
         using op by auto
       then show ?thesis using step_snap assms by auto
     next
       case 2
       then obtain cid' r where RecvMarker: "t ! j = RecvMarker cid' p r" 
         by (metis event.collapse(5) op)
       then have "cid \<noteq> cid'" 
         using RecvMarker_implies_Marker_in_set assms(1) assms(5) no_marker_if_no_snapshot snap_p(1) step_snap by blast
       then show ?thesis 
         using assms snap_p(1) step_snap RecvMarker by auto
     qed
   qed
   then have "\<exists>k u u' m. j+1 \<le> k \<and> k < i \<and> t ! k = Send cid p q u u' m"
   proof -
     have "j+1 < i"
     proof -
       have "(S t (j+1)) \<noteq> (S t i)" 
         using assms(3) marker_last by auto
       then have "j+1 \<noteq> i" by auto
       moreover have "j+1 \<le> i" using \<open>j < i\<close> by simp
       ultimately show ?thesis by simp
     qed
     moreover have "trace init t final" using assms by simp
     moreover have "Marker = last (msgs (S t (j+1)) cid)" using marker_last by simp
     moreover have "Marker : set (msgs (S t (j+1)) cid)" using marker_last by (simp add: marker_last)
     ultimately show ?thesis using assms last_changes_implies_send_when_msgs_nonempty_trace by simp
   qed
   then obtain k where Send: "\<exists>u u' m. j+1 \<le> k \<and> k < i \<and> t ! k = Send cid p q u u' m" by blast
   then have "postrecording_event t k"
   proof -
     have "k < length t" using Send assms by simp
     moreover have "isSend (t ! k)" using Send by auto
     moreover have "has_snapshotted (S t k) p" using Send snap_p 
       using assms(1) snapshot_stable_ver_3 by blast
     moreover have "occurs_on (t ! k) = p" using Send by auto
     ultimately show ?thesis unfolding postrecording_event by simp
   qed
   then show ?thesis using Send by auto
 qed
 
 lemma same_messages_if_no_occurrence_trace:
   shows
     "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
        (\<forall>k. i \<le> k \<and> k < j \<longrightarrow> occurs_on (t ! k) \<noteq> p \<and> occurs_on (t ! k) \<noteq> q);
        channel cid = Some (p, q) \<rbrakk>
      \<Longrightarrow> msgs (S t i) cid = msgs (S t j) cid \<and> cs (S t i) cid = cs (S t j) cid"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
     by (metis (no_types, hide_lams) Suc_eq_plus1 Suc_n_not_le_n diff_self_eq_0 distributed_system.step_Suc distributed_system_axioms le0 le_eq_less_or_eq less_le_trans)
   then have "msgs (S t i) cid = msgs (S t (i+1)) cid \<and> cs (S t i) cid = cs (S t (i+1)) cid"
   proof -
     have "~ occurs_on (t ! i) = p" using Suc by simp
     moreover have "~ occurs_on (t ! i) = q" using Suc by simp
     ultimately show ?thesis using step Suc same_messages_if_no_occurrence by blast
   qed
   moreover have "msgs (S t (i+1)) cid = msgs (S t j) cid \<and> cs (S t (i+1)) cid = cs (S t j) cid"
   proof -
     have "i+1 \<le> j" using Suc by linarith
     moreover have "\<forall>k. i+1 \<le> k \<and> k < j \<longrightarrow> occurs_on (t ! k) \<noteq> p \<and> occurs_on (t ! k) \<noteq> q" using Suc by force
     ultimately show ?thesis using Suc by auto
   qed
   ultimately show ?case by simp
 qed
 
 lemma snapshot_step_cs_preservation_p:
   assumes
     "c \<turnstile> ev \<mapsto> c'" and
     "~ regular_event ev" and
     "occurs_on ev = p" and
     "channel cid = Some (p, q)"
   shows
     "map Msg (fst (cs c cid)) @ takeWhile ((\<noteq>) Marker) (msgs c cid)
    = map Msg (fst (cs c' cid)) @ takeWhile ((\<noteq>) Marker) (msgs c' cid)
    \<and> snd (cs c cid) = snd (cs c' cid)"
 proof -
   have "isSnapshot ev \<or> isRecvMarker ev" using assms nonregular_event by blast
   then show ?thesis
   proof (elim disjE, goal_cases)
     case 1
     then have Snap: "ev = Snapshot p" by (metis event.collapse(4) assms(3))
     then have "fst (cs c cid) = fst (cs c' cid)" 
       using assms(1) assms(2) regular_event same_cs_if_not_recv by blast
     moreover have "takeWhile ((\<noteq>) Marker) (msgs c cid)
                  = takeWhile ((\<noteq>) Marker) (msgs c' cid)"
     proof -
       have "msgs c' cid = msgs c cid @ [Marker]" using assms Snap by auto
       then show ?thesis 
         by (simp add: takeWhile_tail)
     qed
     moreover have "snd (cs c cid) = snd (cs c' cid)" 
       using Snap assms no_self_channel by fastforce
     ultimately show ?thesis by simp
   next
     case 2
     then obtain cid' r where RecvMarker: "ev = RecvMarker cid' p r" by (metis event.collapse(5) assms(3))
     have "cid \<noteq> cid'" 
       by (metis "2" RecvMarker assms(1) assms(4) distributed_system.RecvMarker_given_channel distributed_system.happen_implies_can_occur distributed_system_axioms event.sel(5,10) no_self_channel)
     then have "fst (cs c cid) = fst (cs c' cid)"
       using RecvMarker assms(1) assms(2) regular_event same_cs_if_not_recv by blast
     moreover have "takeWhile ((\<noteq>) Marker) (msgs c cid)
                  = takeWhile ((\<noteq>) Marker) (msgs c' cid)"
     proof (cases "has_snapshotted c p")
       case True
       then have "msgs c cid = msgs c' cid" using RecvMarker \<open>cid \<noteq> cid'\<close> assms by auto
       then show ?thesis by simp
     next
       case False
       then have "msgs c' cid = msgs c cid @ [Marker]" using RecvMarker \<open>cid \<noteq> cid'\<close> assms by auto
       then show ?thesis
         by (simp add: takeWhile_tail)
     qed
     moreover have "snd (cs c cid) = snd (cs c' cid)"
     proof (cases "has_snapshotted c p")
       case True
       then have "cs c cid = cs c' cid" using RecvMarker \<open>cid \<noteq> cid'\<close> assms by simp
       then show ?thesis by simp
     next
       case False
       then show ?thesis
         using RecvMarker \<open>cid \<noteq> cid'\<close> assms(1) assms(4) no_self_channel by auto
     qed
     ultimately show ?thesis by simp
   qed
 qed
 
 lemma snapshot_step_cs_preservation_q:
   assumes
     "c \<turnstile> ev \<mapsto> c'" and
     "~ regular_event ev" and
     "occurs_on ev = q" and
     "channel cid = Some (p, q)" and
     "Marker \<notin> set (msgs c cid)" and
     "~ has_snapshotted c q"
   shows
     "map Msg (fst (cs c cid)) @ takeWhile ((\<noteq>) Marker) (msgs c cid)
    = map Msg (fst (cs c' cid)) @ takeWhile ((\<noteq>) Marker) (msgs c' cid)
    \<and> snd (cs c' cid) = Recording"
 proof -
   have "isSnapshot ev \<or> isRecvMarker ev" using assms nonregular_event by blast
   then show ?thesis
   proof (elim disjE, goal_cases)
     case 1
     then have Snapshot: "ev = Snapshot q" by (metis event.collapse(4) assms(3))
     then have "fst (cs c cid) = fst (cs c' cid)" 
       using assms(1) assms(2) regular_event same_cs_if_not_recv by blast
     moreover have "takeWhile ((\<noteq>) Marker) (msgs c cid)
                  = takeWhile ((\<noteq>) Marker) (msgs c' cid)"
     proof -
       have "msgs c' cid = msgs c cid" using assms Snapshot 
         by (metis distributed_system.next_snapshot distributed_system_axioms eq_fst_iff no_self_channel option.inject)
       then show ?thesis by simp
     qed
     moreover have "snd (cs c' cid) = Recording" using assms Snapshot by auto
     ultimately show ?thesis by simp
   next
     case 2
     then obtain cid' r where RecvMarker: "ev = RecvMarker cid' q r" by (metis event.collapse(5) assms(3))
     have "cid \<noteq> cid'" 
       using RecvMarker RecvMarker_implies_Marker_in_set assms(1) assms(5) by blast
     have "fst (cs c cid) = fst (cs c' cid)"
       using assms(1) assms(2) regular_event same_cs_if_not_recv by blast
     moreover have "takeWhile ((\<noteq>) Marker) (msgs c cid)
                  = takeWhile ((\<noteq>) Marker) (msgs c' cid)"
     proof -
       have "\<nexists>r. channel cid = Some (q, r)" 
         using assms(4) no_self_channel by auto
       with RecvMarker assms \<open>cid \<noteq> cid'\<close> have "msgs c cid = msgs c' cid" by (cases "has_snapshotted c r", auto)
       then show ?thesis by simp
     qed
     moreover have "snd (cs c' cid) = Recording" using assms RecvMarker \<open>cid \<noteq> cid'\<close> by simp
     ultimately show ?thesis by simp
   qed
 qed
 
 lemma Marker_in_channel_implies_not_done:
   assumes
     "trace init t final" and
     "Marker : set (msgs (S t i) cid)" and
     "channel cid = Some (p, q)" and
     "i \<le> length t"
   shows
     "snd (cs (S t i) cid) \<noteq> Done"
 proof (rule ccontr)
   assume is_done: "~ snd (cs (S t i) cid) \<noteq> Done"
   let ?t = "take i t"
   have tr: "trace init ?t (S t i)" 
     using assms(1) exists_trace_for_any_i by blast
   have "\<exists>q p. RecvMarker cid q p \<in> set ?t" 
     by (metis (mono_tags, lifting) assms(3) distributed_system.trace.simps distributed_system_axioms done_only_from_recv_marker_trace computation.no_initial_channel_snapshot computation_axioms is_done list.discI recording_state.simps(4) snd_conv tr)
   then obtain j where RecvMarker: "\<exists>q p. t ! j = RecvMarker cid q p" "j < i" 
     by (metis (no_types, lifting) assms(4) in_set_conv_nth length_take min.absorb2 nth_take)
   then have step_j: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
     by (metis Suc_eq_plus1 assms(1) distributed_system.step_Suc distributed_system_axioms assms(4) less_le_trans)
   then have "t ! j = RecvMarker cid q p"
     by (metis RecvMarker(1) RecvMarker_given_channel assms(3) event.disc(25) event.sel(10) happen_implies_can_occur)
   then have "Marker \<notin> set (msgs (S t (j+1)) cid)" 
     using assms(1) assms(3) no_marker_after_RecvMarker step_j by presburger
   moreover have "has_snapshotted (S t (j+1)) p" 
     using Suc_eq_plus1 \<open>t ! j = RecvMarker cid q p\<close> assms(1) recv_marker_means_snapshotted snapshot_state_unchanged step_j by presburger
   ultimately have "Marker \<notin> set (msgs (S t i) cid)" 
     by (metis RecvMarker(2) Suc_eq_plus1 Suc_leI assms(1,3) assms(4) no_marker_and_snapshotted_implies_no_more_markers_trace)
   then show False using assms by simp
 qed
 
 lemma keep_empty_if_no_events:
   shows
     "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
        msgs (S t i) cid = [];
        has_snapshotted (S t i) p;
        channel cid = Some (p, q);
        \<forall>k. i \<le> k \<and> k < j \<and> regular_event (t ! k) \<longrightarrow> ~ occurs_on (t ! k) = p \<rbrakk>
      \<Longrightarrow> msgs (S t j) cid = []"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
   proof -
     have "i < length t"
       using Suc.hyps(2) Suc.prems(3) by linarith
     then show ?thesis
       by (metis (full_types) Suc.prems(1) Suc_eq_plus1 step_Suc)
   qed
   have "msgs (S t (i+1)) cid = []"
   proof (cases "t ! i")
     case (Snapshot r)
     have "r \<noteq> p"
     proof (rule ccontr)
       assume "~ r \<noteq> p"
       moreover have "can_occur (t ! i) (S t i)"
         using happen_implies_can_occur local.step by blast
       ultimately show False using can_occur_def Snapshot Suc by simp
     qed
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" 
       using Snapshot local.step Suc by auto
     then show ?thesis using Suc by simp
   next
     case (RecvMarker cid' r s)
     have "cid \<noteq> cid'"
     proof (rule ccontr)
       assume "~ cid \<noteq> cid'"
       then have "msgs (S t i) cid \<noteq> []" 
         by (metis RecvMarker length_greater_0_conv linorder_not_less list.size(3) local.step nat_less_le recv_marker_other_channels_not_shrinking)
       then show False using Suc by simp
     qed
     then show ?thesis
     proof (cases "has_snapshotted (S t i) r")
       case True
       then have "msgs (S t (i+1)) cid = msgs (S t i) cid" using RecvMarker Suc step \<open>cid \<noteq> cid'\<close> by auto
       then show ?thesis using Suc by simp
     next
       case False
       have "r \<noteq> p" 
         using False Suc.prems(5) by blast
       then show ?thesis using RecvMarker Suc step \<open>cid \<noteq> cid'\<close> False by simp
     qed
   next
     case (Trans r u u')
     then show ?thesis using Suc step by simp
   next
     case (Send cid' r s u u' m)
     have "r \<noteq> p"
     proof (rule ccontr)
       assume "~ r \<noteq> p"
       then have "occurs_on (t ! i) = p \<and> regular_event (t ! i)" using Send by simp
       moreover have "i \<le> i \<and> i < j" using Suc by simp
       ultimately show False using Suc.prems by blast
     qed
     have "cid \<noteq> cid'"
     proof (rule ccontr)
       assume "~ cid \<noteq> cid'"
       then have "channel cid = channel cid'" by auto
       then have "channel cid' = Some (r, s)" using Send step can_occur_def by simp
       then show False using Suc \<open>r \<noteq> p\<close> \<open>~ cid \<noteq> cid'\<close> by auto
     qed
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid"
       using step Send Suc by simp
     then show ?thesis using Suc by simp
   next
     case (Recv cid' r s u u' m)
     have "cid \<noteq> cid'"
     proof (rule ccontr)
       assume "~ cid \<noteq> cid'"
       then have "msgs (S t i) cid \<noteq> []" 
         using Recv local.step by auto
       then show False using Suc by simp
     qed
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using Recv step by auto
     then show ?thesis using Suc by simp
   qed
   moreover have "\<forall>k. i+1 \<le> k \<and> k < j \<and> regular_event (t ! k) \<longrightarrow> ~ occurs_on (t ! k) = p"
     using Suc by simp
   moreover have "has_snapshotted (S t (i+1)) p" 
     by (meson Suc.prems(1) Suc.prems(5) discrete less_not_refl nat_le_linear snapshot_stable_ver_3)
   moreover have "i+1 \<le> j" using Suc by simp
   moreover have "j \<le> length t" using Suc by simp
   moreover have "j - (i+1) = n" using Suc by linarith
   ultimately show ?case using Suc by blast
 qed
 
 lemma last_unchanged_or_empty_if_no_events:
   shows
     "\<lbrakk> trace init t final; i \<le> j; j \<le> length t;
        msgs (S t i) cid \<noteq> [];
        last (msgs (S t i) cid) = Marker;
        has_snapshotted (S t i) p;
        channel cid = Some (p, q);
        \<forall>k. i \<le> k \<and> k < j \<and> regular_event (t ! k) \<longrightarrow> ~ occurs_on (t ! k) = p \<rbrakk>
      \<Longrightarrow> msgs (S t j) cid = [] \<or> (msgs (S t j) cid \<noteq> [] \<and> last (msgs (S t j) cid) = Marker)"
 proof (induct "j - i" arbitrary: i)
   case 0
   then show ?case 
     by auto
 next
   case (Suc n)
   then have step: "(S t i) \<turnstile> (t ! i) \<mapsto> (S t (i+1))" 
   proof -
     have "i < length t"
       using Suc.hyps(2) Suc.prems(3) by linarith
     then show ?thesis
       by (metis (full_types) Suc.prems(1) Suc_eq_plus1 step_Suc)
   qed
   have msgs_s_ip1: "msgs (S t (i+1)) cid = [] \<or> (msgs (S t (i+1)) cid \<noteq> [] \<and> last (msgs (S t (i+1)) cid) = Marker)"
   proof (cases "t ! i")
     case (Snapshot r)
     have "r \<noteq> p"
     proof (rule ccontr)
       assume "~ r \<noteq> p"
       moreover have "can_occur (t ! i) (S t i)"
         using happen_implies_can_occur local.step by blast
       ultimately show False using can_occur_def Snapshot Suc by simp
     qed
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid" 
       using Snapshot local.step Suc by auto
     then show ?thesis using Suc by simp
   next
     case (RecvMarker cid' r s)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "msgs (S t (i+1)) cid = []" 
       proof -
         have "Marker # msgs (S t (i+1)) cid = msgs (S t i) cid"
           using RecvMarker True local.step by auto
         then show ?thesis
         proof -
           assume a1: "Marker # msgs (S t (i + 1)) cid = msgs (S t i) cid"
           have "i < j"
             by (metis (no_types) Suc.hyps(2) Suc.prems(2) Suc_neq_Zero diff_is_0_eq le_neq_implies_less)
           then have "i < length t"
             using Suc.prems(3) less_le_trans by blast
           then show ?thesis
             using a1 by (metis (no_types) Marker_in_channel_implies_not_done RecvMarker Suc.prems(1) Suc.prems(5) Suc.prems(7) Suc_eq_plus1 Suc_le_eq True last_ConsR last_in_set recv_marker_means_cs_Done)
         qed
       qed
       then show ?thesis by simp
     next
       case False
       then show ?thesis
       proof (cases "has_snapshotted (S t i) r")
         case True
         then show ?thesis 
           using False RecvMarker Suc.prems(5) local.step by auto
       next
         case False
         then have "r \<noteq> p" 
           using Suc.prems(6) by blast
         with RecvMarker False Suc.prems step \<open>cid \<noteq> cid'\<close> show ?thesis by auto
       qed
     qed
   next
     case (Trans r u u')
     then show ?thesis using Suc step by simp
   next
     case (Send cid' r s u u' m)
     have "r \<noteq> p"
     proof (rule ccontr)
       assume "~ r \<noteq> p"
       then have "occurs_on (t ! i) = p \<and> regular_event (t ! i)" using Send by simp
       moreover have "i \<le> i \<and> i < j" using Suc by simp
       ultimately show False using Suc.prems by blast
     qed
     have "cid \<noteq> cid'"
     proof (rule ccontr)
       assume "~ cid \<noteq> cid'"
       then have "channel cid = channel cid'" by auto
       then have "channel cid' = Some (r, s)" using Send step can_occur_def by simp
       then show False using Suc \<open>r \<noteq> p\<close> \<open>~ cid \<noteq> cid'\<close> by auto
     qed
     then have "msgs (S t i) cid = msgs (S t (i+1)) cid"
       using step Send by simp
     then show ?thesis using Suc by simp
   next
     case (Recv cid' r s u u' m)
     then show ?thesis
     proof (cases "cid = cid'")
       case True
       then have "msgs (S t i) cid = Msg m # msgs (S t (i+1)) cid" 
         using Recv local.step by auto
       then have "last (msgs (S t (i+1)) cid) = Marker" 
         by (metis Suc.prems(5) last.simps message.simps(3))
       then show ?thesis by blast
     next
       case False
       then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using Recv step by auto
       then show ?thesis using Suc by simp
     qed
   qed
   then show ?case
   proof (elim disjE, goal_cases)
     case 1
     moreover have "trace init t final" using Suc by simp
     moreover have "i+1 \<le> j" using Suc by simp
     moreover have "j \<le> length t" using Suc by simp
     moreover have "has_snapshotted (S t (i+1)) p" 
       using Suc.prems(6) local.step snapshot_state_unchanged by auto
     moreover have "j - (i+1) = n" using Suc by linarith
     moreover have "\<forall>k. i+1 \<le> k \<and> k < j \<and> regular_event (t ! k) \<longrightarrow> ~ occurs_on (t ! k) = p"
       using Suc by auto
     ultimately have "msgs (S t j) cid = []" using keep_empty_if_no_events Suc.prems(7) by blast
     then show ?thesis by simp
   next
     case 2
     moreover have "trace init t final" using Suc by simp
     moreover have "i+1 \<le> j" using Suc by simp
     moreover have "j \<le> length t" using Suc by simp
     moreover have "has_snapshotted (S t (i+1)) p" 
       using Suc.prems(6) local.step snapshot_state_unchanged by auto
     moreover have "j - (i+1) = n" using Suc by linarith
     moreover have "\<forall>k. i+1 \<le> k \<and> k < j \<and> regular_event (t ! k) \<longrightarrow> ~ occurs_on (t ! k) = p"
       using Suc by auto
     ultimately show ?thesis using Suc.prems(7) Suc.hyps by blast
   qed
 qed
 
 lemma cs_after_all_prerecording_events:
   assumes
     "trace init t final" and
     "\<forall>i'. i' \<ge> i \<longrightarrow> ~ prerecording_event t i'" and
     "\<forall>j'. j' < i \<longrightarrow> ~ postrecording_event t j'" and
     "i \<le> length t"
   shows
     "cs_equal_to_snapshot (S t i) final"
 proof (unfold cs_equal_to_snapshot_def, rule allI, rule impI)
   fix cid
   assume "channel cid \<noteq> None"
   then obtain p q where chan: "channel cid = Some (p, q)" by auto
   have cs_done: "snd (cs (S t (length t)) cid) = Done" 
     using chan all_channels_done_in_final_state assms(1) final_is_s_t_len_t by blast
   have "filter ((\<noteq>) Marker) (msgs (S t i) cid) = takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)" (is ?B)
   proof (rule ccontr)
     let ?m = "msgs (S t i) cid"
     assume "~ ?B"
     then obtain j k where range: "j < k" "k < length ?m" and "?m ! j = Marker" "?m ! k \<noteq> Marker"
       using filter_neq_takeWhile by metis
     then have "Marker \<in> set ?m" 
       by (metis less_trans nth_mem)
     moreover have "last ?m \<noteq> Marker"
     proof -
       have "\<forall>l. l < length ?m \<and> l \<noteq> j \<longrightarrow> ?m ! l \<noteq> Marker" 
         using chan \<open>j < k\<close> \<open>k < length (msgs (S t i) cid)\<close> \<open>msgs (S t i) cid ! j = Marker\<close> assms(1) at_most_one_marker calculation less_trans by blast
       moreover have "last ?m = ?m ! (length ?m - 1)" 
         by (metis \<open>Marker \<in> set (msgs (S t i) cid)\<close> empty_iff last_conv_nth list.set(1))
       moreover have "length ?m - 1 \<noteq> j" using range by auto
       ultimately show ?thesis using range by auto
     qed
     moreover have "i \<le> length t" 
       using chan assms(1) calculation(1) computation.exists_next_marker_free_state computation.no_change_if_ge_length_t computation_axioms nat_le_linear by fastforce
     ultimately have "\<exists>j. j < i \<and> postrecording_event t j"
       using chan assms(1) msg_after_marker_and_nonempty_implies_postrecording_event by auto
     then show False using assms by auto
   qed
   moreover have "takeWhile ((\<noteq>) Marker) (msgs (S t i) cid) = map Msg (fst (cs final cid))"
   proof (cases "snd (cs (S t i) cid)")
     case NotStarted
     text \<open>show that q and p have to snapshot, and then reduce it to the case below depending on
           the order they snapshotted in\<close>
     have nsq: "~ has_snapshotted (S t i) q" 
       using NotStarted chan assms(1) cs_in_initial_state_implies_not_snapshotted by auto
     obtain j where snap_q: "~ has_snapshotted (S t j) q" "has_snapshotted (S t (j+1)) q" 
       by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p)
     have step_q: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
       by (metis \<open>\<not> ps (S t j) q \<noteq> None\<close> add.commute assms(1) le_SucI le_eq_less_or_eq le_refl linorder_neqE_nat no_change_if_ge_length_t plus_1_eq_Suc snap_q step_Suc)
     obtain k where snap_p: "~ has_snapshotted (S t k) p" "has_snapshotted (S t (k+1)) p" 
       by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p)
     have bound: "i \<le> j"
     proof (rule ccontr)
       assume "~ i \<le> j"
       then have "i \<ge> j+1" by simp
       then have "has_snapshotted (S t i) q" 
         by (meson assms(1) computation.snapshot_stable_ver_3 computation_axioms snap_q(2))
       then show False using nsq by simp
     qed
     have step_p: "(S t k) \<turnstile> (t ! k) \<mapsto> (S t (k+1))" 
       by (metis \<open>\<not> ps (S t k) p \<noteq> None\<close> add.commute assms(1) le_SucI le_eq_less_or_eq le_refl linorder_neqE_nat no_change_if_ge_length_t plus_1_eq_Suc snap_p step_Suc)
     have oq: "occurs_on (t ! j) = q"
     proof (rule ccontr)
       assume "~ occurs_on (t ! j) = q"
       then have "has_snapshotted (S t j) q = has_snapshotted (S t (j+1)) q" 
         using no_state_change_if_no_event step_q by auto
       then show False using snap_q by blast
     qed
     have op: "occurs_on (t ! k) = p"
     proof (rule ccontr)
       assume "~ occurs_on (t ! k) = p"
       then have "has_snapshotted (S t k) p = has_snapshotted (S t (k+1)) p"
         using no_state_change_if_no_event step_p by auto
       then show False using snap_p by blast
     qed
     have "p \<noteq> q" using chan no_self_channel by blast
     then have "j \<noteq> k" using oq op event_occurs_on_unique by blast
     show ?thesis
     proof (cases "j < k")
       case True
       then have "msgs (S t i) cid = msgs (S t j) cid \<and> cs (S t i) cid = cs (S t j) cid"
       proof -
         have "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> occurs_on (t ! k) \<noteq> p \<and> occurs_on (t ! k) \<noteq> q" (is ?Q)
         proof (rule ccontr)
           assume "~ ?Q"
           then obtain l where range: "i \<le> l" "l < j" and "occurs_on (t ! l) = p \<or> occurs_on (t ! l) = q" by blast
           then show False
           proof (elim disjE, goal_cases)
             case 1
             then show ?thesis
             proof (cases "regular_event (t ! l)")
               case True
               have "l < k" using range \<open>j < k\<close> by simp
               have "~ has_snapshotted (S t l) p" using snap_p(1) range \<open>j < k\<close> snapshot_stable_ver_3 assms(1) by simp
               then have "prerecording_event t l" using True "1" prerecording_event 
                 using s_def snap_q(1) snap_q(2) by fastforce
               then show False using assms range by blast
             next
               case False
               then have step_l: "(S t l) \<turnstile> t ! l \<mapsto> (S t (l+1))" 
                 by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD True assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all)
               then have "has_snapshotted (S t (l+1)) p" using False nonregular_event_induces_snapshot 
                 by (metis "1"(3) snapshot_state_unchanged)
               then show False 
                 by (metis Suc_eq_plus1 Suc_leI True assms(1) less_imp_le_nat local.range(2) snap_p(1) snapshot_stable_ver_3)
             qed
           next
             case 2
             then show ?thesis
             proof (cases "regular_event (t ! l)")
               case True
               have "~ has_snapshotted (S t l) q" using snap_q(1) range \<open>j < k\<close> snapshot_stable_ver_3 assms(1) by simp
               then have "prerecording_event t l" using True "2" prerecording_event 
                 using s_def snap_q(2) by fastforce
               then show False using assms range by blast
             next
               case False
               then have step_l: "(S t l) \<turnstile> t ! l \<mapsto> (S t (l+1))" 
                 by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD True assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all)
               then have "has_snapshotted (S t (l+1)) q" using False nonregular_event_induces_snapshot 
                 by (metis "2"(3) snapshot_state_unchanged)
               then show False 
                 by (metis Suc_eq_plus1 Suc_leI assms(1) range(2) snap_q(1) snapshot_stable_ver_3)
             qed
           qed
         qed
         moreover have "j \<le> length t"
         proof (rule ccontr)
           assume "~ j \<le> length t"
           then have "S t j = S t (j+1)" using no_change_if_ge_length_t assms by simp
           then show False using snap_q by auto
         qed
         ultimately show ?thesis using chan same_messages_if_no_occurrence_trace assms less_imp_le bound by blast
       qed
       moreover have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
                    = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (j+1)) cid)
                    \<and> snd (cs (S t (j+1)) cid) = Recording"
       proof -
         have "~ regular_event (t ! j)" using snap_q 
           using regular_event_cannot_induce_snapshot step_q by blast
         moreover have "Marker \<notin> set (msgs (S t j) cid)" 
           by (meson chan True assms(1) computation.no_marker_if_no_snapshot computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_p(1))
         ultimately show ?thesis using oq snapshot_step_cs_preservation_q step_q chan snap_q(1) by blast
       qed
       moreover have "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid)
                  = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (j+1)) cid)"
       proof -
         have "snd (cs (S t (j+1)) cid) = Recording" using calculation by simp
         moreover have "\<forall>a. j+1 \<le> a \<and> a < k \<longrightarrow> ~ occurs_on (t ! a) = p" (is ?R)
         proof (rule ccontr)
           assume "~ ?R"
           then obtain a where "j+1 \<le> a" "a < k" and ocp: "occurs_on (t ! a) = p" by blast
           have "a < length t"
           proof -
             have "k < length t"
             proof (rule ccontr)
               assume "~ k < length t"
               then have "S t k = S t (k+1)" 
                 using assms(1) no_change_if_ge_length_t by auto
               then show False using snap_p by auto
             qed
             then show ?thesis using \<open>a < k\<close> by simp
           qed
           then show False
           proof (cases "regular_event (t ! a)")
             case True
             have "~ has_snapshotted (S t a) p" 
               by (meson \<open>a < k\<close> assms(1) computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_p(1))
             then have "prerecording_event t a" using \<open>a < length t\<close> ocp True prerecording_event by simp
             then show False using \<open>j+1 \<le> a\<close> \<open>j \<ge> i\<close> assms by auto
           next
             case False
             then have "(S t a) \<turnstile> (t ! a) \<mapsto> (S t (a+1))" 
               using \<open>a < length t\<close> assms(1) step_Suc by auto
             then have "has_snapshotted (S t (a+1)) p" 
               by (metis False ocp nonregular_event_induces_snapshot snapshot_state_unchanged)
             then show False 
               by (metis Suc_eq_plus1 Suc_leI \<open>a < k\<close> assms(1) snap_p(1) snapshot_stable_ver_3)
           qed
         qed
         moreover have "~ has_snapshotted (S t (j+1)) p" 
           by (metis Suc_eq_plus1 Suc_le_eq True assms(1) computation.snapshot_stable_ver_2 computation_axioms snap_p(1))
         ultimately show ?thesis using chan cs_when_recording_2 True assms(1) by auto
       qed
       moreover have "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid)
                  = map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k+1)) cid)"
       proof -
         have "\<not> regular_event (t ! k)"
           using regular_event_preserves_process_snapshots snap_p(1) snap_p(2) step_p by force
         then show ?thesis
           using chan computation.snapshot_step_cs_preservation_p computation_axioms op step_p by fastforce
       qed
       moreover have "map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k+1)) cid)
                  = map Msg (fst (cs final cid))"
       proof -
         have f1: "\<forall>f p pa pb c ca es n a na. \<not> computation f p pa pb (c::('a, 'b, 'c) configuration) ca \<or> \<not> distributed_system.trace f p pa pb c es ca \<or> ps (distributed_system.s f p pa pb c es n) a = None \<or> \<not> n \<le> na \<or> ps (distributed_system.s f p pa pb c es na) a \<noteq> None"
           by (meson computation.snapshot_stable_ver_2)
         have f2: "computation channel trans send recv init (S t (length t))"
           using assms(1) final_is_s_t_len_t computation_axioms by blast
         have f3: "trace init t (S t (length t))"
           using assms(1) final_is_s_t_len_t by blast
         have f4: "ps (S t k) p = None"
           by (meson snap_p(1))
         then have f5: "k < length t"
           using f3 f2 f1 by (metis le_eq_less_or_eq not_le s_def snap_p(2) take_all)
         have "\<not> regular_event (t ! k)"
           using f4 by (meson distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(2) step_p)
         then have f6: "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k + 1)) cid) \<and> snd (cs (S t k) cid) = snd (cs (S t (k + 1)) cid)"
           using chan computation.snapshot_step_cs_preservation_p computation_axioms op step_p by fastforce
         then have f7: "snd (cs (S t (k + 1)) cid) \<noteq> Done"
           using f5 f4 by (metis (no_types) assms(1) chan cs_done_implies_both_snapshotted(1))
         have "j + 1 \<le> k + 1"
           using True by linarith
        then have "snd (cs (S t (k + 1)) cid) = Recording"
           using f7 f3 f2 f1 by (meson chan computation.cs_in_initial_state_implies_not_snapshotted recording_state.exhaust snap_q(2))
        then show ?thesis
          using f6 f5 by (metis (no_types) Suc_eq_plus1 Suc_leI assms(1) chan cs_done cs_done_implies_both_snapshotted(1) cs_when_recording final_is_s_t_len_t le_eq_less_or_eq snap_p(2))
       qed
       ultimately show ?thesis 
         by (metis (no_types, lifting) chan Nil_is_map_conv assms(1) computation.no_initial_channel_snapshot computation_axioms fst_conv no_recording_cs_if_not_snapshotted self_append_conv2 snap_q(1))
     next
       case False
       then have "k < j" using \<open>j \<noteq> k\<close> False by simp
       then have "map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)
                = map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)"
       proof (cases "i \<le> k")
         case True
         then have "msgs (S t i) cid = msgs (S t k) cid \<and> cs (S t i) cid = cs (S t k) cid"
         proof -
           have "\<forall>j. i \<le> j \<and> j < k \<longrightarrow> occurs_on (t ! j) \<noteq> p \<and> occurs_on (t ! j) \<noteq> q" (is ?Q)
           proof (rule ccontr)
             assume "~ ?Q"
             then obtain l where range: "i \<le> l" "l < k" and "occurs_on (t ! l) = p \<or> occurs_on (t ! l) = q" by blast
             then show False
             proof (elim disjE, goal_cases)
               case 1
               then show ?thesis
               proof (cases "regular_event (t ! l)")
                 case True
                 have "l < k" using range \<open>k < j\<close> by simp
                 have "~ has_snapshotted (S t l) p" using snap_p(1) range \<open>k < j\<close> snapshot_stable_ver_3 assms(1) by simp
                 then have "prerecording_event t l" using True "1" prerecording_event 
                   using s_def snap_p by fastforce
                 then show False using assms range by blast
               next
                 case False
                 then have step_l: "(S t l) \<turnstile> t ! l \<mapsto> (S t (l+1))" 
                   by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all)
                 then have "has_snapshotted (S t (l+1)) p" using False nonregular_event_induces_snapshot 
                   by (metis "1"(3) snapshot_state_unchanged)
                 then show False 
                   by (metis Suc_eq_plus1 Suc_leI assms(1) local.range(2) snap_p(1) snapshot_stable_ver_3)
               qed
             next
               case 2
               then show ?thesis
               proof (cases "regular_event (t ! l)")
                 case True
                 have "~ has_snapshotted (S t l) p" using snap_p(1) range \<open>k < j\<close> snapshot_stable_ver_3 assms(1) by simp
                 moreover have "l < length t" 
                   using \<open>k < j\<close> local.range(2) s_def snap_q(1) snap_q(2) by force
                 ultimately have "prerecording_event t l" using True "2" prerecording_event 
                 proof -
                   have "l \<le> j"
                     by (meson False \<open>l < k\<close> less_trans not_less)
                   then show ?thesis
                     by (metis (no_types) True \<open>l < length t\<close> \<open>occurs_on (t ! l) = q\<close> assms(1) computation.prerecording_event computation.snapshot_stable_ver_2 computation_axioms snap_q(1))
                 qed
                 then show False using assms range by blast
               next
                 case False
                 then have step_l: "(S t l) \<turnstile> t ! l \<mapsto> (S t (l+1))" 
                   by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all)
                 then have "has_snapshotted (S t (l+1)) q" using False nonregular_event_induces_snapshot 
                   by (metis "2"(3) snapshot_state_unchanged)
                 then show False 
                   by (metis Suc_eq_plus1 Suc_leI \<open>k < j\<close> assms(1) less_imp_le_nat local.range(2) snap_q(1) snapshot_stable_ver_3)
               qed
             qed
           qed
           moreover have "k \<le> length t"
           proof (rule ccontr)
             assume "~ k \<le> length t"
             then have "S t k = S t (k+1)" using no_change_if_ge_length_t assms by simp
             then show False using snap_p by auto
           qed
           ultimately show ?thesis using chan same_messages_if_no_occurrence_trace assms True less_imp_le by auto
         qed
         moreover have "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid)
                    = map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k+1)) cid)
                    \<and> snd (cs (S t (k+1)) cid) = NotStarted"
         proof -
           have "~ regular_event (t ! k)" using snap_p 
             using regular_event_cannot_induce_snapshot step_p by blast
           then show ?thesis
             using calculation op snapshot_step_cs_preservation_p step_p chan NotStarted by auto
         qed
         moreover have "map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k+1)) cid)
                    = map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)"
         proof -
           have "\<forall>a. k+1 \<le> a \<and> a < j \<longrightarrow> ~ occurs_on (t ! a) = q" (is ?R)
           proof (rule ccontr)
             assume "~ ?R"
             then obtain a where "k+1 \<le> a" "a < j" and ocp: "occurs_on (t ! a) = q" by blast
             have "a < length t"
             proof -
               have "j < length t"
               proof (rule ccontr)
                 assume "~ j < length t"
                 then have "S t j = S t (j+1)" 
                   using assms(1) no_change_if_ge_length_t by auto
                 then show False using snap_q by auto
               qed
               then show ?thesis using \<open>a < j\<close> by simp
             qed
             then show False
             proof (cases "regular_event (t ! a)")
               case True
               have "~ has_snapshotted (S t a) q" 
                 by (meson \<open>a < j\<close> assms(1) computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_q(1))
               then have "prerecording_event t a" using \<open>a < length t\<close> ocp True prerecording_event by simp
               then show False using \<open>k+1 \<le> a\<close> \<open>k \<ge> i\<close> assms by auto
             next
               case False
               then have "(S t a) \<turnstile> (t ! a) \<mapsto> (S t (a+1))" 
                 using \<open>a < length t\<close> assms(1) step_Suc by auto
               then have "has_snapshotted (S t (a+1)) q" 
                 by (metis False ocp nonregular_event_induces_snapshot snapshot_state_unchanged)
               then show False 
                 by (metis Suc_eq_plus1 Suc_leI \<open>a < j\<close> assms(1) snap_q(1) snapshot_stable_ver_3)
             qed
           qed
           moreover have "Marker : set (msgs (S t (k+1)) cid)" 
             using chan \<open>map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k + 1)) cid) \<and> snd (cs (S t (k + 1)) cid) = NotStarted\<close> assms(1) cs_in_initial_state_implies_not_snapshotted marker_must_stay_if_no_snapshot snap_p(2) by blast
           moreover have "has_snapshotted (S t (k+1)) p" 
             using snap_p(2) by blast
           moreover have "~ has_snapshotted (S t (k+1)) q" 
             using chan \<open>map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k + 1)) cid) \<and> snd (cs (S t (k + 1)) cid) = NotStarted\<close> assms(1) cs_in_initial_state_implies_not_snapshotted by blast
           moreover have "k+1 \<le> j" 
             using \<open>k < j\<close> by auto
           moreover have "trace init t final" using assms by simp
           moreover have "snd (cs (S t (k+1)) cid) = NotStarted" 
             using \<open>map Msg (fst (cs (S t k) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (k + 1)) cid) \<and> snd (cs (S t (k + 1)) cid) = NotStarted\<close> by blast
           ultimately show ?thesis using cs_when_recording_3 chan by simp
         qed
         ultimately show ?thesis by simp
       next
         case False
         show ?thesis
         proof -
           have "has_snapshotted (S t i) p" 
             by (metis False Suc_eq_plus1 assms(1) not_less_eq_eq snap_p(2) snapshot_stable_ver_3)
           moreover have "~ has_snapshotted (S t i) q" 
             using nsq by auto
           moreover have "Marker : set (msgs (S t i) cid)" 
             using chan assms(1) calculation(1) marker_must_stay_if_no_snapshot nsq by blast
           moreover have "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = q" (is ?R)
           proof (rule ccontr)
             assume "~ ?R"
             then obtain k where "i \<le> k" "k < j" and ocp: "occurs_on (t ! k) = q" by blast
             have "k < length t"
             proof -
               have "j < length t"
               proof (rule ccontr)
                 assume "~ j < length t"
                 then have "S t j = S t (j+1)" 
                   using assms(1) no_change_if_ge_length_t by auto
                 then show False using snap_q by auto
               qed
               then show ?thesis using \<open>k < j\<close> by simp
             qed
             then show False
             proof (cases "regular_event (t ! k)")
               case True
               have "~ has_snapshotted (S t k) q" 
                 by (meson \<open>k < j\<close> assms(1) computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_q(1))
               then have "prerecording_event t k" using \<open>k < length t\<close> ocp True prerecording_event by simp
               then show False using \<open>i \<le> j\<close> \<open>k \<ge> i\<close> assms by auto
             next
               case False
               then have "(S t k) \<turnstile> (t ! k) \<mapsto> (S t (k+1))" 
                 using \<open>k < length t\<close> assms(1) step_Suc by auto
               then have "has_snapshotted (S t (k+1)) q" 
                 by (metis False ocp nonregular_event_induces_snapshot snapshot_state_unchanged)
               then show False 
                 by (metis Suc_eq_plus1 Suc_leI \<open>k < j\<close> assms(1) snap_q(1) snapshot_stable_ver_3)
             qed
           qed
           ultimately show ?thesis using cs_when_recording_3 
             using NotStarted assms(1) bound chan by auto
         qed
       qed
       moreover have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
                    = map Msg (fst (cs final cid))"
       proof (cases "\<exists>q p. t ! j = RecvMarker cid q p")
         case True
         then have "fst (cs (S t j) cid) = fst (cs (S t (j+1)) cid)" 
           using step_q by auto
         moreover have RecvMarker: "t ! j = RecvMarker cid q p"
         proof -
           have "can_occur (t ! j) (S t j)" using happen_implies_can_occur step_q by simp
           then show ?thesis 
             using RecvMarker_given_channel True chan by force
         qed
         moreover have "takeWhile ((\<noteq>) Marker) (msgs (S t j) cid) = []"
         proof -
           have "can_occur (t ! j) (S t j)" using happen_implies_can_occur step_q by simp
           then have "length (msgs (S t j) cid) > 0 \<and> hd (msgs (S t j) cid) = Marker"
             using RecvMarker can_occur_def by auto
           then show ?thesis 
             by (metis (mono_tags, lifting) hd_conv_nth length_greater_0_conv nth_mem set_takeWhileD takeWhile_nth)
         qed
         moreover have "snd (cs (S t (j+1)) cid) = Done" using step_q True by auto
         moreover have "cs (S t (j+1)) cid = cs final cid" using chan calculation cs_done_implies_same_snapshots assms(1) 
           by (metis final_is_s_t_len_t nat_le_linear no_change_if_ge_length_t)
         ultimately show ?thesis 
           by simp
       next
         case False
         have "~ regular_event (t ! j)" 
           using regular_event_preserves_process_snapshots snap_q(1) snap_q(2) step_q by auto
         then have "isSnapshot (t ! j) \<or> isRecvMarker (t ! j)" using nonregular_event by auto
         then have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
                  = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (j+1)) cid)
                  \<and> snd (cs (S t (j+1)) cid) = Recording"
         proof (elim disjE, goal_cases)
           case 1
           have Snapshot: "t ! j = Snapshot q" 
             using "1" oq by auto
           then have "msgs (S t j) cid = msgs (S t (j+1)) cid"
             using \<open>p \<noteq> q\<close> step_q chan by auto
           moreover have "cs (S t (j+1)) cid = (fst (cs (S t j) cid), Recording)"
             using step_q Snapshot chan by simp
           ultimately show ?thesis by simp
         next
           case 2
           obtain cid' r where RecvMarker: "t ! j = RecvMarker cid' q r" 
             by (metis "2" event.collapse(5) oq)
           have "cid \<noteq> cid'"
           proof (rule ccontr)
             assume "~ cid \<noteq> cid'"
             then have "channel cid = channel cid'" by simp
             then have "channel cid' = Some (r, q)" 
               using False RecvMarker \<open>\<not> cid \<noteq> cid'\<close> by blast
             then show False 
               using False RecvMarker \<open>\<not> cid \<noteq> cid'\<close> by blast
           qed
           then have "msgs (S t j) cid = msgs (S t (j+1)) cid"
             using \<open>cid \<noteq> cid'\<close> step_q snap_q RecvMarker chan \<open>p \<noteq> q\<close> by simp
           moreover have "cs (S t (j+1)) cid = (fst (cs (S t j) cid), Recording)"
             using \<open>p \<noteq> q\<close> \<open>cid \<noteq> cid'\<close>step_q snap_q RecvMarker chan by auto
           ultimately show ?thesis by simp
         qed
         moreover have "map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (j+1)) cid)
                      = map Msg (fst (cs final cid))"
         proof -
           have "snd (cs (S t (j+1)) cid) = Recording" 
             using calculation by blast
           moreover have "has_snapshotted (S t (j+1)) p" 
             by (metis Suc_eq_plus1 Suc_leI \<open>k < j\<close> assms(1) le_add1 snap_p(2) snapshot_stable_ver_3)
           moreover have "has_snapshotted (S t (j+1)) q" using snap_q by auto
           moreover have "j < length t" 
             by (metis (no_types, lifting) chan Suc_eq_plus1 assms(1) cs_done cs_done_implies_both_snapshotted(2) computation.no_change_if_ge_length_t computation.snapshot_stable_ver_3 computation_axioms leI le_Suc_eq snap_q(1) snap_q(2))
           ultimately show ?thesis using cs_when_recording assms(1) cs_done final_is_s_t_len_t
           proof -
             assume a1: "j < length t"
             assume a2: "trace init t final"
             assume a3: "snd (cs (S t (length t)) cid) = Done"
             assume a4: "snd (cs (S t (j + 1)) cid) = Recording"
             assume a5: "ps (S t (j + 1)) p \<noteq> None"
             assume a6: "\<And>t. trace init t final \<Longrightarrow> final = S t (length t)"
             assume a7: "\<And>i j t p cid q. \<lbrakk>i < j; j \<le> length t; trace init t final; ps (S t i) p \<noteq> None; snd (cs (S t i) cid) = Recording; snd (cs (S t j) cid) = Done; channel cid = Some (p, q)\<rbrakk> \<Longrightarrow> map Msg (fst (cs (S t j) cid)) = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)"
             have "Suc j < length t"
               using a3 a2 a1 by (metis (no_types) False Suc_eq_plus1 Suc_lessI chan cs_done_implies_has_snapshotted done_only_from_recv_marker snap_q(1) step_q)
             then show ?thesis
               using a7 a6 a5 a4 a3 a2 by (metis (no_types) Suc_eq_plus1 chan nat_le_linear)
           qed
         qed
         ultimately show ?thesis by simp
       qed
       ultimately show ?thesis 
         by (metis (no_types, lifting) Nil_is_map_conv assms(1) assms(3) chan cs_done cs_done_implies_has_snapshotted cs_not_nil_implies_postrecording_event nat_le_linear nsq self_append_conv2 snapshot_stable_ver_3)
     qed
   next
     case Recording
     then obtain j where snap_p: "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" 
       by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) 
     have snap_q: "has_snapshotted (S t i) q" 
       using Recording assms(1) chan cs_recording_implies_snapshot by blast
     have fst_cs_empty: "cs (S t i) cid = ([], Recording)" (is ?P)
     proof (rule ccontr)
       assume "~ ?P"
       have "snd (cs (S t i) cid) = Recording" using Recording by simp
       moreover have "fst (cs (S t i) cid) \<noteq> []" using \<open>~ ?P\<close> prod.collapse calculation by metis
       ultimately have "\<exists>j. j < i \<and> postrecording_event t j" 
         using assms(1) assms(4) chan cs_not_nil_implies_postrecording_event by blast
       then show False using assms by auto
     qed
     then show ?thesis
     proof -
       have i_less_len_t: "i < length t"
       proof (rule ccontr)
         assume "~ i < length t"
         then have "snd (cs (S t i) cid) = Done" 
           by (metis assms(1) cs_done le_eq_less_or_eq nat_le_linear no_change_if_ge_length_t)
         then show False using Recording by simp
       qed
       then have "map Msg (fst (cs final cid))
           = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)"
       proof (cases "j < i")
         case True
         then have "has_snapshotted (S t i) p" 
           by (metis Suc_eq_plus1 Suc_leI assms(1) snap_p(2) snapshot_stable_ver_3)
         moreover have "length t \<le> length t" by simp
         ultimately show ?thesis 
           using Recording chan assms(1) cs_done cs_when_recording final_is_s_t_len_t i_less_len_t by blast
       next
         case False
         text \<open>need to show that next message that comes into the channel must be marker\<close>
         have "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ occurs_on (t ! k) = p" (is ?P)
         proof (rule ccontr)
           assume "~ ?P"
           then obtain k where "i \<le> k" "k < j" "occurs_on (t ! k) = p" by blast
           then show False
           proof (cases "regular_event (t ! k)")
             case True
             then have "prerecording_event t k" 
               by (metis (no_types, hide_lams) \<open>k < j\<close> \<open>occurs_on (t ! k) = p\<close> all_processes_snapshotted_in_final_state assms(1) final_is_s_t_len_t computation.prerecording_event computation_axioms less_trans nat_le_linear not_less snap_p(1) snapshot_stable_ver_2)
             then show ?thesis using assms \<open>i \<le> k\<close> by auto
           next
             case False
             then have step_k: "(S t k) \<turnstile> (t ! k) \<mapsto> (S t (Suc k))" 
               by (metis (no_types, lifting) Suc_leI \<open>k < j\<close> all_processes_snapshotted_in_final_state assms(1) final_is_s_t_len_t le_Suc_eq less_imp_Suc_add linorder_not_less no_change_if_ge_length_t snap_p(1) step_Suc)
             then have "has_snapshotted (S t (Suc k)) p" 
               by (metis False \<open>occurs_on (t ! k) = p\<close> nonregular_event_induces_snapshot snapshot_state_unchanged)
             then have "k \<ge> j" 
               by (metis Suc_leI \<open>k < j\<close> assms(1) snap_p(1) snapshot_stable_ver_3)
             then show False using \<open>k < j\<close> by simp
           qed
         qed
         moreover have "~ has_snapshotted (S t i) p" 
           using False assms(1) snap_p(1) snapshot_stable_ver_3 by auto
         ultimately have to_snapshot: "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
                        = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t i) cid)"
           using False chan Recording assms(1) cs_when_recording_2 by auto
         have step_j: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
           by (metis Suc_eq_plus1 Suc_le_eq assms(1) distributed_system.step_Suc distributed_system_axioms computation.no_change_if_ge_length_t computation_axioms le_add1 not_less_eq_eq snap_p(1) snap_p(2))
         then have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t j) cid)
                  = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (j+1)) cid)"
         proof -
           have o: "~ regular_event (t ! j) \<and> occurs_on (t ! j) = p"
             by (metis (no_types, hide_lams) distributed_system.no_state_change_if_no_event distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(1) snap_p(2) step_j)
           then show ?thesis
             using chan snapshot_step_cs_preservation_p step_j by blast
         qed
         moreover have "map Msg (fst (cs final cid))
            = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\<noteq>) Marker) (msgs (S t (j+1)) cid)"
         proof -
           have "snd (cs (S t (j+1)) cid) = Recording"
           proof -
             have f1: "ps (S t j) p = None"
               by (meson snap_p(1))
             then have f2: "j < length t"
               by (metis (no_types) all_processes_snapshotted_in_final_state assms(1) final_is_s_t_len_t linorder_not_le snapshot_stable_ver_3)
             have "t ! j \<noteq> RecvMarker cid q p"
               using f1 by (metis (no_types) Suc_eq_plus1 assms(1) recv_marker_means_snapshotted step_j)
             then show ?thesis
               using f2 f1 by (meson False assms(1) chan cs_done_implies_both_snapshotted(1) cs_in_initial_state_implies_not_snapshotted cs_not_not_started_stable done_only_from_recv_marker linorder_not_le recording_state.exhaust snap_q snapshot_stable_ver_3 step_j)
           qed
           moreover have "j+1 < length t"
           proof (rule ccontr)
             assume "~ j+1 < length t"
             then have "snd (cs (S t (j+1)) cid) = Done"
               by (metis assms(1) cs_done le_Suc_eq less_imp_Suc_add linorder_not_le no_change_if_ge_length_t)
             then show False using calculation by auto
           qed
           ultimately show ?thesis
             using chan snap_p(2) assms final_is_s_t_len_t cs_when_recording cs_done by blast
         qed
         ultimately show ?thesis using to_snapshot by simp
       qed
       then show ?thesis using fst_cs_empty by simp
     qed
   next
     case Done
     text \<open>msgs must be empty, and cs must also be empty\<close>
     have fst_cs_empty: "fst (cs (S t i) cid) = []"
     proof (rule ccontr)
       assume "~ fst (cs (S t i) cid) = []" 
       then have "fst (cs (S t 0) cid) \<noteq> fst (cs (S t i) cid)" 
         by (metis chan assms(1) cs_not_nil_implies_postrecording_event gr_implies_not0 le0)
       then have "\<exists>j. j < i \<and> postrecording_event t j" 
         using chan \<open>fst (cs (S t i) cid) \<noteq> []\<close> assms(1) assms(4) cs_not_nil_implies_postrecording_event by blast
       then show False using assms by auto
     qed
     moreover have "msgs (S t i) cid = []"
     proof -
       have no_marker: "Marker \<notin> set (msgs (S t i) cid)" (is ?P)
       proof (rule ccontr)
         assume "~ ?P"
         then have "Marker : set (msgs (S t i) cid)" by simp
         then have "snd (cs (S t i) cid) \<noteq> Done" 
           by (metis Marker_in_channel_implies_not_done chan assms(1) nat_le_linear s_def take_all)
         then show False using Done by simp
       qed
       have snap_both: "has_snapshotted (S t i) p \<and> has_snapshotted (S t i) q" 
         by (metis chan Done assms(1) cs_done_implies_both_snapshotted(1) cs_done_implies_has_snapshotted final_is_s_t_len_t computation.all_processes_snapshotted_in_final_state computation_axioms le_refl not_less s_def take_all)
       obtain j where snap_p: "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" 
         by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p)
       have "j < i" 
         by (meson assms(1) not_le_imp_less snap_both snap_p(1) snapshot_stable_ver_2)
       have step_j: "(S t j) \<turnstile> (t ! j) \<mapsto> (S t (j+1))" 
         by (metis Suc_eq_plus1 assms(1) distributed_system.step_Suc distributed_system_axioms computation.no_change_if_ge_length_t computation_axioms le_add1 linorder_not_less snap_p(1) snap_p(2))
       have nonreg_j: "~ regular_event (t ! j)" 
         by (meson distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(1) snap_p(2) step_j)
       have oc_j: "occurs_on (t ! j) = p" 
         using no_state_change_if_no_event snap_p(1) snap_p(2) step_j by force
       have "msgs (S t i) cid = [] \<or> (msgs (S t i) cid \<noteq> [] \<and> last (msgs (S t i) cid) = Marker)"
       proof -
         have "msgs (S t (j+1)) cid \<noteq> [] \<and> last (msgs (S t (j+1)) cid) = Marker"
         proof -
           have "msgs (S t (j+1)) cid = msgs (S t j) cid @ [Marker]"
           proof -
             have "isSnapshot (t ! j) \<or> isRecvMarker (t ! j)" using nonregular_event nonreg_j by blast
             then show ?thesis
             proof (elim disjE, goal_cases)
               case 1
               then have "t ! j = Snapshot p" using oc_j by auto
               then show ?thesis using step_j chan by auto
             next
               case 2
               then obtain cid' r where RecvMarker: "t ! j = RecvMarker cid' p r" 
                 by (metis event.collapse(5) oc_j)
               have "cid \<noteq> cid'"
               proof (rule ccontr)
                 assume "~ cid \<noteq> cid'"
                 then have "channel cid = channel cid'" by auto
                 then have "Some (p, q) = Some (r, p)" 
                   by (metis RecvMarker RecvMarker_implies_Marker_in_set assms(1) chan computation.no_marker_if_no_snapshot computation_axioms snap_p(1) step_j)
                 then show False using no_self_channel chan by simp
               qed
               then show ?thesis using oc_j snap_p step_j chan RecvMarker by auto
             qed
           qed
           then show ?thesis by auto
         qed
         moreover have "i \<le> length t" using assms by simp
         moreover have "j+1 \<le> i" using \<open>j < i\<close> by simp
         moreover have "\<forall>k. j+1 \<le> k \<and> k < i \<and> regular_event (t ! k) \<longrightarrow> ~ occurs_on (t ! k) = p" (is ?R)
         proof (rule ccontr)
           assume "~ ?R"
           then obtain k where range: "j+1 \<le> k" "k < i" and "regular_event (t ! k)" "occurs_on (t ! k) = p"
             by blast
           then have "postrecording_event t k" using snap_p 
             by (meson assms(1) calculation(2) le_trans linorder_not_less pre_if_regular_and_not_post prerecording_event snapshot_stable_ver_2)
           then show False using assms range by auto
         qed
         ultimately show ?thesis 
           using assms(1) chan last_unchanged_or_empty_if_no_events snap_p(2) by auto
       qed
       then show ?thesis using no_marker last_in_set by fastforce
     qed
     ultimately show ?thesis 
       using chan Done assms(1) assms(4) final_is_s_t_len_t computation.cs_done_implies_same_snapshots computation_axioms by fastforce
   qed
   ultimately show "filter ((\<noteq>) Marker) (msgs (S t i) cid) = map Msg (fst (cs final cid))" by simp
 qed
 
 lemma snapshot_after_all_prerecording_events:
   assumes
     "trace init t final" and
     "\<forall>i'. i' \<ge> i \<longrightarrow> ~ prerecording_event t i'" and
     "\<forall>j'. j' < i \<longrightarrow> ~ postrecording_event t j'" and
     "i \<le> length t"
   shows
     "state_equal_to_snapshot (S t i) final"
 proof (unfold state_equal_to_snapshot_def, rule conjI)
   show "ps_equal_to_snapshot (S t i) final"
     using assms ps_after_all_prerecording_events by auto
   show "cs_equal_to_snapshot (S t i) final"
     using assms cs_after_all_prerecording_events by auto
 qed
 
 subsection \<open>Obtaining the desired traces\<close>
 
 abbreviation all_prerecording_before_postrecording where
   "all_prerecording_before_postrecording t \<equiv> \<exists>i. (\<forall>j. j < i \<longrightarrow> ~ postrecording_event t j)
                                                \<and> (\<forall>j. j \<ge> i \<longrightarrow> ~ prerecording_event t j)
                                                \<and> i \<le> length t
                                                \<and> trace init t final"
 
 definition count_violations :: "('a, 'b, 'c) trace \<Rightarrow> nat" where
   "count_violations t = sum (\<lambda>i. if postrecording_event t i
                                  then card {j \<in> {i+1..<length t}. prerecording_event t j}
                                  else 0)
                         {0..<length t}"
 
 lemma violations_ge_0:
   shows
     "(if postrecording_event t i
      then card {j \<in> {i+1..<length t}. prerecording_event t j}
      else 0) \<ge> 0"
   by simp
 
 lemma count_violations_ge_0:
   shows
     "count_violations t \<ge> 0"
   by simp
 
 lemma violations_0_implies_all_subterms_0:
   assumes
     "count_violations t = 0"
   shows
     "\<forall>i \<in> {0..<length t}. (if postrecording_event t i
                                  then card {j \<in> {i+1..<length t}. prerecording_event t j}
                                  else 0) = 0"
 proof -
   have "sum (\<lambda>i. if postrecording_event t i
                                  then card {j \<in> {i+1..<length t}. prerecording_event t j}
                                  else 0)
         {0..<length t} = 0" using count_violations_def assms by simp
   then show "\<forall>i \<in> {0..<length t}. (if postrecording_event t i
                                  then card {j \<in> {i+1..<length t}. prerecording_event t j}
                                  else 0) = 0"
     by auto
 qed
 
 lemma exists_postrecording_violation_if_count_greater_0:
   assumes
     "count_violations t > 0"
   shows
     "\<exists>i. postrecording_event t i \<and> card {j \<in> {i+1..<length t}. prerecording_event t j} > 0" (is ?P)
 proof (rule ccontr)
   assume "~ ?P"
   then have "\<forall>i. ~ postrecording_event t i \<or> card {j \<in> {i+1..<length t}. prerecording_event t j} = 0" by simp
   have "count_violations t = 0"
   proof (unfold count_violations_def)
     have "\<forall>i. (if postrecording_event t i
              then card {j \<in> {i+1..<length t}. prerecording_event t j}
              else 0) = 0"
       using \<open>\<forall>i. \<not> postrecording_event t i \<or> card {j \<in> {i + 1..<length t}. prerecording_event t j} = 0\<close> by auto
     then show "sum (\<lambda>i. if postrecording_event t i
                           then card {j \<in> {i+1..<length t}. prerecording_event t j}
                           else 0) {0..<length t} = 0" by simp
   qed
   then show False using assms by simp
 qed
 
 lemma exists_prerecording_violation_when_card_greater_0:
   assumes
     "card {j \<in> {i+1..<length t}. prerecording_event t j} > 0"
   shows
     "\<exists>j \<in> {i+1..<length t}. prerecording_event t j" 
   by (metis (no_types, lifting) Collect_empty_eq assms card_0_eq empty_subsetI finite_atLeastLessThan not_gr_zero subset_card_intvl_is_intvl)
 
 lemma card_greater_0_if_post_after_pre:
   assumes
     "i < j" and
     "postrecording_event t i" and
     "prerecording_event t j"
   shows
     "card {j \<in> {i+1..<length t}. prerecording_event t j} > 0"
 proof -
   have "j < length t" using prerecording_event assms by auto
   have "{j \<in> {i+1..<length t}. prerecording_event t j} \<noteq> empty" 
     using Suc_eq_plus1 \<open>j < length t\<close> assms(1) assms(3) less_imp_triv by auto
   then show ?thesis by fastforce
 qed
 
 lemma exists_neighboring_violation_pair:
   assumes
     "trace init t final" and
     "count_violations t > 0"
   shows
     "\<exists>i j. i < j \<and> postrecording_event t i \<and> prerecording_event t j
          \<and> (\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)) \<and> j < length t"
 proof -
   let ?I = "{i. postrecording_event t i \<and> card {j \<in> {i+1..<length t}. prerecording_event t j} > 0}"
   have nonempty_I: "?I \<noteq> empty" using assms exists_postrecording_violation_if_count_greater_0 by blast
   have fin_I: "finite ?I"
   proof (rule ccontr)
     assume "~ finite ?I"
     then obtain i where "i > length t" "postrecording_event t i" 
       by (simp add: postrecording_event)
     then show False using postrecording_event by simp
   qed
   let ?i = "Max ?I"
   have no_greater_postrec_violation: "\<forall>i. i > ?i \<longrightarrow> ~ (postrecording_event t i \<and> card {j \<in> {i+1..<length t}. prerecording_event t j} > 0)"
     using Max_gr_iff fin_I by blast
   have post_i: "postrecording_event t ?i" 
     using Max_in fin_I nonempty_I by blast
   have "card {j \<in> {?i+1..<length t}. prerecording_event t j} > 0"
   proof -
     have "?i \<in> ?I" 
       using Max_in fin_I nonempty_I by blast
     then show ?thesis by simp
   qed
   let ?J = "{j \<in> {?i+1..<length t}. prerecording_event t j}"
   have nonempty_J: "?J \<noteq> empty"
     using \<open>card {j \<in> {?i+1..<length t}. prerecording_event t j} > 0\<close> exists_prerecording_violation_when_card_greater_0
     by blast
   have fin_J: "finite ?J" by auto
   let ?j = "Min ?J"
   have pre_j: "prerecording_event t ?j"
     using Min_in fin_J nonempty_J by blast
   have no_smaller_prerec_violation: "\<forall>j \<in> {?i+1..<length t}. j < ?j \<longrightarrow> ~ prerecording_event t j" 
     using Min_less_iff fin_J by blast
   have j_less_len_t: "?j < length t"
     using pre_j prerecording_event by blast
   have "\<forall>k. (?i < k \<and> k < ?j) \<longrightarrow> ~ regular_event (t ! k)"
   proof (rule allI, rule impI)
     fix k
     assume asm: "?i < k \<and> k < ?j"
     then show "~ regular_event (t ! k)"
     proof -
       have "0_le_k": "0 \<le> k" by simp
       have k_less_len_t: "k < length t" using j_less_len_t asm by auto
       show ?thesis
       proof (rule ccontr)
         assume reg_event: "~ ~ regular_event (t ! k)"
         then show False
         proof (cases "has_snapshotted (S t k) (occurs_on (t ! k))")
           case True
           then have post_k: "postrecording_event t k" using reg_event k_less_len_t postrecording_event by simp
           moreover have "card {j \<in> {k+1..<length t}. prerecording_event t j} > 0"
             using post_k pre_j card_greater_0_if_post_after_pre asm pre_j by blast
           ultimately show False using no_greater_postrec_violation asm by blast
         next
           case False
           then have pre_k: "prerecording_event t k" using reg_event k_less_len_t prerecording_event by simp
           moreover have "k \<in> {?i+1..<length t}" using asm k_less_len_t by simp
           ultimately show False using no_smaller_prerec_violation asm by blast
         qed
       qed
     qed
   qed
   moreover have "?i < ?j" using nonempty_J by auto
   ultimately show ?thesis using pre_j post_i j_less_len_t by blast
 qed
 
 lemma same_cardinality_post_swap_1:
   assumes
     "prerecording_event t j" and
     "postrecording_event t i" and
     "i < j" and
     "j < length t" and
     "count_violations t = Suc n" and
     "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     "trace init t final"
   shows
     "{k \<in> {0..<i}. prerecording_event t k}
    = {k \<in> {0..<i}. prerecording_event (swap_events i j t) k}"
 proof -
   let ?t = "swap_events i j t"
   have same_begin: "take i t = take i ?t" using swap_identical_heads assms by blast
   have same_length: "length t = length (swap_events i j t)" using swap_identical_length assms by blast
   have a: "\<forall>k. k < i \<longrightarrow> t ! k = ?t ! k" 
     by (metis nth_take same_begin)
   then have "\<forall>k. k < i \<longrightarrow> prerecording_event t k = prerecording_event ?t k"
   proof -
     have "\<forall>k. k < i \<longrightarrow> S t k = S ?t k" using assms swap_events by simp
     then show ?thesis unfolding prerecording_event using a same_length by presburger
   qed
   then show ?thesis by auto
 qed
 
 lemma same_cardinality_post_swap_2:
   assumes
     "prerecording_event t j" and
     "postrecording_event t i" and
     "i < j" and
     "j < length t" and
     "count_violations t = Suc n" and
     "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     "trace init t final"
   shows
     "card {k \<in> {i..<j+1}. prerecording_event t k}
    = card {k \<in> {i..<j+1}. prerecording_event (swap_events i j t) k}"
 proof -
   let ?t = "swap_events i j t"
   have "card {k \<in> {i..<j+1}. prerecording_event t k} = 1"
   proof -
     have "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> ~ prerecording_event t k"
     proof (rule allI, rule impI)
       fix k
       assume asm: "i \<le> k \<and> k < j"
       then show "~ prerecording_event t k"
       proof (cases "k = i")
         case True
         then have "postrecording_event t k" using assms by simp
         then show ?thesis 
           by (meson computation.postrecording_event computation.prerecording_event computation_axioms)
       next
         case False
         then have "i < k \<and> k < j" using asm by force
         then have "~ regular_event (t ! k)" using assms by simp
         then show ?thesis unfolding prerecording_event by simp
       qed
     qed
     then have "{k \<in> {i..<j}. prerecording_event t k} = empty" by simp
     moreover have "{k \<in> {j..<j+1}. prerecording_event t k} = {j}"
     proof -
       have "{j..<j+1} = {j}" by auto
       moreover have "prerecording_event t j" using assms by simp
       ultimately show ?thesis by blast
     qed
     ultimately have "{k \<in> {i..<j+1}. prerecording_event t k} = {j}" using assms(3-4) by auto
     then show ?thesis by simp
   qed
   moreover have "card {k \<in> {i..<j+1}. prerecording_event ?t k} = 1"
   proof -
     have swap_ind: "prerecording_event ?t i
           \<and> postrecording_event ?t (i+1)
           \<and> (\<forall>k. k > i+1 \<and> k < j+1 \<longrightarrow> ~ regular_event (?t ! k))"
       using assms swap_events by blast
     have "\<forall>k. i+1 \<le> k \<and> k < j+1 \<longrightarrow> ~ prerecording_event ?t k"
     proof (rule allI, rule impI)
       fix k
       assume asm: "i+1 \<le> k \<and> k < j+1"
       then show "~ prerecording_event ?t k"
       proof (cases "k = i+1")
         case True
         then have "postrecording_event ?t k" using swap_ind by blast
         then show ?thesis 
           by (meson computation.postrecording_event computation.prerecording_event computation_axioms)
       next
         case False
         then have "i+1 < k \<and> k < j+1" using asm by linarith
         then have "~ regular_event (?t ! k)" using asm assms swap_ind by blast
         then show ?thesis unfolding prerecording_event by simp
       qed
     qed
     then have "{k \<in> {i+1..<j+1}. prerecording_event ?t k} = empty" by simp
     moreover have "{k \<in> {i..<i+1}. prerecording_event ?t k} = {i}"
     proof -
       have "{i..<i+1} = {i}" by simp
       moreover have "prerecording_event ?t i" using swap_ind by blast
       ultimately show ?thesis by blast
     qed
     ultimately have "{k \<in> {i..<j+1}. prerecording_event ?t k} = {i}" using assms(3-4) by auto
     then show ?thesis by simp
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma same_cardinality_post_swap_3:
   assumes
     "prerecording_event t j" and
     "postrecording_event t i" and
     "i < j" and
     "j < length t" and
     "count_violations t = Suc n" and
     "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     "trace init t final"
   shows
     "{k \<in> {j+1..<length t}. prerecording_event t k}
    = {k \<in> {j+1..<length (swap_events i j t)}. prerecording_event (swap_events i j t) k}"
 proof -
   let ?t = "swap_events i j t"
   have "drop (j+1) t = drop (j+1) ?t" 
     using assms(3) assms(4) swap_identical_tails by blast
   have same_length: "length t = length ?t" using swap_identical_length assms by blast
   have a: "\<forall>k. j+1 \<le> k \<and> k < length t \<longrightarrow> ?t ! k = t ! k"
   proof (rule allI, rule impI)
    fix k
     assume "j+1 \<le> k \<and> k < length t"
     then have "?t ! k = drop (j+1) (swap_events i j t) ! (k-(j+1))" 
       by (metis (no_types, lifting) Suc_eq_plus1 Suc_leI assms(4) le_add_diff_inverse nth_drop same_length)
     moreover have "t ! k = drop (j+1) t ! (k-(j+1))" 
       using \<open>j + 1 \<le> k \<and> k < length t\<close> by auto
     ultimately have "drop (j+1) ?t ! (k-(j+1)) = drop (j+1) t ! (k-(j+1))"
       using assms swap_identical_tails by metis
     then show "?t ! k = t ! k" 
       using \<open>?t ! k = drop (j + 1) ?t ! (k - (j + 1))\<close> \<open>t ! k = drop (j + 1) t ! (k - (j + 1))\<close> by auto
   qed
   then have "\<forall>k. j+1 \<le> k \<and> k < length t \<longrightarrow> prerecording_event t k = prerecording_event ?t k"
   proof -
     have "\<forall>k. k \<ge> (j+1) \<longrightarrow> S t k = S ?t k" using assms swap_events by simp
     then show ?thesis unfolding prerecording_event using a by auto
   qed
   then have "{k \<in> {j+1..<length t}. prerecording_event t k}
            = {k \<in> {j+1..<length t}. prerecording_event ?t k}"
     by auto
   then show ?thesis using same_length by metis
 qed
 
 lemma card_ip1_to_j_is_1_in_normal_events:
   assumes
     "prerecording_event t j" and
     "postrecording_event t i" and
     "i < j" and
     "j < length t" and
     "count_violations t = Suc n" and
     "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     "count_violations t = Suc n" and
     "trace init t final"
   shows
     "card {k \<in> {i+1..<j+1}. prerecording_event t k} = 1"
 proof -
   have "\<forall>k. i < k \<and> k < j \<longrightarrow> ~ prerecording_event t k"
   proof (rule allI, rule impI)
     fix k
     assume asm: "i < k \<and> k < j"
     then show "~ prerecording_event t k"
     proof -
       have "~ regular_event (t ! k)" using asm assms by blast
       then show ?thesis unfolding prerecording_event by simp
     qed
   qed
   then have "{k \<in> {i+1..<j}. prerecording_event t k} = empty" by auto
   moreover have "{k \<in> {j..<j+1}. prerecording_event t k} = {j}"
   proof -
     have "{j..<j+1} = {j}" by auto
     moreover have "prerecording_event t j" using assms by simp
     then show ?thesis by auto
   qed
   ultimately have "{k \<in> {i+1..<j+1}. prerecording_event t k} = {j}" using assms by auto
   then show ?thesis by simp
 qed
 
 lemma card_ip1_to_j_is_0_in_swapped_events:
   assumes
     "prerecording_event t j" and
     "postrecording_event t i" and
     "i < j" and
     "j < length t" and
     "count_violations t = Suc n" and
     "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     "count_violations t = Suc n" and
     "trace init t final"
   shows
     "card {k \<in> {i+1..<j+1}. prerecording_event (swap_events i j t) k} = 0"
 proof -
   let ?t = "swap_events i j t"
   have postrec_ip1: "postrecording_event ?t (i+1)" using assms swap_events by blast
   have neigh_shift: "\<forall>k. i+1 < k \<and> k < j+1 \<longrightarrow> ~ regular_event (?t ! k)" using assms swap_events by blast
   have "\<forall>k. i+1 \<le> k \<and> k < j+1 \<longrightarrow> ~ prerecording_event ?t k"
   proof (rule allI, rule impI)
     fix k
     assume asm: "i+1 \<le> k \<and> k < j+1"
     then show "~ prerecording_event ?t k"
     proof (cases "k = i+1")
       case True
       then show ?thesis using postrec_ip1 
         by (meson computation.postrecording_event computation.prerecording_event computation_axioms)
     next
       case False
       then have "i+1 < k \<and> k < j+1" using asm by simp
       then have "~ regular_event (?t ! k)" using neigh_shift by blast
       then show ?thesis unfolding prerecording_event by simp
     qed
   qed
   then have "{k \<in> {i+1..<j+1}. prerecording_event ?t k} = empty" by auto
   then show ?thesis by simp
 qed
 
 lemma count_violations_swap:
   assumes
     "prerecording_event t j" and
     "postrecording_event t i" and
     "i < j" and
     "j < length t" and
     "count_violations t = Suc n" and
     "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)" and
     "count_violations t = Suc n" and
     "trace init t final"
   shows
     "count_violations (swap_events i j t) = n"
 proof -
   let ?t = "swap_events i j t"
   let ?f = "(\<lambda>i. if postrecording_event t i then card {j \<in> {i+1..<length t}. prerecording_event t j} else 0)"
   let ?f' = "(\<lambda>i. if postrecording_event ?t i then card {j \<in> {i+1..<length ?t}. prerecording_event ?t j} else 0)"
   have same_postrec_prefix: "\<forall>k. k < i \<longrightarrow> postrecording_event t k = postrecording_event ?t k"
   proof -
     have "\<forall>k. k < i \<longrightarrow> S t k = S ?t k" using assms swap_events by auto
     then show ?thesis unfolding postrecording_event
     proof -
       assume a1: "\<forall>k<i. S t k = S (swap_events i j t) k"
       { fix nn :: nat
         have "\<And>n na es nb. \<not> n < na \<or> \<not> na < length es \<or> \<not> nb < n \<or> swap_events n na es ! nb = (es ! nb::('a, 'b, 'c) event)"
           by (metis (no_types) nth_take swap_identical_heads)
         then have "\<not> nn < i \<or> \<not> nn < length t \<and> \<not> nn < length (swap_events i j t) \<or> \<not> regular_event (t ! nn) \<and> \<not> regular_event (swap_events i j t ! nn) \<or> ps (S t nn) (occurs_on (t ! nn)) = None \<and> ps (S (swap_events i j t) nn) (occurs_on (swap_events i j t ! nn)) = None \<or> regular_event (t ! nn) \<and> regular_event (swap_events i j t ! nn) \<and> nn < length t \<and> nn < length (swap_events i j t) \<and> ps (S t nn) (occurs_on (t ! nn)) \<noteq> None \<and> ps (S (swap_events i j t) nn) (occurs_on (swap_events i j t ! nn)) \<noteq> None"
           using a1 by (metis (no_types) assms(3) assms(4) swap_identical_length) }
       then show "\<forall>n<i. (n < length t \<and> regular_event (t ! n) \<and> ps (S t n) (occurs_on (t ! n)) \<noteq> None) = (n < length (swap_events i j t) \<and> regular_event (swap_events i j t ! n) \<and> ps (S (swap_events i j t) n) (occurs_on (swap_events i j t ! n)) \<noteq> None)"
         by (metis (no_types))
     qed
   qed
   have same_postrec_suffix: "\<forall>k. k \<ge> j+1 \<longrightarrow> postrecording_event t k = postrecording_event ?t k"
   proof -
     have post_equal_states: "\<forall>k. k \<ge> j+1 \<longrightarrow> S t k = S ?t k" using assms swap_events by presburger
     show ?thesis
     proof (rule allI, rule impI)
       fix k
       assume "j+1 \<le> k"
       then show "postrecording_event t k = postrecording_event ?t k"
       proof (cases "k < length t")
         case False
         then have "~ postrecording_event t k" using postrecording_event by simp
         moreover have "~ postrecording_event ?t k"
           using postrecording_event swap_identical_length False assms by metis
         ultimately show ?thesis by simp
       next
         case True
         then show "postrecording_event t k = postrecording_event ?t k"
           using post_equal_states
         proof -
           assume a1: "\<forall>k\<ge>j + 1. S t k = S (swap_events i j t) k"
           assume a2: "k < length t"
           have f3: "length t = length (swap_events i j t)"
             using assms(3) assms(4) swap_identical_length by blast
           have f4: "k - (j + 1) + (j + 1) = k"
             using \<open>j + 1 \<le> k\<close> le_add_diff_inverse2 by blast
           have "drop (j + 1) t = drop (j + 1) (swap_events i j t)"
             using assms(3) assms(4) swap_identical_tails by blast
           then have "swap_events i j t ! k = t ! k"
             using f4 f3 a2 by (metis (no_types) drop_drop hd_drop_conv_nth)
           then show ?thesis
             using f3 a1 \<open>j + 1 \<le> k\<close> postrecording_event by presburger
         qed
       qed
     qed
   qed
 
   have sum_decomp_f: "sum ?f {0..<length t} = sum ?f {0..<i} + sum ?f {i..<j+1} + sum ?f {j+1..<length t}"
     by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right assms(3) assms(4) discrete le_add2 less_SucI less_or_eq_imp_le sum.atLeastLessThan_concat)
   have sum_decomp_f': "sum ?f' {0..<length t} = sum ?f' {0..<i} + sum ?f' {i..<j+1} + sum ?f' {j+1..<length t}"
     by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right assms(3) assms(4) discrete le_add2 less_SucI less_or_eq_imp_le sum.atLeastLessThan_concat)
 
   have prefix_sum: "sum ?f {0..<i} = sum ?f' {0..<i}"
   proof -
     have "\<forall>l. 0 \<le> l \<and> l < i \<longrightarrow> ?f l = ?f' l"
     proof (rule allI, rule impI)
       fix l
       assume "0 \<le> l \<and> l < i"
       then have "l < i" by simp
       show "?f l = ?f' l"
       proof (cases "postrecording_event t l")
       case True
         let ?G = "{k \<in> {l+1..<length t}. prerecording_event t k}"
         let ?G' = "{k \<in> {l+1..<length t}. prerecording_event ?t k}"
         let ?A = "{k \<in> {l+1..<i}. prerecording_event t k}"
         let ?B = "{k \<in> {i..<j+1}. prerecording_event t k}"
         let ?C = "{k \<in> {j+1..<length t}. prerecording_event t k}"
         let ?A' = "{k \<in> {l+1..<i}. prerecording_event ?t k}"
         let ?B' = "{k \<in> {i..<j+1}. prerecording_event ?t k}"
         let ?C' = "{k \<in> {j+1..<length t}. prerecording_event ?t k}"
         have card_G: "card ?G = card ?A + card ?B + card ?C"
         proof -
           have "?G = ?A \<union> (?B \<union> ?C)" using assms \<open>l < i\<close> by auto
           then have "card ?G = card (?A \<union> (?B \<union> ?C))" by simp
           also have "card (?A \<union> (?B \<union> ?C)) = card ?A + card (?B \<union> ?C)"
           proof -
             have "?A \<inter> (?B \<union> ?C) = {}" using \<open>l < i\<close> assms by auto
             then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal)
           qed
           also have "card ?A + card (?B \<union> ?C) = card ?A + card ?B + card ?C"
           proof -
             have "?B \<inter> ?C = {}" by auto
             then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal)
           qed
           finally show ?thesis by simp
         qed
         have card_G': "card ?G' = card ?A' + card ?B' + card ?C'"
         proof -
           have "?G' = ?A' \<union> (?B' \<union> ?C')" using assms \<open>l < i\<close> by auto
           then have "card ?G' = card (?A' \<union> (?B' \<union> ?C'))" by simp
           also have "card (?A' \<union> (?B' \<union> ?C')) = card ?A' + card (?B' \<union> ?C')"
           proof -
             have "?A' \<inter> (?B' \<union> ?C') = {}" using \<open>l < i\<close> assms by auto
             then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal)
           qed
           also have "card ?A' + card (?B' \<union> ?C') = card ?A' + card ?B' + card ?C'"
           proof -
             have "?B' \<inter> ?C' = {}" by auto
             then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal)
           qed
           finally show ?thesis by simp
         qed
         have "card ?G = card ?G'"
         proof -
           have "card ?A = card ?A'"
           proof -
             have "{k \<in> {0..<i}. prerecording_event t k} = {k \<in> {0..<i}. prerecording_event ?t k}"
               using assms same_cardinality_post_swap_1 by blast
             then have "?A = ?A'" by auto
             then show ?thesis by simp
           qed
           moreover have "card ?B = card ?B'" using assms same_cardinality_post_swap_2 by blast
           moreover have "card ?C = card ?C'"
           proof -
             have "?C = ?C'" using assms same_cardinality_post_swap_3 by auto
             then show ?thesis by simp
           qed
           ultimately show ?thesis using card_G card_G' by linarith
         qed
         moreover have "postrecording_event ?t l" using True same_postrec_prefix \<open>l < i\<close> by blast
         moreover have "length ?t = length t" using assms(3) assms(4) by fastforce
         ultimately show ?thesis using True by presburger
       next
         case False
         then have "~ postrecording_event ?t l" using same_postrec_prefix \<open>l < i\<close> by blast
         then show ?thesis using False by simp
       qed
     qed
     then show ?thesis using sum_eq_if_same_subterms by auto
   qed
 
   have infix_sum: "sum ?f {i..<j+1} = sum ?f' {i..<j+1} + 1"
   proof -
     have sum_decomp_f: "sum ?f {i..<j+1} = sum ?f {i..<i+2} + sum ?f {i+2..<j+1}" 
       by (metis (no_types, lifting) Suc_eq_plus1 Suc_leI add_2_eq_Suc' assms(3) less_Suc_eq linorder_not_le sum.atLeastLessThan_concat)
     have sum_decomp_f': "sum ?f' {i..<j+1} = sum ?f' {i..<i+2} + sum ?f' {i+2..<j+1}" 
       by (metis (no_types, lifting) Suc_eq_plus1 Suc_mono add.assoc assms(3) discrete le_add1 one_add_one sum.atLeastLessThan_concat)
     have "sum ?f {i+2..<j+1} = sum ?f' {i+2..<j+1}"
     proof -
       have "\<forall>l. i+2 \<le> l \<and> l < j+1 \<longrightarrow> ?f l = ?f' l"
       proof (rule allI, rule impI)
         fix l
         assume asm: "i+2 \<le> l \<and> l < j+1"
         have "?f l = 0"
         proof (cases "l = j")
           case True
           then have "~ postrecording_event t l" 
             using assms(1) postrecording_event prerecording_event by auto
           then show ?thesis by simp
         next
           case False
           then have "i < l \<and> l < j" using assms asm by simp
           then have "~ regular_event (t ! l)" using assms by blast
           then have "~ postrecording_event t l" unfolding postrecording_event by simp
           then show ?thesis by simp
         qed
         moreover have "?f' l = 0"
         proof -
           have "\<forall>k. i+1 < k \<and> k < j+1 \<longrightarrow> ~ regular_event (?t ! k)" using assms swap_events by blast 
           then have "~ regular_event (?t ! l)" using asm by simp
           then have "~ postrecording_event ?t l" unfolding postrecording_event by simp
           then show ?thesis by simp
         qed
         ultimately show "?f l = ?f' l" by simp
       qed
       then show ?thesis using sum_eq_if_same_subterms by simp
     qed
 
     moreover have "sum ?f {i..<i+2} = 1 + sum ?f' {i..<i+2}"
     proof -
       have int_def: "{i..<i+2} = {i,i+1}" by auto
       then have "sum ?f {i,i+1} = ?f i + ?f (i+1)" by simp
       moreover have "sum ?f' {i,i+1} = ?f' i + ?f' (i+1)" using int_def by simp
 
       moreover have "?f (i+1) = 0"
       proof (cases "j = i+1")
         case True
         then have "prerecording_event t (i+1)" using assms by simp
         then have "~ postrecording_event t (i+1)"
           unfolding postrecording_event using prerecording_event by simp
         then show ?thesis by simp
       next
         case False
         then have "~ regular_event (t ! (i+1))" using assms by simp
         then have "~ postrecording_event t (i+1)" unfolding postrecording_event by simp
         then show ?thesis by simp
       qed
       moreover have "?f' i = 0"
       proof -
         have "prerecording_event ?t i" using assms swap_events by blast
         then have "~ postrecording_event ?t i"
           unfolding postrecording_event using prerecording_event by simp
         then show ?thesis by simp
       qed
       moreover have "?f i = ?f' (i+1) + 1"
       proof -
         have pi: "postrecording_event t i" using assms by simp
         moreover have pip1: "postrecording_event ?t (i+1)" using assms swap_events by blast
         let ?G = "{k \<in> {i+1..<length t}. prerecording_event t k}"
         let ?G' = "{k \<in> {i+2..<length ?t}. prerecording_event ?t k}"
         let ?A = "{k \<in> {i+1..<j+1}. prerecording_event t k}"
         let ?B = "{k \<in> {j+1..<length t}. prerecording_event t k}"
         let ?A' = "{k \<in> {i+2..<j+1}. prerecording_event ?t k}"
         let ?B' = "{k \<in> {j+1..<length ?t}. prerecording_event ?t k}"
         have card_G: "card ?G = card ?A + card ?B"
         proof -
           have "?G = ?A \<union> ?B" using assms by auto
           moreover have "?A \<inter> ?B = {}" by auto
           ultimately show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal)
         qed
         have card_G': "card ?G' = card ?A' + card ?B'"
         proof -
           have "?G' = ?A' \<union> ?B'" using assms by auto
           moreover have "?A' \<inter> ?B' = {}" by auto
           ultimately show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal)
         qed
         have "card ?G = card ?G' + 1"
         proof -
           have "card ?A = card ?A' + 1"
           proof -
             have "card ?A = 1" using assms card_ip1_to_j_is_1_in_normal_events by blast
             moreover have "card ?A' = 0" using assms card_ip1_to_j_is_0_in_swapped_events by force
             ultimately show ?thesis by algebra
           qed
           moreover have "card ?B = card ?B'" using assms same_cardinality_post_swap_3 by force
           ultimately show ?thesis using card_G card_G' by presburger
         qed
         moreover have "card ?G = ?f i" using pi by simp
         moreover have "card ?G' = ?f' (i+1)" using pip1 by simp
         ultimately show ?thesis by argo
       qed
       ultimately show ?thesis by auto
     qed
 
     ultimately show ?thesis using sum_decomp_f sum_decomp_f' by linarith
   qed
 
   have suffix_sum: "sum ?f {j+1..<length t} = sum ?f' {j+1..<length t}"
   proof -
     have "\<forall>l. l > j \<longrightarrow> ?f l = ?f' l"
     proof (rule allI, rule impI)
       fix l
       assume "l > j"
       then show "?f l = ?f' l"
       proof (cases "postrecording_event t l")
         case True
         let ?G = "{k \<in> {l+1..<length t}. prerecording_event t k}"
         let ?G' = "{k \<in> {l+1..<length t}. prerecording_event ?t k}"
         let ?C = "{k \<in> {j+1..<length t}. prerecording_event t k}"
         let ?C' = "{k \<in> {j+1..<length t}. prerecording_event ?t k}"
         have "card ?G = card ?G'"
         proof -
           have "?C = ?C'" using assms same_cardinality_post_swap_3 by auto
           then have "?G = ?G'" using \<open>l > j\<close> by fastforce
           then show ?thesis by simp
         qed
         moreover have "postrecording_event ?t l" using True same_postrec_suffix \<open>l > j\<close> by simp
         moreover have "length ?t = length t" using assms(3) assms(4) by fastforce
         ultimately show ?thesis using True by presburger
       next
         case False
         then have "~ postrecording_event ?t l" using same_postrec_suffix \<open>l > j\<close> by simp
         then show ?thesis using False by simp
       qed
     qed
     then have "\<forall>k. j+1 \<le> k \<and> k < length t \<longrightarrow> ?f k = ?f' k"
       using discrete by blast
     moreover have "length t = length ?t" 
       using assms(3) assms(4) swap_identical_length by blast
     ultimately show ?thesis by (blast intro:sum_eq_if_same_subterms)
   qed
   have "sum ?f {0..<length t} = sum ?f' {0..<length t} + 1"
   proof -
     have "sum ?f {0..<i} = sum ?f' {0..<i}" using prefix_sum by simp
     moreover have "sum ?f {i..<j+1} = sum ?f' {i..<j+1} + 1" using infix_sum by simp
     moreover have "sum ?f {j+1..<length t} = sum ?f' {j+1..<length t}" using suffix_sum by simp
     ultimately show ?thesis using sum_decomp_f sum_decomp_f' by presburger
   qed
   moreover have "length ?t = length t" 
     using assms(3) assms(4) by auto
   moreover have "sum ?f {0..<length t} = n + 1" using assms count_violations_def by simp
   ultimately have "sum ?f' {0..<length ?t} = n" by presburger
   then show ?thesis unfolding count_violations_def by presburger
 qed
 
 lemma desired_trace_always_exists:
   assumes
     "trace init t final"
   shows
     "\<exists>t'. perm t' t
         \<and> all_prerecording_before_postrecording t'"
 using assms proof (induct "count_violations t" arbitrary: t)
   case 0
   then show ?case
   proof (cases "\<exists>i. prerecording_event t i")
     case False
     then have "\<forall>j. ~ prerecording_event t j" by auto
     then have "\<forall>j. j \<le> 0 \<longrightarrow> ~ postrecording_event t j" 
       using "0.prems" init_is_s_t_0 no_initial_process_snapshot postrecording_event by auto
     moreover have "\<forall>j. j > 0 \<longrightarrow> ~ prerecording_event t j"  using False by auto
     moreover have "length t > 0" 
       by (metis "0.prems" all_processes_snapshotted_in_final_state length_greater_0_conv no_initial_process_snapshot tr_init trace_and_start_determines_end)
     ultimately show ?thesis using "0.prems" False by auto
   next
     case True
     let ?Is = "{i. prerecording_event t i}"
     have "?Is \<noteq> empty"
       by (simp add: True)
     moreover have fin_Is: "finite ?Is"
     proof (rule ccontr)
       assume "~ finite ?Is"
       then obtain i where "i > length t" "prerecording_event t i" 
         by (simp add: prerecording_event)
       then show False using prerecording_event by auto
     qed
     let ?i = "Max ?Is"
     have pi: "prerecording_event t ?i" 
       using Max_in calculation fin_Is by blast
     have "?i < length t"
     proof (rule ccontr)
       assume "~ ?i < length t"
       then show False 
         using calculation fin_Is computation.prerecording_event computation_axioms by force
     qed
     moreover have "\<forall>j. j \<ge> ?i+1 \<longrightarrow> ~ prerecording_event t j"
     proof -
       have "\<forall>j. j > ?i \<longrightarrow> ~ prerecording_event t j"
         using Max_less_iff fin_Is by auto
       then show ?thesis by auto
     qed
     moreover have "\<forall>j. j < ?i+1 \<longrightarrow> ~ postrecording_event t j"
     proof -
       have "\<forall>j. j \<le> ?i \<longrightarrow> ~ postrecording_event t j"
       proof (rule allI, rule impI, rule ccontr)
         fix j
         assume "j \<le> ?i" "~ ~ postrecording_event t j"
         then have "j < ?i" 
           by (metis add_diff_inverse_nat dual_order.antisym le_add1 pi postrecording_event prerecording_event)
         then have "count_violations t > 0"
         proof -
           have "(if postrecording_event t j
                    then card {l \<in> {j+1..<length t}. prerecording_event t l}
                    else 0) = card {l \<in> {j+1..<length t}. prerecording_event t l}"
             using \<open>~ ~ postrecording_event t j\<close> by simp
           moreover have "card {l \<in> {j+1..<length t}. prerecording_event t l} > 0"
           proof -
             have "j + 1 \<le> ?i \<and> ?i < length t" 
               using \<open>Max {i. prerecording_event t i} < length t\<close> \<open>j < Max {i. prerecording_event t i}\<close> discrete by blast
             moreover have "prerecording_event t ?i" using pi by simp
             ultimately have "{l \<in> {j+1..<length t}. prerecording_event t l} \<noteq> empty" by fastforce
             then show ?thesis by fastforce
           qed
           ultimately show ?thesis
             by (metis (no_types, lifting) violations_0_implies_all_subterms_0 \<open>Max {i. prerecording_event t i} < length t\<close> \<open>j < Max {i. prerecording_event t i}\<close> atLeastLessThan_iff less_trans linorder_not_le neq0_conv)
         qed
         then show False using "0" by simp
       qed
       then show ?thesis by auto
     qed
     moreover have "?i+1 \<le> length t" 
       using calculation(2) discrete by blast
     ultimately show ?thesis using "0.prems" by blast
   qed
 next
   case (Suc n)
   then obtain i j where ind: "postrecording_event t i" "prerecording_event t j"
                              "\<forall>k. (i < k \<and> k < j) \<longrightarrow> ~ regular_event (t ! k)"
                              "i < j" "j < length t" using exists_neighboring_violation_pair Suc by force
   then have "trace init (swap_events i j t) final
           \<and> (\<forall>k. k \<ge> j + 1 \<longrightarrow> S (swap_events i j t) k = S t k)
           \<and> (\<forall>k. k \<le> i \<longrightarrow> S (swap_events i j t) k = S t k)"
     using Suc swap_events by presburger
   moreover have "perm (swap_events i j t) t" using swap_events_perm ind by blast
   moreover have "count_violations (swap_events i j t) = n"
     using count_violations_swap Suc ind by simp
   ultimately show ?case using Suc.hyps by blast
 qed
 
 theorem snapshot_algorithm_is_correct:
   assumes
     "trace init t final"
   shows
     "\<exists>t' i. trace init t' final \<and> perm t' t
           \<and> state_equal_to_snapshot (S t' i) final \<and> i \<le> length t'"
 proof -
   obtain t' where "perm t' t" and
                   "all_prerecording_before_postrecording t'"
     using assms desired_trace_always_exists by blast
   then show ?thesis using snapshot_after_all_prerecording_events
     by blast
 qed
 
 subsection \<open>Stable property detection\<close>
 
 text \<open>Finally, we show that the computed snapshot is indeed
 suitable for stable property detection, as claimed in~\cite{chandy}.\<close>
 
 definition stable where
   "stable p \<equiv> (\<forall>c. p c \<longrightarrow> (\<forall>t c'. trace c t c' \<longrightarrow> p c'))"
 
 lemma has_snapshot_stable:
   assumes
     "trace init t final"
   shows
     "stable (\<lambda>c. has_snapshotted c p)" 
   using snapshot_stable stable_def by auto
 
 definition some_snapshot_state where
   "some_snapshot_state t \<equiv>
      SOME (t', i). trace init t final
                  \<and> trace init t' final \<and> perm t' t
                  \<and> state_equal_to_snapshot (S t' i) final"
 
 lemma split_S:
   assumes
     "trace init t final"
   shows
     "trace (S t i) (drop i t) final"
 proof -
   have "t = take i t @ drop i t" by simp
   then show ?thesis
     by (metis split_trace assms exists_trace_for_any_i
               trace_and_start_determines_end)
 qed
 
 theorem Stable_Property_Detection:
   assumes
     "stable p" and
     "trace init t final" and
     "(t', i) = some_snapshot_state t" and
     "p (S t' i)"
   shows
     "p final"
 proof -
   have "\<exists>t' i. trace init t final
              \<and> trace init t' final \<and> perm t' t
              \<and> state_equal_to_snapshot (S t' i) final"
     using snapshot_algorithm_is_correct assms(2) by blast
   then have "trace init t' final"
     using assms
     unfolding some_snapshot_state_def
     by (metis (lifting) case_prodD case_prodI someI_ex)
   then show ?thesis
     using assms stable_def split_S by metis
 qed
 
 end (* locale computation *)
 
 end (* theory Snapshot *)
diff --git a/thys/Chandy_Lamport/Util.thy b/thys/Chandy_Lamport/Util.thy
--- a/thys/Chandy_Lamport/Util.thy
+++ b/thys/Chandy_Lamport/Util.thy
@@ -1,363 +1,363 @@
 section \<open>Utilties\<close>
 
 theory Util
   imports
     Main
     "HOL-Library.Sublist"
-    "HOL-Library.Permutation"
+    "HOL-Library.List_Permutation"
 
 begin
 
 abbreviation swap_events where
   "swap_events i j t \<equiv> take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t) @ drop (j+1) t"
 
 lemma swap_neighbors_2:
   shows
     "i+1 < length t \<Longrightarrow> swap_events i (i+1) t = (t[i := t ! (i+1)])[i+1 := t ! i]"
 proof (induct i arbitrary: t)
   case 0
   then show ?case 
     by (metis One_nat_def Suc_eq_plus1 add_lessD1 append.left_neutral append_Cons cancel_comm_monoid_add_class.diff_cancel drop_update_cancel length_list_update numeral_One take_0 take_Cons_numeral upd_conv_take_nth_drop zero_less_Suc)
 next
   case (Suc n)
   let ?t = "tl t"
   have "t = hd t # ?t"
     by (metis Suc.prems hd_Cons_tl list.size(3) not_less_zero)
   moreover have "swap_events n (n+1) ?t = (?t[n := ?t ! (n+1)])[n+1 := ?t ! n]" 
     by (metis Suc.hyps Suc.prems Suc_eq_plus1 length_tl less_diff_conv)
   ultimately show ?case 
     by (metis Suc_eq_plus1 append_Cons diff_self_eq_0 drop_Suc_Cons list_update_code(3) nth_Cons_Suc take_Suc_Cons)
 qed
 
 lemma swap_identical_length:
   assumes
     "i < j" and
     "j < length t"
   shows
     "length t = length (swap_events i j t)"
 proof -
   have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t))
       = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))"
     by simp
   then have "... = j+1" 
     using assms(1) assms(2) by auto
   then show ?thesis using assms(2) by auto
 qed
 
 lemma swap_identical_heads:
   assumes
     "i < j" and
     "j < length t"
   shows
     "take i t = take i (swap_events i j t)"
   using assms by auto
 
 lemma swap_identical_tails:
   assumes
     "i < j" and
     "j < length t"
   shows
     "drop (j+1) t = drop (j+1) (swap_events i j t)"
 proof -
   have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t))
       = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))"
     by simp
   then have "... = j+1" 
     using assms(1) assms(2) by auto
   then show ?thesis 
     by (metis \<open>length (take i t @ [t ! j, t ! i] @ take (j - (i + 1)) (drop (i + 1) t)) = length (take i t) + length [t ! j, t ! i] + length (take (j - (i + 1)) (drop (i + 1) t))\<close> append.assoc append_eq_conv_conj)
 qed
 
 lemma swap_neighbors:
   shows
     "i+1 < length l \<Longrightarrow> (l[i := l ! (i+1)])[i+1 := l ! i] = take i l @ [l ! (i+1), l ! i] @ drop (i+2) l"
 proof (induct i arbitrary: l)
   case 0
   then show ?case 
     by (metis One_nat_def add.left_neutral add_lessD1 append_Cons append_Nil drop_update_cancel length_list_update one_add_one plus_1_eq_Suc take0 take_Suc_Cons upd_conv_take_nth_drop zero_less_two)
 next
   case (Suc n)
   let ?l = "tl l"
   have "(l[Suc n := l ! (Suc n + 1)])[Suc n + 1 := l ! Suc n] = hd l # (?l[n := ?l ! (n+1)])[n+1 := ?l ! n]"
     by (metis Suc.prems add.commute add_less_same_cancel2 list.collapse list.size(3) list_update_code(3) not_add_less2 nth_Cons_Suc plus_1_eq_Suc)
   have "n + 1 < length ?l" using Suc.prems by auto
   then have "(?l[n := ?l ! (n+1)])[n+1 := ?l ! n] = take n ?l @ [?l ! (n+1), ?l ! n] @ drop (n+2) ?l"
     using Suc.hyps by simp
   then show ?case
     by (cases l) auto
 qed
 
 lemma swap_events_perm:
   assumes
     "i < j" and
     "j < length t"
   shows
     "perm (swap_events i j t) t"
 proof -
   have swap: "swap_events i j t
       = take i t @ [t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t)) @ (drop (j+1) t)"
     by auto
   have reg: "t = take i t @ (take ((j+1) - i) (drop i t)) @ drop (j+1) t" 
     by (metis add_diff_inverse_nat add_lessD1 append.assoc append_take_drop_id assms(1) less_imp_add_positive less_not_refl take_add)
   have "perm (take i t) (take i t)" by simp
   moreover have "perm (drop (j+1) t) (drop (j+1) t)" by simp
   moreover have "perm ([t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t))) (take ((j+1) - i) (drop i t))"
   proof -
     let ?l = "take (j - (i+1)) (drop (i+1) t)"
     have "take ((j+1) - i) (drop i t) = t ! i # ?l @ [t ! j]"
     proof -
       have f1: "Suc (j - Suc i) = j - i"
         by (meson Suc_diff_Suc assms(1))
       have f2: "i < length t"
         using assms(1) assms(2) by linarith
       have f3: "j - (i + 1) + (i + 1) = j"
         by (meson assms(1) discrete le_add_diff_inverse2)
       then have "drop (j - (i + 1)) (drop (i + 1) t) = drop j t"
         by (metis drop_drop)
       then show ?thesis
         using f3 f2 f1 by (metis (no_types) Cons_nth_drop_Suc Suc_diff_le Suc_eq_plus1 assms(1) assms(2) hd_drop_conv_nth length_drop less_diff_conv nat_less_le take_Suc_Cons take_hd_drop)
     qed
     then show ?thesis using mset_eq_perm by fastforce
   qed
   ultimately show ?thesis using swap reg 
     by (metis append.assoc perm_append1 perm_append2)
 qed
 
 lemma sum_eq_if_same_subterms:
   fixes
     i :: nat
   shows
     "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> f k = f' k \<Longrightarrow> sum f {i..<j} = sum f' {i..<j}"
   by auto
 
 lemma filter_neq_takeWhile:
   assumes
     "filter ((\<noteq>) a) l \<noteq> takeWhile ((\<noteq>) a) l"
   shows
     "\<exists>i j. i < j \<and> j < length l \<and> l ! i = a \<and> l ! j \<noteq> a" (is ?P)
 proof (rule ccontr)
   assume "~ ?P"
   then have asm: "\<forall>i j. i < j \<and> j < length l \<longrightarrow> l ! i \<noteq> a \<or> l ! j = a" (is ?Q) by simp
   then have "filter ((\<noteq>) a) l = takeWhile ((\<noteq>) a) l"
   proof (cases "a : set l")
     case False
     then have "\<forall>i. i < length l \<longrightarrow> l ! i \<noteq> a" by auto
     then show ?thesis 
       by (metis (mono_tags, lifting) False filter_True takeWhile_eq_all_conv)
   next
     case True
     then have ex_j: "\<exists>j. j < length l \<and> l ! j = a" 
       by (simp add: in_set_conv_nth)
     let ?j = "Min {j. j < length l \<and> l ! j = a}"
     have fin_j: "finite {j. j < length l \<and> l ! j = a}" 
       using finite_nat_set_iff_bounded by blast
     moreover have "{j. j < length l \<and> l ! j = a} \<noteq> empty" using ex_j by blast
     ultimately have "?j < length l" 
       using Min_less_iff by blast
     have tail_all_a: "\<forall>j. j < length l \<and> j \<ge> ?j \<longrightarrow> l ! j = a"
     proof (rule allI, rule impI)
       fix j
       assume "j < length l \<and> j \<ge> ?j"
       moreover have "\<lbrakk> ?Q; j < length l \<and> j \<ge> ?j \<rbrakk> \<Longrightarrow> \<forall>k. k \<ge> ?j \<and> k \<le> j \<longrightarrow> l ! j = a"
       proof (induct "j - ?j")
         case 0
         then have "j = ?j" using 0 by simp
         then show ?case 
           using Min_in \<open>{j. j < length l \<and> l ! j = a} \<noteq> {}\<close> fin_j by blast
       next
         case (Suc n)
         then have "\<forall>k. k \<ge> ?j \<and> k < j \<longrightarrow> l ! j = a" 
           by (metis (mono_tags, lifting) Min_in \<open>{j. j < length l \<and> l ! j = a} \<noteq> {}\<close> fin_j le_eq_less_or_eq mem_Collect_eq)
         then show ?case 
           using Suc.hyps(2) by auto
       qed
       ultimately show "l ! j = a" using asm by blast
     qed
     moreover have head_all_not_a: "\<forall>i. i < ?j \<longrightarrow> l ! i \<noteq> a" using asm calculation 
       by (metis (mono_tags, lifting) Min_le \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> fin_j leD less_trans mem_Collect_eq)
     ultimately have "takeWhile ((\<noteq>) a) l = take ?j l"
     proof -
       have "length (takeWhile ((\<noteq>) a) l) = ?j" 
       proof -
         have "length (takeWhile ((\<noteq>) a) l) \<le> ?j" (is ?S)
         proof (rule ccontr)
           assume "\<not> ?S"
           then have "l ! ?j \<noteq> a" 
             by (metis (mono_tags, lifting) not_le_imp_less nth_mem set_takeWhileD takeWhile_nth)
           then show False 
             using \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> tail_all_a by blast
         qed
         moreover have "length (takeWhile ((\<noteq>) a) l) \<ge> ?j" (is ?T)
         proof (rule ccontr)
           assume "\<not> ?T"
           then have "\<exists>j. j < ?j \<and> l ! j = a" 
             by (metis (mono_tags, lifting) \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> calculation le_less_trans not_le_imp_less nth_length_takeWhile)
           then show False 
             using head_all_not_a by blast
         qed
         ultimately show ?thesis by simp
       qed
       moreover have "length (take ?j l) = ?j" 
         by (metis calculation takeWhile_eq_take)
       ultimately show ?thesis 
         by (metis takeWhile_eq_take)
 
     qed
     moreover have "filter ((\<noteq>) a) l = take ?j l"
     proof -
       have "filter ((\<noteq>) a) l = filter ((\<noteq>) a) (take ?j l) @ filter ((\<noteq>) a) (drop ?j l)" 
         by (metis append_take_drop_id filter_append)
       moreover have "filter ((\<noteq>) a) (take ?j l) = take ?j l" using head_all_not_a 
         by (metis \<open>takeWhile ((\<noteq>) a) l = take (Min {j. j < length l \<and> l ! j = a}) l\<close> filter_id_conv set_takeWhileD)
       moreover have "filter ((\<noteq>) a) (drop ?j l) = []"
       proof -
         have "\<forall>j. j \<ge> ?j \<and> j < length l \<longrightarrow> l ! j = drop ?j l ! (j - ?j)" 
           by simp
         then have "\<forall>j. j < length l - ?j \<longrightarrow> drop ?j l ! j = a" using tail_all_a 
           by (metis (no_types, lifting) Groups.add_ac(2) \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> less_diff_conv less_imp_le_nat not_add_less2 not_le nth_drop)
         then show ?thesis
         proof -
           obtain aa :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a" where
             "\<forall>x0 x1. (\<exists>v2. v2 \<in> set x1 \<and> x0 v2) = (aa x0 x1 \<in> set x1 \<and> x0 (aa x0 x1))"
             by moura
           then have f1: "\<forall>as p. aa p as \<in> set as \<and> p (aa p as) \<or> filter p as = []"
             by (metis (full_types) filter_False)
           obtain nn :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
             f2: "\<forall>x0 x1. (\<exists>v2<length x0. x0 ! v2 = x1) = (nn x0 x1 < length x0 \<and> x0 ! nn x0 x1 = x1)"
           by moura
           { assume "drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) = a"
             then have "filter ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l) = [] \<or> \<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
               using f1 by (metis (full_types)) }
           moreover
           { assume "\<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length l - Min {n. n < length l \<and> l ! n = a}"
             then have "\<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
               by simp }
           ultimately have "filter ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l) = [] \<or> \<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
             using \<open>\<forall>j<length l - Min {j. j < length l \<and> l ! j = a}. drop (Min {j. j < length l \<and> l ! j = a}) l ! j = a\<close> by blast
           then show ?thesis
             using f2 f1 by (meson in_set_conv_nth)
         qed
       qed
       ultimately show ?thesis by simp
     qed
     ultimately show ?thesis by simp
   qed
   then show False using assms by simp
 qed
 
 lemma util_exactly_one_element:
   assumes
     "m \<notin> set l" and
     "l' = l @ [m]"
   shows
     "\<exists>!j. j < length l' \<and> l' ! j = m" (is ?P)
 proof -
   have "\<forall>j. j < length l' - 1 \<longrightarrow> l' ! j \<noteq> m" 
     by (metis assms(1) assms(2) butlast_snoc length_butlast nth_append nth_mem)
   then have one_j: "\<forall>j. j < length l' \<and> l' ! j = m \<longrightarrow> j = (length l' - 1)"
     by (metis (no_types, hide_lams) diff_Suc_1 lessE)
   show ?thesis
   proof (rule ccontr)
     assume "~ ?P"
     then obtain i j where "i \<noteq> j" "i < length l'" "j < length l'"
                           "l' ! i = m" "l' ! j = m"
       using assms by auto
     then show False using one_j by blast
   qed
 qed
 
 lemma exists_one_iff_filter_one:
   shows
     "(\<exists>!j. j < length l \<and> l ! j = a) \<longleftrightarrow> length (filter ((=) a) l) = 1"
 proof (rule iffI)
   assume "\<exists>!j. j < length l \<and> l ! j = a"
   then obtain j where "j < length l" "l ! j = a"
     by blast
   moreover have "\<forall>k. k \<noteq> j \<and> k < length l \<longrightarrow> l ! k \<noteq> a" 
     using \<open>\<exists>!j. j < length l \<and> l ! j = a\<close> \<open>j < length l\<close> \<open>l ! j = a\<close> by blast
   moreover have "l = take j l @ [l ! j] @ drop (j+1) l" 
     by (metis Cons_eq_appendI Cons_nth_drop_Suc Suc_eq_plus1 append_self_conv2 append_take_drop_id calculation(1) calculation(2))
   moreover have "filter ((=) a) (take j l) = []"
   proof -
     have "\<forall>k. k < length (take j l) \<longrightarrow> (take j l) ! k \<noteq> a" 
       using calculation(3) by auto
     then show ?thesis 
       by (metis (full_types) filter_False in_set_conv_nth)
   qed
   moreover have "filter ((=) a) (drop (j+1) l) = []"
   proof -
     have "\<forall>k. k < length (drop (j+1) l) \<longrightarrow> (drop (j+1) l) ! k \<noteq> a" 
       using calculation(3) by auto
     then show ?thesis
       by (metis (full_types) filter_False in_set_conv_nth)
   qed
   ultimately show "length (filter ((=) a) l) = 1" 
     by (metis (mono_tags, lifting) One_nat_def Suc_eq_plus1 append_Cons append_self_conv2 filter.simps(2) filter_append list.size(3) list.size(4))
 next
   assume asm: "length (filter ((=) a) l) = 1"
   then have "filter ((=) a) l = [a]"
   proof -
     let ?xs = "filter ((=) a) l"
     have "length ?xs = 1"
       using asm by blast
     then show ?thesis 
       by (metis (full_types) Cons_eq_filterD One_nat_def length_0_conv length_Suc_conv)
   qed
   then have "\<exists>j. j < length l \<and> l ! j = a" 
     by (metis (full_types) filter_False in_set_conv_nth list.discI)
   then obtain j where j: "j < length l" "l ! j = a" by blast
   moreover have "\<forall>k. k < length l \<and> k \<noteq> j \<longrightarrow> l ! k \<noteq> a"
   proof (rule allI, rule impI)
     fix k
     assume assm: "k < length l \<and> k \<noteq> j"
     show "l ! k \<noteq> a"
     proof (rule ccontr)
       assume lka: "\<not> l ! k \<noteq> a"
       show False
       proof (cases "k < j")
         let ?xs = "take (k+1) l"
         let ?ys = "drop (k+1) l"
         case True
         then have "length (filter ((=) a) ?xs) > 0" 
           by (metis (full_types, hide_lams) add.commute assm discrete filter_empty_conv length_greater_0_conv length_take less_add_one lka min.absorb2 nth_mem nth_take)
         moreover have "length (filter ((=) a) ?ys) > 0"
         proof -
           have "?ys ! (j - (k+1)) = l ! j" 
             using True assm by auto
           moreover have "j - (k+1) < length ?ys" 
             using True \<open>j < length l\<close> by auto
           ultimately show ?thesis 
             by (metis (full_types) \<open>l ! j = a\<close> filter_empty_conv length_greater_0_conv nth_mem)
         qed
         moreover have "?xs @ ?ys = l" 
           using append_take_drop_id by blast
         ultimately have "length (filter ((=) a) l) > 1" 
           by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 asm filter_append length_append less_add_eq_less less_one nat_neq_iff)
         then show False using asm by simp
       next
         let ?xs = "take (j+1) l"
         let ?ys = "drop (j+1) l"
         case False
         then have "length (filter ((=) a) ?xs) > 0" 
           by (metis (full_types, hide_lams) add.commute j discrete filter_empty_conv length_greater_0_conv length_take less_add_one min.absorb2 nth_mem nth_take)
         moreover have "length (filter ((=) a) ?ys) > 0"
         proof -
           have "?ys ! (k - (j+1)) = l ! k" 
             using False assm by auto
           moreover have "k - (j+1) < length ?ys" 
             using False assm by auto
           ultimately show ?thesis 
             by (metis (full_types) filter_empty_conv length_greater_0_conv lka nth_mem)
         qed
         moreover have "?xs @ ?ys = l" 
           using append_take_drop_id by blast
         ultimately have "length (filter ((=) a) l) > 1" 
           by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 asm filter_append length_append less_add_eq_less less_one nat_neq_iff)
         then show False using asm by simp
       qed
     qed
   qed
   ultimately show "\<exists>!j. j < length l \<and> l ! j = a" by blast
 qed
 
 end
diff --git a/thys/Completeness/PermutationLemmas.thy b/thys/Completeness/PermutationLemmas.thy
--- a/thys/Completeness/PermutationLemmas.thy
+++ b/thys/Completeness/PermutationLemmas.thy
@@ -1,184 +1,184 @@
 section "Permutation Lemmas"
 
 theory PermutationLemmas
-imports "HOL-Library.Permutation" "HOL-Library.Multiset"
+imports "HOL-Library.List_Permutation" "HOL-Library.Multiset"
 begin
 
   \<comment> \<open>following function is very close to that in multisets- now we can make the connection that x <~~> y iff the multiset of x is the same as that of y\<close>
 
 subsection "perm, count equivalence"
 
 primrec count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
 where
   "count x [] = 0"
 | "count x (y#ys) = (if x=y then 1 else 0) + count x ys"
 
 lemma perm_count: "A <~~> B \<Longrightarrow> (\<forall> x. count x A = count x B)"
   by(induct set: perm) auto
 
 lemma count_0: "(\<forall>x. count x B = 0) = (B = [])"
   by(induct B) auto
 
 lemma count_Suc: "count a B = Suc m \<Longrightarrow> a : set B"
   apply(induct B)
    apply auto
   apply(case_tac "a = aa")
    apply auto
   done
 
 lemma count_append: "count a (xs@ys) = count a xs + count a ys"
   by(induct xs) auto
 
 lemma count_perm: "!! B. (\<forall> x. count x A = count x B) \<Longrightarrow> A <~~> B"
   apply(induct A)
   apply(simp add: count_0)
 proof -
   fix a list B
   assume a: "\<And>B. \<forall>x. count x list = count x B \<Longrightarrow> list <~~> B"
     and b: "\<forall>x. count x (a # list) = count x B"
   from b have "a : set B"
     apply auto
     apply (drule_tac x=a in spec, simp) apply(metis count_Suc) done
   from split_list[OF this] obtain xs ys where B: "B = xs@a#ys" by blast
   let ?B' = "xs@ys"
   from b have "\<forall>x. count x list = count x ?B'" by(simp add: count_append B)
   from a[OF this] have c: "list <~~> xs@ys" .
   hence "a#list <~~> a#(xs@ys)" by rule
   also have "a#(xs@ys) <~~> xs@a#ys" by(rule perm_append_Cons)
   also (perm.trans) note B[symmetric]
   finally show "a # list <~~> B" .
 qed
 
 lemma perm_count_conv: "A <~~> B = (\<forall> x. count x A = count x B)"
   apply(blast intro!: perm_count count_perm) done 
 
 
 subsection "Properties closed under Perm and Contr hold for x iff hold for remdups x"
 
 lemma remdups_append: "y : set ys --> remdups (ws@y#ys) = remdups (ws@ys)"
   apply (induct ws, simp)
   apply (case_tac "y = a", simp, simp)
   done
 
 lemma perm_contr': assumes perm[rule_format]: "! xs ys. xs <~~> ys --> (P xs = P ys)"
   and contr'[rule_format]: "! x xs. P(x#x#xs) = P (x#xs)" 
   shows "! xs. length xs = n --> (P xs = P (remdups xs))"
   apply(induct n rule: nat_less_induct)
 proof (safe)
   fix xs :: "'a list"
   assume a[rule_format]: "\<forall>m<length xs. \<forall>ys. length ys = m \<longrightarrow> P ys = P (remdups ys)"
   show "P xs = P (remdups xs)"
   proof (cases "distinct xs")
     case True
     thus ?thesis by(simp add:distinct_remdups_id)
   next
     case False
     from not_distinct_decomp[OF this] obtain ws ys zs y where xs: "xs = ws@[y]@ys@[y]@zs" by force
     have "P xs = P (ws@[y]@ys@[y]@zs)" by (simp add: xs)
     also have "... = P ([y,y]@ws@ys@zs)" 
       apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
     also have "... = P ([y]@ws@ys@zs)" apply simp apply(rule contr') done
     also have "... = P (ws@ys@[y]@zs)" 
       apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
     also have "... = P (remdups (ws@ys@[y]@zs))"
       apply(rule a) by(auto simp: xs)
     also have "(remdups (ws@ys@[y]@zs)) = (remdups xs)"
       apply(simp add: xs remdups_append) done 
     finally show "P xs = P (remdups xs)" .
   qed
 qed
 
 lemma perm_contr: assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
   and contr': "! x xs. P(x#x#xs) = P (x#xs)" 
   shows "(P xs = P (remdups xs))"
   apply(rule perm_contr'[OF perm contr', rule_format]) by force
 
 
 subsection "List properties closed under Perm, Weak and Contr are monotonic in the set of the list"
 
 definition
   rem :: "'a => 'a list => 'a list" where
   "rem x xs = filter (%y. y ~= x) xs"
 
 lemma rem: "x ~: set (rem x xs)"
   by(simp add: rem_def)
 
 lemma length_rem: "length (rem x xs) <= length xs"
   by(simp add: rem_def)
 
 lemma rem_notin: "x ~: set xs ==> rem x xs = xs"
   apply(simp add: rem_def)
   apply(rule filter_True)
   apply force
   done
 
 
 lemma perm_weak_filter': assumes perm[rule_format]: "! xs ys. xs <~~> ys --> (P xs = P ys)"
   and weak[rule_format]: "! x xs. P xs --> P (x#xs)"
   shows "! ys. P (ys@filter Q xs) --> P (ys@xs)"
   apply (induct xs, simp, rule)
   apply rule
   apply simp
   apply (case_tac "Q a", simp)
    apply(drule_tac x="ys@[a]" in spec) apply simp
   apply simp
   apply(drule_tac x="ys@[a]" in spec) apply simp
   apply(erule impE)
    apply(subgoal_tac "(ys @ a # filter Q xs) <~~> a#ys@filter Q xs")
     apply(simp add: perm)
     apply(rule weak) apply simp
    apply(rule perm_sym) apply(rule perm_append_Cons)
   .
 
 lemma perm_weak_filter: assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
   and weak: "! x xs. P xs --> P (x#xs)"
   shows "P (filter Q xs) ==> P xs"
   using perm_weak_filter'[OF perm weak, rule_format, of "[]", simplified]
   by blast
 
   \<comment> \<open>right, now in a position to prove that in presence of perm, contr and weak, set x leq set y and x : ded implies y : ded\<close>
 
 lemma perm_weak_contr_mono: 
   assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
   and contr: "! x xs. P (x#x#xs) --> P (x#xs)"
   and weak: "! x xs. P xs --> P (x#xs)"
   and xy: "set x <= set y"
   and Px : "P x"
   shows "P y"
 proof -
   from contr weak have contr': "! x xs. P(x#x#xs) = P (x#xs)" by blast
 
   define y' where "y' = filter (% z. z : set x) y"
   from xy have "set x = set y'" apply(simp add: y'_def) apply blast done
   hence rxry': "remdups x <~~> remdups y'" by(simp add: perm_remdups_iff_eq_set)
 
   from Px perm_contr[OF perm contr'] have Prx: "P (remdups x)" by simp
   with rxry' have "P (remdups y')" by(simp add: perm)
   
   with perm_contr[OF perm contr'] have "P y'" by simp
   thus "P y" 
     apply(simp add: y'_def)
     apply(rule perm_weak_filter[OF perm weak]) .
 qed
 
 (* No, not used
 subsection "Following used in Soundness"
 
 primrec multiset_of_list :: "'a list \<Rightarrow> 'a multiset"
 where
   "multiset_of_list [] = {#}"
 | "multiset_of_list (x#xs) = {#x#} + multiset_of_list xs"
 
 lemma count_count[symmetric]: "count x A = Multiset.count (multiset_of_list A) x"
   by (induct A) simp_all
 
 lemma perm_multiset: "A <~~> B = (multiset_of_list A = multiset_of_list B)"
   apply(simp add: perm_count_conv)
   apply(simp add: multiset_eq_iff)
   apply(simp add: count_count)
   done
 
 lemma set_of_multiset_of_list: "set_of (multiset_of_list A) = set A"
   by (induct A) auto
 *)
 end
diff --git a/thys/Groebner_Macaulay/Hilbert_Function.thy b/thys/Groebner_Macaulay/Hilbert_Function.thy
--- a/thys/Groebner_Macaulay/Hilbert_Function.thy
+++ b/thys/Groebner_Macaulay/Hilbert_Function.thy
@@ -1,1404 +1,1404 @@
 (* Author: Alexander Maletzky *)
 
 section \<open>Direct Decompositions and Hilbert Functions\<close>
 
 theory Hilbert_Function
-  imports Dube_Prelims Degree_Section "HOL-Library.Permutation"
+  imports Dube_Prelims Degree_Section "HOL-Library.List_Permutation"
 begin
 
 subsection \<open>Direct Decompositions\<close>
 
 text \<open>The main reason for defining \<open>direct_decomp\<close> in terms of lists rather than sets is that
   lemma \<open>direct_decomp_direct_decomp\<close> can be proved easier. At some point one could invest the time
   to re-define \<open>direct_decomp\<close> in terms of sets (possibly adding a couple of further assumptions to
   \<open>direct_decomp_direct_decomp\<close>).\<close>
 
 definition direct_decomp :: "'a set \<Rightarrow> 'a::comm_monoid_add set list \<Rightarrow> bool"
   where "direct_decomp A ss \<longleftrightarrow> bij_betw sum_list (listset ss) A"
 
 lemma direct_decompI:
   "inj_on sum_list (listset ss) \<Longrightarrow> sum_list ` listset ss = A \<Longrightarrow> direct_decomp A ss"
   by (simp add: direct_decomp_def bij_betw_def)
 
 lemma direct_decompI_alt:
   "(\<And>qs. qs \<in> listset ss \<Longrightarrow> sum_list qs \<in> A) \<Longrightarrow> (\<And>a. a \<in> A \<Longrightarrow> \<exists>!qs\<in>listset ss. a = sum_list qs) \<Longrightarrow>
     direct_decomp A ss"
   by (auto simp: direct_decomp_def intro!: bij_betwI') blast
 
 lemma direct_decompD:
   assumes "direct_decomp A ss"
   shows "qs \<in> listset ss \<Longrightarrow> sum_list qs \<in> A" and "inj_on sum_list (listset ss)"
     and "sum_list ` listset ss = A"
   using assms by (auto simp: direct_decomp_def bij_betw_def)
 
 lemma direct_decompE:
   assumes "direct_decomp A ss" and "a \<in> A"
   obtains qs where "qs \<in> listset ss" and "a = sum_list qs"
   using assms by (auto simp: direct_decomp_def bij_betw_def)
 
 lemma direct_decomp_unique:
   "direct_decomp A ss \<Longrightarrow> qs \<in> listset ss \<Longrightarrow> qs' \<in> listset ss \<Longrightarrow> sum_list qs = sum_list qs' \<Longrightarrow>
     qs = qs'"
   by (auto dest: direct_decompD simp: inj_on_def)
 
 lemma direct_decomp_singleton: "direct_decomp A [A]"
 proof (rule direct_decompI_alt)
   fix qs
   assume "qs \<in> listset [A]"
   then obtain q where "q \<in> A" and "qs = [q]" by (rule listset_singletonE)
   thus "sum_list qs \<in> A" by simp
 next
   fix a
   assume "a \<in> A"
   show "\<exists>!qs\<in>listset [A]. a = sum_list qs"
   proof (intro ex1I conjI allI impI)
     from \<open>a \<in> A\<close> refl show "[a] \<in> listset [A]" by (rule listset_singletonI)
   next
     fix qs
     assume "qs \<in> listset [A] \<and> a = sum_list qs"
     hence a: "a = sum_list qs" and "qs \<in> listset [A]" by simp_all
     from this(2) obtain b where qs: "qs = [b]" by (rule listset_singletonE)
     with a show "qs = [a]" by simp
   qed simp_all
 qed
 
 (* TODO: Move. *)
 lemma mset_bij:
   assumes "bij_betw f {..<length xs} {..<length ys}" and "\<And>i. i < length xs \<Longrightarrow> xs ! i = ys ! f i"
   shows "mset xs = mset ys"
 proof -
   from assms(1) have 1: "inj_on f {0..<length xs}" and 2: "f ` {0..<length xs} = {0..<length ys}"
     by (simp_all add: bij_betw_def lessThan_atLeast0)
   let ?f = "(!) ys \<circ> f"
   have "xs = map ?f [0..<length xs]" unfolding list_eq_iff_nth_eq
   proof (intro conjI allI impI)
     fix i
     assume "i < length xs"
     hence "xs ! i = ys ! f i" by (rule assms(2))
     also from \<open>i < length xs\<close> have "\<dots> = map ((!) ys \<circ> f) [0..<length xs] ! i" by simp
     finally show "xs ! i = map ((!) ys \<circ> f) [0..<length xs] ! i" .
   qed simp
   hence "mset xs = mset (map ?f [0..<length xs])" by (rule arg_cong)
   also have "\<dots> = image_mset ((!) ys) (image_mset f (mset_set {0..<length xs}))"
     by (simp flip: image_mset.comp)
   also from 1 have "\<dots> = image_mset ((!) ys) (mset_set {0..<length ys})"
     by (simp add: image_mset_mset_set 2)
   also have "\<dots> = mset (map ((!) ys) [0..<length ys])" by simp
   finally show "mset xs = mset ys" by (simp only: map_nth)
 qed
 
 lemma direct_decomp_perm:
   assumes "direct_decomp A ss1" and "perm ss1 ss2"
   shows "direct_decomp A ss2"
 proof -
   from assms(2) have len_ss1: "length ss1 = length ss2" by (rule perm_length)
   from assms(2) have "\<exists>f. bij_betw f {..<length ss1} {..<length ss2} \<and> (\<forall>i<length ss1. ss1 ! i = ss2 ! f i)"
     by (rule permutation_Ex_bij)
   then obtain f where f_bij: "bij_betw f {..<length ss2} {..<length ss1}"
     and f: "\<And>i. i < length ss2 \<Longrightarrow> ss1 ! i = ss2 ! f i" unfolding len_ss1 by blast
   define g where "g = inv_into {..<length ss2} f"
   from f_bij have g_bij: "bij_betw g {..<length ss1} {..<length ss2}"
     unfolding g_def len_ss1 by (rule bij_betw_inv_into)
   have f_g: "f (g i) = i" if "i < length ss1" for i
   proof -
     from that f_bij have "i \<in> f ` {..<length ss2}" by (simp add: bij_betw_def len_ss1)
     thus ?thesis by (simp only: f_inv_into_f g_def)
   qed
   have g_f: "g (f i) = i" if "i < length ss2" for i
   proof -
     from f_bij have "inj_on f {..<length ss2}" by (simp only: bij_betw_def)
     moreover from that have "i \<in> {..<length ss2}" by simp
     ultimately show ?thesis by (simp add: g_def)
   qed
   have g: "ss2 ! i = ss1 ! g i" if "i < length ss1" for i
   proof -
     from that have "i \<in> {..<length ss2}" by (simp add: len_ss1)
     hence "g i \<in> g ` {..<length ss2}" by (rule imageI)
     also from g_bij have "\<dots> = {..<length ss2}" by (simp only: len_ss1 bij_betw_def)
     finally have "g i < length ss2" by simp
     hence "ss1 ! g i = ss2 ! f (g i)" by (rule f)
     with that show ?thesis by (simp only: f_g)
   qed
   show ?thesis
   proof (rule direct_decompI_alt)
     fix qs2
     assume "qs2 \<in> listset ss2"
     then obtain qs1 where qs1_in: "qs1 \<in> listset ss1" and len_qs1: "length qs1 = length qs2"
       and *: "\<And>i. i < length qs2 \<Longrightarrow> qs1 ! i = qs2 ! f i" using f_bij f by (rule listset_permE) blast+
     from \<open>qs2 \<in> listset ss2\<close> have "length qs2 = length ss2" by (rule listsetD)
     with f_bij have "bij_betw f {..<length qs1} {..<length qs2}" by (simp only: len_qs1 len_ss1)
     hence "mset qs1 = mset qs2" using * by (rule mset_bij) (simp only: len_qs1)
     hence "sum_list qs2 = sum_list qs1" by (simp flip: sum_mset_sum_list)
     also from assms(1) qs1_in have "\<dots> \<in> A" by (rule direct_decompD)
     finally show "sum_list qs2 \<in> A" .
   next
     fix a
     assume "a \<in> A"
     with assms(1) obtain qs where a: "a = sum_list qs" and qs_in: "qs \<in> listset ss1"
       by (rule direct_decompE)
     from qs_in obtain qs2 where qs2_in: "qs2 \<in> listset ss2" and len_qs2: "length qs2 = length qs"
       and 1: "\<And>i. i < length qs \<Longrightarrow> qs2 ! i = qs ! g i" using g_bij g by (rule listset_permE) blast+
     show "\<exists>!qs\<in>listset ss2. a = sum_list qs"
     proof (intro ex1I conjI allI impI)
       from qs_in have len_qs: "length qs = length ss1" by (rule listsetD)
       with g_bij have g_bij2: "bij_betw g {..<length qs2} {..<length qs}" by (simp only: len_qs2 len_ss1)
       hence "mset qs2 = mset qs" using 1 by (rule mset_bij) (simp only: len_qs2)
       thus a2: "a = sum_list qs2" by (simp only: a flip: sum_mset_sum_list)
 
       fix qs'
       assume "qs' \<in> listset ss2 \<and> a = sum_list qs'"
       hence qs'_in: "qs' \<in> listset ss2" and a': "a = sum_list qs'" by simp_all
       from this(1) obtain qs1 where qs1_in: "qs1 \<in> listset ss1" and len_qs1: "length qs1 = length qs'"
       and 2: "\<And>i. i < length qs' \<Longrightarrow> qs1 ! i = qs' ! f i" using f_bij f by (rule listset_permE) blast+
       from \<open>qs' \<in> listset ss2\<close> have "length qs' = length ss2" by (rule listsetD)
       with f_bij have "bij_betw f {..<length qs1} {..<length qs'}" by (simp only: len_qs1 len_ss1)
       hence "mset qs1 = mset qs'" using 2 by (rule mset_bij) (simp only: len_qs1)
       hence "sum_list qs1 = sum_list qs'" by (simp flip: sum_mset_sum_list)
       hence "sum_list qs1 = sum_list qs" by (simp only: a flip: a')
       with assms(1) qs1_in qs_in have "qs1 = qs" by (rule direct_decomp_unique)
       show "qs' = qs2" unfolding list_eq_iff_nth_eq
       proof (intro conjI allI impI)
         from qs'_in have "length qs' = length ss2" by (rule listsetD)
         thus eq: "length qs' = length qs2" by (simp only: len_qs2 len_qs len_ss1)
 
         fix i
         assume "i < length qs'"
         hence "i < length qs2" by (simp only: eq)
         hence "i \<in> {..<length qs2}" and "i < length qs" and "i < length ss1"
           by (simp_all add: len_qs2 len_qs)
         from this(1) have "g i \<in> g ` {..<length qs2}" by (rule imageI)
         also from g_bij2 have "\<dots> = {..<length qs}" by (simp only: bij_betw_def)
         finally have "g i < length qs'" by (simp add: eq len_qs2)
         from \<open>i < length qs\<close> have "qs2 ! i = qs ! g i" by (rule 1)
         also have "\<dots> = qs1 ! g i" by (simp only: \<open>qs1 = qs\<close>)
         also from \<open>g i < length qs'\<close> have "\<dots> = qs' ! f (g i)" by (rule 2)
         also from \<open>i < length ss1\<close> have "\<dots> = qs' ! i" by (simp only: f_g)
         finally show "qs' ! i = qs2 ! i" by (rule sym)
       qed
     qed fact
   qed
 qed
 
 lemma direct_decomp_split_map:
   "direct_decomp A (map f ss) \<Longrightarrow> direct_decomp A (map f (filter P ss) @ map f (filter (- P) ss))"
 proof (rule direct_decomp_perm)
   show "perm (map f ss) (map f (filter P ss) @ map f (filter (- P) ss))"
   proof (induct ss)
     case Nil
     show ?case by simp
   next
     case (Cons s ss)
     show ?case
     proof (cases "P s")
       case True
       with Cons show ?thesis by simp
     next
       case False
       have "map f (s # ss) = f s # map f ss" by simp
       also from Cons have "perm (f s # map f ss) (f s # map f (filter P ss) @ map f (filter (- P) ss))"
         by (rule perm.intros)
       also have "perm \<dots> (map f (filter P ss) @ map f (s # filter (- P) ss))"
         by (simp add: perm_append_Cons)
       also(trans) from False have "\<dots> = map f (filter P (s # ss)) @ map f (filter (- P) (s # ss))"
         by simp
       finally show ?thesis .
     qed
   qed
 qed
 
 lemmas direct_decomp_split = direct_decomp_split_map[where f=id, simplified]
 
 lemma direct_decomp_direct_decomp:
   assumes "direct_decomp A (s # ss)" and "direct_decomp s rs"
   shows "direct_decomp A (ss @ rs)" (is "direct_decomp A ?ss")
 proof (rule direct_decompI_alt)
   fix qs
   assume "qs \<in> listset ?ss"
   then obtain qs1 qs2 where qs1: "qs1 \<in> listset ss" and qs2: "qs2 \<in> listset rs" and qs: "qs = qs1 @ qs2"
     by (rule listset_appendE)
   have "sum_list qs = sum_list ((sum_list qs2) # qs1)" by (simp add: qs add.commute)
   also from assms(1) have "\<dots> \<in> A"
   proof (rule direct_decompD)
     from assms(2) qs2 have "sum_list qs2 \<in> s" by (rule direct_decompD)
     thus "sum_list qs2 # qs1 \<in> listset (s # ss)" using qs1 refl by (rule listset_ConsI)
   qed
   finally show "sum_list qs \<in> A" .
 next
   fix a
   assume "a \<in> A"
   with assms(1) obtain qs1 where qs1_in: "qs1 \<in> listset (s # ss)" and a: "a = sum_list qs1"
     by (rule direct_decompE)
   from qs1_in obtain qs11 qs12 where "qs11 \<in> s" and qs12_in: "qs12 \<in> listset ss"
     and qs1: "qs1 = qs11 # qs12" by (rule listset_ConsE)
   from assms(2) this(1) obtain qs2 where qs2_in: "qs2 \<in> listset rs" and qs11: "qs11 = sum_list qs2"
     by (rule direct_decompE)
   let ?qs = "qs12 @ qs2"
   show "\<exists>!qs\<in>listset ?ss. a = sum_list qs"
   proof (intro ex1I conjI allI impI)
     from qs12_in qs2_in refl show "?qs \<in> listset ?ss" by (rule listset_appendI)
 
     show "a = sum_list ?qs" by (simp add: a qs1 qs11 add.commute)
 
     fix qs0
     assume "qs0 \<in> listset ?ss \<and> a = sum_list qs0"
     hence qs0_in: "qs0 \<in> listset ?ss" and a2: "a = sum_list qs0" by simp_all
     from this(1) obtain qs01 qs02 where qs01_in: "qs01 \<in> listset ss" and qs02_in: "qs02 \<in> listset rs"
       and qs0: "qs0 = qs01 @ qs02" by (rule listset_appendE)
     note assms(1)
     moreover from _ qs01_in refl have "(sum_list qs02) # qs01 \<in> listset (s # ss)" (is "?qs' \<in> _")
     proof (rule listset_ConsI)
       from assms(2) qs02_in show "sum_list qs02 \<in> s" by (rule direct_decompD)
     qed
     moreover note qs1_in
     moreover from a2 have "sum_list ?qs' = sum_list qs1" by (simp add: qs0 a add.commute)
     ultimately have "?qs' = qs11 # qs12" unfolding qs1 by (rule direct_decomp_unique)
     hence "qs11 = sum_list qs02" and 1: "qs01 = qs12" by simp_all
     from this(1) have "sum_list qs02 = sum_list qs2" by (simp only: qs11)
     with assms(2) qs02_in qs2_in have "qs02 = qs2" by (rule direct_decomp_unique)
     thus "qs0 = qs12 @ qs2" by (simp only: 1 qs0)
   qed
 qed
 
 lemma sum_list_map_times: "sum_list (map ((*) x) xs) = (x::'a::semiring_0) * sum_list xs"
   by (induct xs) (simp_all add: algebra_simps)
 
 lemma direct_decomp_image_times:
   assumes "direct_decomp (A::'a::semiring_0 set) ss" and "\<And>a b. x * a = x * b \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> a = b"
   shows "direct_decomp ((*) x ` A) (map ((`) ((*) x)) ss)" (is "direct_decomp ?A ?ss")
 proof (rule direct_decompI_alt)
   fix qs
   assume "qs \<in> listset ?ss"
   then obtain qs0 where qs0_in: "qs0 \<in> listset ss" and qs: "qs = map ((*) x) qs0"
     by (rule listset_map_imageE)
   have "sum_list qs = x * sum_list qs0" by (simp only: qs sum_list_map_times)
   moreover from assms(1) qs0_in have "sum_list qs0 \<in> A" by (rule direct_decompD)
   ultimately show "sum_list qs \<in> (*) x ` A" by (rule image_eqI)
 next
   fix a
   assume "a \<in> ?A"
   then obtain a' where "a' \<in> A" and a: "a = x * a'" ..
   from assms(1) this(1) obtain qs' where qs'_in: "qs' \<in> listset ss" and a': "a' = sum_list qs'"
     by (rule direct_decompE)
   define qs where "qs = map ((*) x) qs'"
   show "\<exists>!qs\<in>listset ?ss. a = sum_list qs"
   proof (intro ex1I conjI allI impI)
     from qs'_in qs_def show "qs \<in> listset ?ss" by (rule listset_map_imageI)
 
     fix qs0
     assume "qs0 \<in> listset ?ss \<and> a = sum_list qs0"
     hence "qs0 \<in> listset ?ss" and a0: "a = sum_list qs0" by simp_all
     from this(1) obtain qs1 where qs1_in: "qs1 \<in> listset ss" and qs0: "qs0 = map ((*) x) qs1"
       by (rule listset_map_imageE)
     show "qs0 = qs"
     proof (cases "x = 0")
       case True
       from qs1_in have "length qs1 = length ss" by (rule listsetD)
       moreover from qs'_in have "length qs' = length ss" by (rule listsetD)
       ultimately show ?thesis by (simp add: qs_def qs0 list_eq_iff_nth_eq True)
     next
       case False
       have "x * sum_list qs1 = a" by (simp only: a0 qs0 sum_list_map_times)
       also have "\<dots> = x * sum_list qs'" by (simp only: a' a)
       finally have "sum_list qs1 = sum_list qs'" using False by (rule assms(2))
       with assms(1) qs1_in qs'_in have "qs1 = qs'" by (rule direct_decomp_unique)
       thus ?thesis by (simp only: qs0 qs_def)
     qed
   qed (simp only: a a' qs_def sum_list_map_times)
 qed
 
 lemma direct_decomp_appendD:
   assumes "direct_decomp A (ss1 @ ss2)"
   shows "{} \<notin> set ss2 \<Longrightarrow> direct_decomp (sum_list ` listset ss1) ss1" (is "_ \<Longrightarrow> ?thesis1")
     and "{} \<notin> set ss1 \<Longrightarrow> direct_decomp (sum_list ` listset ss2) ss2" (is "_ \<Longrightarrow> ?thesis2")
     and "direct_decomp A [sum_list ` listset ss1, sum_list ` listset ss2]" (is "direct_decomp _ ?ss")
 proof -
   have rl: "direct_decomp (sum_list ` listset ts1) ts1"
     if "direct_decomp A (ts1 @ ts2)" and "{} \<notin> set ts2" for ts1 ts2
   proof (intro direct_decompI inj_onI refl)
     fix qs1 qs2
     assume qs1: "qs1 \<in> listset ts1" and qs2: "qs2 \<in> listset ts1"
     assume eq: "sum_list qs1 = sum_list qs2"
     from that(2) have "listset ts2 \<noteq> {}" by (simp add: listset_empty_iff)
     then obtain qs3 where qs3: "qs3 \<in> listset ts2" by blast
     note that(1)
     moreover from qs1 qs3 refl have "qs1 @ qs3 \<in> listset (ts1 @ ts2)" by (rule listset_appendI)
     moreover from qs2 qs3 refl have "qs2 @ qs3 \<in> listset (ts1 @ ts2)" by (rule listset_appendI)
     moreover have "sum_list (qs1 @ qs3) = sum_list (qs2 @ qs3)" by (simp add: eq)
     ultimately have "qs1 @ qs3 = qs2 @ qs3" by (rule direct_decomp_unique)
     thus "qs1 = qs2" by simp
   qed
 
   {
     assume "{} \<notin> set ss2"
     with assms show ?thesis1 by (rule rl)
   }
 
   {
     from assms perm_append_swap have "direct_decomp A (ss2 @ ss1)" by (rule direct_decomp_perm)
     moreover assume "{} \<notin> set ss1"
     ultimately show ?thesis2 by (rule rl)
   }
 
   show "direct_decomp A ?ss"
   proof (rule direct_decompI_alt)
     fix qs
     assume "qs \<in> listset ?ss"
     then obtain q1 q2 where q1: "q1 \<in> sum_list ` listset ss1" and q2: "q2 \<in> sum_list ` listset ss2"
       and qs: "qs = [q1, q2]" by (rule listset_doubletonE)
     from q1 obtain qs1 where qs1: "qs1 \<in> listset ss1" and q1: "q1 = sum_list qs1" ..
     from q2 obtain qs2 where qs2: "qs2 \<in> listset ss2" and q2: "q2 = sum_list qs2" ..
     from qs1 qs2 refl have "qs1 @ qs2 \<in> listset (ss1 @ ss2)" by (rule listset_appendI)
     with assms have "sum_list (qs1 @ qs2) \<in> A" by (rule direct_decompD)
     thus "sum_list qs \<in> A" by (simp add: qs q1 q2)
   next
     fix a
     assume "a \<in> A"
     with assms obtain qs0 where qs0_in: "qs0 \<in> listset (ss1 @ ss2)" and a: "a = sum_list qs0"
       by (rule direct_decompE)
     from this(1) obtain qs1 qs2 where qs1: "qs1 \<in> listset ss1" and qs2: "qs2 \<in> listset ss2"
       and qs0: "qs0 = qs1 @ qs2" by (rule listset_appendE)
     from qs1 have len_qs1: "length qs1 = length ss1" by (rule listsetD)
     define qs where "qs = [sum_list qs1, sum_list qs2]"
     show "\<exists>!qs\<in>listset ?ss. a = sum_list qs"
     proof (intro ex1I conjI)
       from qs1 have "sum_list qs1 \<in> sum_list ` listset ss1" by (rule imageI)
       moreover from qs2 have "sum_list qs2 \<in> sum_list ` listset ss2" by (rule imageI)
       ultimately show "qs \<in> listset ?ss" using qs_def by (rule listset_doubletonI)
 
       fix qs'
       assume "qs' \<in> listset ?ss \<and> a = sum_list qs'"
       hence "qs' \<in> listset ?ss" and a': "a = sum_list qs'" by simp_all
       from this(1) obtain q1 q2 where q1: "q1 \<in> sum_list ` listset ss1"
         and q2: "q2 \<in> sum_list ` listset ss2" and qs': "qs' = [q1, q2]" by (rule listset_doubletonE)
       from q1 obtain qs1' where qs1': "qs1' \<in> listset ss1" and q1: "q1 = sum_list qs1'" ..
       from q2 obtain qs2' where qs2': "qs2' \<in> listset ss2" and q2: "q2 = sum_list qs2'" ..
       from qs1' have len_qs1': "length qs1' = length ss1" by (rule listsetD)
       note assms
       moreover from qs1' qs2' refl have "qs1' @ qs2' \<in> listset (ss1 @ ss2)" by (rule listset_appendI)
       moreover note qs0_in
       moreover have "sum_list (qs1' @ qs2') = sum_list qs0" by (simp add: a' qs' flip: a q1 q2)
       ultimately have "qs1' @ qs2' = qs0" by (rule direct_decomp_unique)
       also have "\<dots> = qs1 @ qs2" by fact
       finally show "qs' = qs" by (simp add: qs_def qs' q1 q2 len_qs1 len_qs1')
     qed (simp add: qs_def a qs0)
   qed
 qed
 
 lemma direct_decomp_Cons_zeroI:
   assumes "direct_decomp A ss"
   shows "direct_decomp A ({0} # ss)"
 proof (rule direct_decompI_alt)
   fix qs
   assume "qs \<in> listset ({0} # ss)"
   then obtain q qs' where "q \<in> {0}" and "qs' \<in> listset ss" and "qs = q # qs'"
     by (rule listset_ConsE)
   from this(1, 3) have "sum_list qs = sum_list qs'" by simp
   also from assms \<open>qs' \<in> listset ss\<close> have "\<dots> \<in> A" by (rule direct_decompD)
   finally show "sum_list qs \<in> A" .
 next
   fix a
   assume "a \<in> A"
   with assms obtain qs' where qs': "qs' \<in> listset ss" and a: "a = sum_list qs'"
     by (rule direct_decompE)
   define qs where "qs = 0 # qs'"
   show "\<exists>!qs. qs \<in> listset ({0} # ss) \<and> a = sum_list qs"
   proof (intro ex1I conjI)
     from _ qs' qs_def show "qs \<in> listset ({0} # ss)" by (rule listset_ConsI) simp
   next
     fix qs0
     assume "qs0 \<in> listset ({0} # ss) \<and> a = sum_list qs0"
     hence "qs0 \<in> listset ({0} # ss)" and a0: "a = sum_list qs0" by simp_all
     from this(1) obtain q0 qs0' where "q0 \<in> {0}" and qs0': "qs0' \<in> listset ss"
       and qs0: "qs0 = q0 # qs0'" by (rule listset_ConsE)
     from this(1, 3) have "sum_list qs0' = sum_list qs'" by (simp add: a0 flip: a)
     with assms qs0' qs' have "qs0' = qs'" by (rule direct_decomp_unique)
     with \<open>q0 \<in> {0}\<close> show "qs0 = qs" by (simp add: qs_def qs0)
   qed (simp add: qs_def a)
 qed
 
 lemma direct_decomp_Cons_zeroD:
   assumes "direct_decomp A ({0} # ss)"
   shows "direct_decomp A ss"
 proof -
   have "direct_decomp {0} []" by (simp add: direct_decomp_def bij_betw_def)
   with assms have "direct_decomp A (ss @ [])" by (rule direct_decomp_direct_decomp)
   thus ?thesis by simp
 qed
 
 lemma direct_decomp_Cons_subsetI:
   assumes "direct_decomp A (s # ss)" and "\<And>s0. s0 \<in> set ss \<Longrightarrow> 0 \<in> s0"
   shows "s \<subseteq> A"
 proof
   fix x
   assume "x \<in> s"
   moreover from assms(2) have "map (\<lambda>_. 0) ss \<in> listset ss"
     by (induct ss, auto simp del: listset.simps(2) intro: listset_ConsI)
   ultimately have "x # (map (\<lambda>_. 0) ss) \<in> listset (s # ss)" using refl by (rule listset_ConsI)
   with assms(1) have "sum_list (x # (map (\<lambda>_. 0) ss)) \<in> A" by (rule direct_decompD)
   thus "x \<in> A" by simp
 qed
 
 lemma direct_decomp_Int_zero:
   assumes "direct_decomp A ss" and "i < j" and "j < length ss" and "\<And>s. s \<in> set ss \<Longrightarrow> 0 \<in> s"
   shows "ss ! i \<inter> ss ! j = {0}"
 proof -
   from assms(2, 3) have "i < length ss" by (rule less_trans)
   hence i_in: "ss ! i \<in> set ss" by simp
   from assms(3) have j_in: "ss ! j \<in> set ss" by simp
   show ?thesis
   proof
     show "ss ! i \<inter> ss ! j \<subseteq> {0}"
     proof
       fix x
       assume "x \<in> ss ! i \<inter> ss ! j"
       hence x_i: "x \<in> ss ! i" and x_j: "x \<in> ss ! j" by simp_all
       have 1: "(map (\<lambda>_. 0) ss)[k := y] \<in> listset ss" if "k < length ss" and "y \<in> ss ! k" for k y
         using assms(4) that
       proof (induct ss arbitrary: k)
         case Nil
         from Nil(2) show ?case by simp
       next
         case (Cons s ss)
         have *: "\<And>s'. s' \<in> set ss \<Longrightarrow> 0 \<in> s'" by (rule Cons.prems) simp
         show ?case
         proof (cases k)
           case k: 0
           with Cons.prems(3) have "y \<in> s" by simp
           moreover from * have "map (\<lambda>_. 0) ss \<in> listset ss"
             by (induct ss) (auto simp del: listset.simps(2) intro: listset_ConsI)
           moreover have "(map (\<lambda>_. 0) (s # ss))[k := y] = y # map (\<lambda>_. 0) ss" by (simp add: k)
           ultimately show ?thesis by (rule listset_ConsI)
         next
           case k: (Suc k')
           have "0 \<in> s" by (rule Cons.prems) simp
           moreover from * have "(map (\<lambda>_. 0) ss)[k' := y] \<in> listset ss"
           proof (rule Cons.hyps)
             from Cons.prems(2) show "k' < length ss" by (simp add: k)
           next
             from Cons.prems(3) show "y \<in> ss ! k'" by (simp add: k)
           qed
           moreover have "(map (\<lambda>_. 0) (s # ss))[k := y] = 0 # (map (\<lambda>_. 0) ss)[k' := y]"
             by (simp add: k)
           ultimately show ?thesis by (rule listset_ConsI)
         qed
       qed
       have 2: "sum_list ((map (\<lambda>_. 0) ss)[k := y]) = y" if "k < length ss" for k and y::'a
         using that by (induct ss arbitrary: k) (auto simp: add_ac split: nat.split)
       define qs1 where "qs1 = (map (\<lambda>_. 0) ss)[i := x]"
       define qs2 where "qs2 = (map (\<lambda>_. 0) ss)[j := x]"
       note assms(1)
       moreover from \<open>i < length ss\<close> x_i have "qs1 \<in> listset ss" unfolding qs1_def by (rule 1)
       moreover from assms(3) x_j have "qs2 \<in> listset ss" unfolding qs2_def by (rule 1)
       thm sum_list_update
       moreover from \<open>i < length ss\<close> assms(3) have "sum_list qs1 = sum_list qs2"
         by (simp add: qs1_def qs2_def 2)
       ultimately have "qs1 = qs2" by (rule direct_decomp_unique)
       hence "qs1 ! i = qs2 ! i" by simp
       with \<open>i < length ss\<close> assms(2, 3) show "x \<in> {0}" by (simp add: qs1_def qs2_def)
     qed
   next
     from i_in have "0 \<in> ss ! i" by (rule assms(4))
     moreover from j_in have "0 \<in> ss ! j" by (rule assms(4))
     ultimately show "{0} \<subseteq> ss ! i \<inter> ss ! j" by simp
   qed
 qed
 
 corollary direct_decomp_pairwise_zero:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> 0 \<in> s"
   shows "pairwise (\<lambda>s1 s2. s1 \<inter> s2 = {0}) (set ss)"
 proof (rule pairwiseI)
   fix s1 s2
   assume "s1 \<in> set ss"
   then obtain i where "i < length ss" and s1: "s1 = ss ! i" by (metis in_set_conv_nth)
   assume "s2 \<in> set ss"
   then obtain j where "j < length ss" and s2: "s2 = ss ! j" by (metis in_set_conv_nth)
   assume "s1 \<noteq> s2"
   hence "i < j \<or> j < i" by (auto simp: s1 s2)
   thus "s1 \<inter> s2 = {0}"
   proof
     assume "i < j"
     with assms(1) show ?thesis unfolding s1 s2 using \<open>j < length ss\<close> assms(2)
       by (rule direct_decomp_Int_zero)
   next
     assume "j < i"
     with assms(1) have "s2 \<inter> s1 = {0}" unfolding s1 s2 using \<open>i < length ss\<close> assms(2)
       by (rule direct_decomp_Int_zero)
     thus ?thesis by (simp only: Int_commute)
   qed
 qed
 
 corollary direct_decomp_repeated_eq_zero:
   assumes "direct_decomp A ss" and "1 < count_list ss X" and "\<And>s. s \<in> set ss \<Longrightarrow> 0 \<in> s"
   shows "X = {0}"
 proof -
   from assms(2) obtain i j where "i < j" and "j < length ss" and 1: "ss ! i = X" and 2: "ss ! j = X"
     by (rule count_list_gr_1_E)
   from assms(1) this(1, 2) assms(3) have "ss ! i \<inter> ss ! j = {0}" by (rule direct_decomp_Int_zero)
   thus ?thesis by (simp add: 1 2)
 qed
 
 corollary direct_decomp_map_Int_zero:
   assumes "direct_decomp A (map f ss)" and "s1 \<in> set ss" and "s2 \<in> set ss" and "s1 \<noteq> s2"
     and "\<And>s. s \<in> set ss \<Longrightarrow> 0 \<in> f s"
   shows "f s1 \<inter> f s2 = {0}"
 proof -
   from assms(2) obtain i where "i < length ss" and s1: "s1 = ss ! i" by (metis in_set_conv_nth)
   from this(1) have i: "i < length (map f ss)" by simp
   from assms(3) obtain j where "j < length ss" and s2: "s2 = ss ! j" by (metis in_set_conv_nth)
   from this(1) have j: "j < length (map f ss)" by simp
   have *: "0 \<in> s" if "s \<in> set (map f ss)" for s
   proof -
     from that obtain s' where "s' \<in> set ss" and s: "s = f s'" unfolding set_map ..
     from this(1) show "0 \<in> s" unfolding s by (rule assms(5))
   qed
   show ?thesis
   proof (rule linorder_cases)
     assume "i < j"
     with assms(1) have "(map f ss) ! i \<inter> (map f ss) ! j = {0}"
       using j * by (rule direct_decomp_Int_zero)
     with i j show ?thesis by (simp add: s1 s2)
   next
     assume "j < i"
     with assms(1) have "(map f ss) ! j \<inter> (map f ss) ! i = {0}"
       using i * by (rule direct_decomp_Int_zero)
     with i j show ?thesis by (simp add: s1 s2 Int_commute)
   next
     assume "i = j"
     with assms(4) show ?thesis by (simp add: s1 s2)
   qed
 qed
 
 subsection \<open>Direct Decompositions and Vector Spaces\<close>
 
 definition (in vector_space) is_basis :: "'b set \<Rightarrow> 'b set \<Rightarrow> bool"
   where "is_basis V B \<longleftrightarrow> (B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> card B = dim V)"
 
 definition (in vector_space) some_basis :: "'b set \<Rightarrow> 'b set"
   where "some_basis V = Eps (local.is_basis V)"
 
 hide_const (open) real_vector.is_basis real_vector.some_basis
 
 context vector_space
 begin
 
 lemma dim_empty [simp]: "dim {} = 0"
   using dim_span_eq_card_independent independent_empty by fastforce
 
 lemma dim_zero [simp]: "dim {0} = 0"
   using dim_span_eq_card_independent independent_empty by fastforce
 
 lemma independent_UnI:
   assumes "independent A" and "independent B" and "span A \<inter> span B = {0}"
   shows "independent (A \<union> B)"
 proof
   from span_superset have "A \<inter> B \<subseteq> span A \<inter> span B" by blast
   hence "A \<inter> B = {}" unfolding assms(3) using assms(1, 2) dependent_zero by blast
   assume "dependent (A \<union> B)"
   then obtain T u v where "finite T" and "T \<subseteq> A \<union> B" and eq: "(\<Sum>v\<in>T. u v *s v) = 0"
     and "v \<in> T" and "u v \<noteq> 0" unfolding dependent_explicit by blast
   define TA where "TA = T \<inter> A"
   define TB where "TB = T \<inter> B"
   from \<open>T \<subseteq> A \<union> B\<close> have T: "T = TA \<union> TB" by (auto simp: TA_def TB_def)
   from \<open>finite T\<close> have "finite TA" and "TA \<subseteq> A" by (simp_all add: TA_def)
   from \<open>finite T\<close> have "finite TB" and "TB \<subseteq> B" by (simp_all add: TB_def)
   from \<open>A \<inter> B = {}\<close> \<open>TA \<subseteq> A\<close> this(2) have "TA \<inter> TB = {}" by blast
   have "0 = (\<Sum>v\<in>TA \<union> TB. u v *s v)" by (simp only: eq flip: T)
   also have "\<dots> = (\<Sum>v\<in>TA. u v *s v) + (\<Sum>v\<in>TB. u v *s v)" by (rule sum.union_disjoint) fact+
   finally have "(\<Sum>v\<in>TA. u v *s v) = (\<Sum>v\<in>TB. (- u) v *s v)" (is "?x = ?y")
     by (simp add: sum_negf eq_neg_iff_add_eq_0)
   from \<open>finite TB\<close> \<open>TB \<subseteq> B\<close> have "?y \<in> span B" by (auto simp: span_explicit simp del: uminus_apply)
   moreover from \<open>finite TA\<close> \<open>TA \<subseteq> A\<close> have "?x \<in> span A" by (auto simp: span_explicit)
   ultimately have "?y \<in> span A \<inter> span B" by (simp add: \<open>?x = ?y\<close>)
   hence "?x = 0" and "?y = 0" by (simp_all add: \<open>?x = ?y\<close> assms(3))
   from \<open>v \<in> T\<close> have "v \<in> TA \<union> TB" by (simp only: T)
   hence "u v = 0"
   proof
     assume "v \<in> TA"
     with assms(1) \<open>finite TA\<close> \<open>TA \<subseteq> A\<close> \<open>?x = 0\<close> show "u v = 0" by (rule independentD)
   next
     assume "v \<in> TB"
     with assms(2) \<open>finite TB\<close> \<open>TB \<subseteq> B\<close> \<open>?y = 0\<close> have "(- u) v = 0" by (rule independentD)
     thus "u v = 0" by simp
   qed
   with \<open>u v \<noteq> 0\<close> show False ..
 qed
 
 lemma subspace_direct_decomp:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> subspace s"
   shows "subspace A"
 proof (rule subspaceI)
   let ?qs = "map (\<lambda>_. 0) ss"
   from assms(2) have "?qs \<in> listset ss"
     by (induct ss) (auto simp del: listset.simps(2) dest: subspace_0 intro: listset_ConsI)
   with assms(1) have "sum_list ?qs \<in> A" by (rule direct_decompD)
   thus "0 \<in> A" by simp
 next
   fix p q
   assume "p \<in> A"
   with assms(1) obtain ps where ps: "ps \<in> listset ss" and p: "p = sum_list ps" by (rule direct_decompE)
   assume "q \<in> A"
   with assms(1) obtain qs where qs: "qs \<in> listset ss" and q: "q = sum_list qs" by (rule direct_decompE)
   from ps qs have l: "length ps = length qs" by (simp only: listsetD)
   from ps qs have "map2 (+) ps qs \<in> listset ss" (is "?qs \<in> _")
     by (rule listset_closed_map2) (auto dest: assms(2) subspace_add)
   with assms(1) have "sum_list ?qs \<in> A" by (rule direct_decompD)
   thus "p + q \<in> A" using l by (simp only: p q sum_list_map2_plus)
 next
   fix c p
   assume "p \<in> A"
   with assms(1) obtain ps where "ps \<in> listset ss" and p: "p = sum_list ps" by (rule direct_decompE)
   from this(1) have "map ((*s) c) ps \<in> listset ss" (is "?qs \<in> _")
     by (rule listset_closed_map) (auto dest: assms(2) subspace_scale)
   with assms(1) have "sum_list ?qs \<in> A" by (rule direct_decompD)
   also have "sum_list ?qs = c *s sum_list ps" by (induct ps) (simp_all add: scale_right_distrib)
   finally show "c *s p \<in> A" by (simp only: p)
 qed
 
 lemma is_basis_alt: "subspace V \<Longrightarrow> is_basis V B \<longleftrightarrow> (independent B \<and> span B = V)"
   by (metis (full_types) is_basis_def dim_eq_card span_eq span_eq_iff)
 
 lemma is_basis_finite: "is_basis V A \<Longrightarrow> is_basis V B \<Longrightarrow> finite A \<longleftrightarrow> finite B"
   unfolding is_basis_def using independent_span_bound by auto
 
 lemma some_basis_is_basis: "is_basis V (some_basis V)"
 proof -
   obtain B where "B \<subseteq> V" and "independent B" and "V \<subseteq> span B" and "card B = dim V"
     by (rule basis_exists)
   hence "is_basis V B" by (simp add: is_basis_def)
   thus ?thesis unfolding some_basis_def by (rule someI)
 qed
 
 corollary
   shows some_basis_subset: "some_basis V \<subseteq> V"
     and independent_some_basis: "independent (some_basis V)"
     and span_some_basis_supset: "V \<subseteq> span (some_basis V)"
     and card_some_basis: "card (some_basis V) = dim V"
   using some_basis_is_basis[of V] by (simp_all add: is_basis_def)
 
 lemma some_basis_not_zero: "0 \<notin> some_basis V"
   using independent_some_basis dependent_zero by blast
 
 lemma span_some_basis: "subspace V \<Longrightarrow> span (some_basis V) = V"
   by (simp add: span_subspace some_basis_subset span_some_basis_supset)
 
 lemma direct_decomp_some_basis_pairwise_disjnt:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> subspace s"
   shows "pairwise (\<lambda>s1 s2. disjnt (some_basis s1) (some_basis s2)) (set ss)"
 proof (rule pairwiseI)
   fix s1 s2
   assume "s1 \<in> set ss" and "s2 \<in> set ss" and "s1 \<noteq> s2"
   have "some_basis s1 \<inter> some_basis s2 \<subseteq> s1 \<inter> s2" using some_basis_subset by blast
   also from direct_decomp_pairwise_zero have "\<dots> = {0}"
   proof (rule pairwiseD)
     fix s
     assume "s \<in> set ss"
     hence "subspace s" by (rule assms(2))
     thus "0 \<in> s" by (rule subspace_0)
   qed fact+
   finally have "some_basis s1 \<inter> some_basis s2 \<subseteq> {0}" .
   with some_basis_not_zero show "disjnt (some_basis s1) (some_basis s2)"
     unfolding disjnt_def by blast
 qed
 
 lemma direct_decomp_span_some_basis:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> subspace s"
   shows "span (\<Union>(some_basis ` set ss)) = A"
 proof -
   from assms(1) have eq0[symmetric]: "sum_list ` listset ss = A" by (rule direct_decompD)
   show ?thesis unfolding eq0 using assms(2)
   proof (induct ss)
     case Nil
     show ?case by simp
   next
     case (Cons s ss)
     have "subspace s" by (rule Cons.prems) simp
     hence eq1: "span (some_basis s) = s" by (rule span_some_basis)
     have "\<And>s'. s' \<in> set ss \<Longrightarrow> subspace s'" by (rule Cons.prems) simp
     hence eq2: "span (\<Union> (some_basis ` set ss)) = sum_list ` listset ss" by (rule Cons.hyps)
     have "span (\<Union> (some_basis ` set (s # ss))) = {x + y |x y. x \<in> s \<and> y \<in> sum_list ` listset ss}"
       by (simp add: span_Un eq1 eq2)
     also have "\<dots> = sum_list ` listset (s # ss)" (is "?A = ?B")
     proof
       show "?A \<subseteq> ?B"
       proof
         fix a
         assume "a \<in> ?A"
         then obtain x y where "x \<in> s" and "y \<in> sum_list ` listset ss" and a: "a = x + y" by blast
         from this(2) obtain qs where "qs \<in> listset ss" and y: "y = sum_list qs" ..
         from \<open>x \<in> s\<close> this(1) refl have "x # qs \<in> listset (s # ss)" by (rule listset_ConsI)
         hence "sum_list (x # qs) \<in> ?B" by (rule imageI)
         also have "sum_list (x # qs) = a" by (simp add: a y)
         finally show "a \<in> ?B" .
       qed
     next
       show "?B \<subseteq> ?A"
       proof
         fix a
         assume "a \<in> ?B"
         then obtain qs' where "qs' \<in> listset (s # ss)" and a: "a = sum_list qs'" ..
         from this(1) obtain x qs where "x \<in> s" and "qs \<in> listset ss" and qs': "qs' = x # qs"
           by (rule listset_ConsE)
         from this(2) have "sum_list qs \<in> sum_list ` listset ss" by (rule imageI)
         moreover have "a = x + sum_list qs" by (simp add: a qs')
         ultimately show "a \<in> ?A" using \<open>x \<in> s\<close> by blast
       qed
     qed
     finally show ?case .
   qed
 qed
 
 lemma direct_decomp_independent_some_basis:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> subspace s"
   shows "independent (\<Union>(some_basis ` set ss))"
   using assms
 proof (induct ss arbitrary: A)
   case Nil
   from independent_empty show ?case by simp
 next
   case (Cons s ss)
   have 1: "\<And>s'. s' \<in> set ss \<Longrightarrow> subspace s'" by (rule Cons.prems) simp
   have "subspace s" by (rule Cons.prems) simp
   hence "0 \<in> s" and eq1: "span (some_basis s) = s" by (rule subspace_0, rule span_some_basis)
   from Cons.prems(1) have *: "direct_decomp A ([s] @ ss)" by simp
   moreover from \<open>0 \<in> s\<close> have "{} \<notin> set [s]" by auto
   ultimately have 2: "direct_decomp (sum_list ` listset ss) ss" by (rule direct_decomp_appendD)
   hence eq2: "span (\<Union> (some_basis ` set ss)) = sum_list ` listset ss" using 1
     by (rule direct_decomp_span_some_basis)
 
   note independent_some_basis[of s]
   moreover from 2 1 have "independent (\<Union> (some_basis ` set ss))" by (rule Cons.hyps)
   moreover have "span (some_basis s) \<inter> span (\<Union> (some_basis ` set ss)) = {0}"
   proof -
     from * have "direct_decomp A [sum_list ` listset [s], sum_list ` listset ss]"
       by (rule direct_decomp_appendD)
     hence "direct_decomp A [s, sum_list ` listset ss]" by (simp add: image_image)
     moreover have "0 < (1::nat)" by simp
     moreover have "1 < length [s, sum_list ` listset ss]" by simp
     ultimately have "[s, sum_list ` listset ss] ! 0 \<inter> [s, sum_list ` listset ss] ! 1 = {0}"
       by (rule direct_decomp_Int_zero) (auto simp: \<open>0 \<in> s\<close> eq2[symmetric] span_zero)
     thus ?thesis by (simp add: eq1 eq2)
   qed
   ultimately have "independent (some_basis s \<union> (\<Union> (some_basis ` set ss)))"
     by (rule independent_UnI)
   thus ?case by simp
 qed
 
 corollary direct_decomp_is_basis:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> subspace s"
   shows "is_basis A (\<Union>(some_basis ` set ss))"
 proof -
   from assms have "subspace A" by (rule subspace_direct_decomp)
   moreover from assms have "span (\<Union>(some_basis ` set ss)) = A"
     by (rule direct_decomp_span_some_basis)
   moreover from assms have "independent (\<Union>(some_basis ` set ss))"
     by (rule direct_decomp_independent_some_basis)
   ultimately show ?thesis by (simp add: is_basis_alt)
 qed
 
 lemma dim_direct_decomp:
   assumes "direct_decomp A ss" and "finite B" and "A \<subseteq> span B" and "\<And>s. s \<in> set ss \<Longrightarrow> subspace s"
   shows "dim A = (\<Sum>s\<in>set ss. dim s)"
 proof -
   from assms(1, 4) have "is_basis A (\<Union>(some_basis ` set ss))"
     (is "is_basis A ?B") by (rule direct_decomp_is_basis)
   hence "dim A = card ?B" and "independent ?B" and "?B \<subseteq> A" by (simp_all add: is_basis_def)
   from this(3) assms(3) have "?B \<subseteq> span B" by (rule subset_trans)
   with assms(2) \<open>independent ?B\<close> have "finite ?B" using independent_span_bound by blast
   note \<open>dim A = card ?B\<close>
   also from finite_set have "card ?B = (\<Sum>s\<in>set ss. card (some_basis s))"
   proof (intro card_UN_disjoint ballI impI)
     fix s
     assume "s \<in> set ss"
     with \<open>finite ?B\<close> show "finite (some_basis s)" by auto
   next
     fix s1 s2
     have "pairwise (\<lambda>s t. disjnt (some_basis s) (some_basis t)) (set ss)"
       using assms(1, 4) by (rule direct_decomp_some_basis_pairwise_disjnt)
     moreover assume "s1 \<in> set ss" and "s2 \<in> set ss" and "s1 \<noteq> s2"
     thm pairwiseD
     ultimately have "disjnt (some_basis s1) (some_basis s2)" by (rule pairwiseD)
     thus "some_basis s1 \<inter> some_basis s2 = {}" by (simp only: disjnt_def)
   qed
   also from refl card_some_basis have "\<dots> = (\<Sum>s\<in>set ss. dim s)" by (rule sum.cong)
   finally show ?thesis .
 qed
 
 end (* vector_space *)
 
 subsection \<open>Homogeneous Sets of Polynomials with Fixed Degree\<close>
 
 lemma homogeneous_set_direct_decomp:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> homogeneous_set s"
   shows "homogeneous_set A"
 proof (rule homogeneous_setI)
   fix a n
   assume "a \<in> A"
   with assms(1) obtain qs where "qs \<in> listset ss" and a: "a = sum_list qs" by (rule direct_decompE)
   have "hom_component a n = hom_component (sum_list qs) n" by (simp only: a)
   also have "\<dots> = sum_list (map (\<lambda>q. hom_component q n) qs)"
     by (induct qs) (simp_all add: hom_component_plus)
   also from assms(1) have "\<dots> \<in> A"
   proof (rule direct_decompD)
     show "map (\<lambda>q. hom_component q n) qs \<in> listset ss"
     proof (rule listset_closed_map)
       fix s q
       assume "s \<in> set ss"
       hence "homogeneous_set s" by (rule assms(2))
       moreover assume "q \<in> s"
       ultimately show "hom_component q n \<in> s" by (rule homogeneous_setD)
     qed fact
   qed
   finally show "hom_component a n \<in> A" .
 qed
 
 definition hom_deg_set :: "nat \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) set"
   where "hom_deg_set z A = (\<lambda>a. hom_component a z) ` A"
 
 lemma hom_deg_setD:
   assumes "p \<in> hom_deg_set z A"
   shows "homogeneous p" and "p \<noteq> 0 \<Longrightarrow> poly_deg p = z"
 proof -
   from assms obtain a where "a \<in> A" and p: "p = hom_component a z" unfolding hom_deg_set_def ..
   show *: "homogeneous p" by (simp only: p homogeneous_hom_component)
 
   assume "p \<noteq> 0"
   hence "keys p \<noteq> {}" by simp
   then obtain t where "t \<in> keys p" by blast
   with * have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
   moreover from \<open>t \<in> keys p\<close> have "deg_pm t = z" unfolding p by (rule keys_hom_componentD)
   ultimately show "poly_deg p = z" by simp
 qed
 
 lemma zero_in_hom_deg_set:
   assumes "0 \<in> A"
   shows "0 \<in> hom_deg_set z A"
 proof -
   have "0 = hom_component 0 z" by simp
   also from assms have "\<dots> \<in> hom_deg_set z A" unfolding hom_deg_set_def by (rule imageI)
   finally show ?thesis .
 qed
 
 lemma hom_deg_set_closed_uminus:
   assumes "\<And>a. a \<in> A \<Longrightarrow> - a \<in> A" and "p \<in> hom_deg_set z A"
   shows "- p \<in> hom_deg_set z A"
 proof -
   from assms(2) obtain a where "a \<in> A" and p: "p = hom_component a z" unfolding hom_deg_set_def ..
   from this(1) have "- a \<in> A" by (rule assms(1))
   moreover have "- p = hom_component (- a) z" by (simp add: p)
   ultimately show ?thesis unfolding hom_deg_set_def by (rule rev_image_eqI)
 qed
 
 lemma hom_deg_set_closed_plus:
   assumes "\<And>a1 a2. a1 \<in> A \<Longrightarrow> a2 \<in> A \<Longrightarrow> a1 + a2 \<in> A"
     and "p \<in> hom_deg_set z A" and "q \<in> hom_deg_set z A"
   shows "p + q \<in> hom_deg_set z A"
 proof -
   from assms(2) obtain a1 where "a1 \<in> A" and p: "p = hom_component a1 z" unfolding hom_deg_set_def ..
   from assms(3) obtain a2 where "a2 \<in> A" and q: "q = hom_component a2 z" unfolding hom_deg_set_def ..
   from \<open>a1 \<in> A\<close> this(1) have "a1 + a2 \<in> A" by (rule assms(1))
   moreover have "p + q = hom_component (a1 + a2) z" by (simp only: p q hom_component_plus)
   ultimately show ?thesis unfolding hom_deg_set_def by (rule rev_image_eqI)
 qed
 
 lemma hom_deg_set_closed_minus:
   assumes "\<And>a1 a2. a1 \<in> A \<Longrightarrow> a2 \<in> A \<Longrightarrow> a1 - a2 \<in> A"
     and "p \<in> hom_deg_set z A" and "q \<in> hom_deg_set z A"
   shows "p - q \<in> hom_deg_set z A"
 proof -
   from assms(2) obtain a1 where "a1 \<in> A" and p: "p = hom_component a1 z" unfolding hom_deg_set_def ..
   from assms(3) obtain a2 where "a2 \<in> A" and q: "q = hom_component a2 z" unfolding hom_deg_set_def ..
   from \<open>a1 \<in> A\<close> this(1) have "a1 - a2 \<in> A" by (rule assms(1))
   moreover have "p - q = hom_component (a1 - a2) z" by (simp only: p q hom_component_minus)
   ultimately show ?thesis unfolding hom_deg_set_def by (rule rev_image_eqI)
 qed
 
 lemma hom_deg_set_closed_scalar:
   assumes "\<And>a. a \<in> A \<Longrightarrow> c \<cdot> a \<in> A" and "p \<in> hom_deg_set z A"
   shows "(c::'a::semiring_0) \<cdot> p \<in> hom_deg_set z A"
 proof -
   from assms(2) obtain a where "a \<in> A" and p: "p = hom_component a z" unfolding hom_deg_set_def ..
   from this(1) have "c \<cdot> a \<in> A" by (rule assms(1))
   moreover have "c \<cdot> p = hom_component (c \<cdot> a) z"
     by (simp add: p punit.map_scale_eq_monom_mult hom_component_monom_mult)
   ultimately show ?thesis unfolding hom_deg_set_def by (rule rev_image_eqI)
 qed
 
 lemma hom_deg_set_closed_sum:
   assumes "0 \<in> A" and "\<And>a1 a2. a1 \<in> A \<Longrightarrow> a2 \<in> A \<Longrightarrow> a1 + a2 \<in> A"
     and "\<And>i. i \<in> I \<Longrightarrow> f i \<in> hom_deg_set z A"
   shows "sum f I \<in> hom_deg_set z A"
   using assms(3)
 proof (induct I rule: infinite_finite_induct)
   case (infinite I)
   with assms(1) show ?case by (simp add: zero_in_hom_deg_set)
 next
   case empty
   with assms(1) show ?case by (simp add: zero_in_hom_deg_set)
 next
   case (insert j I)
   from insert.hyps(1, 2) have "sum f (insert j I) = f j + sum f I" by simp
   also from assms(2) have "\<dots> \<in> hom_deg_set z A"
   proof (intro hom_deg_set_closed_plus insert.hyps)
     show "f j \<in> hom_deg_set z A" by (rule insert.prems) simp
   next
     fix i
     assume "i \<in> I"
     hence "i \<in> insert j I" by simp
     thus "f i \<in> hom_deg_set z A" by (rule insert.prems)
   qed
   finally show ?case .
 qed
 
 lemma hom_deg_set_subset: "homogeneous_set A \<Longrightarrow> hom_deg_set z A \<subseteq> A"
   by (auto dest: homogeneous_setD simp: hom_deg_set_def)
 
 lemma Polys_closed_hom_deg_set:
   assumes "A \<subseteq> P[X]"
   shows "hom_deg_set z A \<subseteq> P[X]"
 proof
   fix p
   assume "p \<in> hom_deg_set z A"
   then obtain p' where "p' \<in> A" and p: "p = hom_component p' z" unfolding hom_deg_set_def ..
   from this(1) assms have "p' \<in> P[X]" ..
   have "keys p \<subseteq> keys p'" by (simp add: p keys_hom_component)
   also from \<open>p' \<in> P[X]\<close> have "\<dots> \<subseteq> .[X]" by (rule PolysD)
   finally show "p \<in> P[X]" by (rule PolysI)
 qed
 
 lemma hom_deg_set_alt_homogeneous_set:
   assumes "homogeneous_set A"
   shows "hom_deg_set z A = {p \<in> A. homogeneous p \<and> (p = 0 \<or> poly_deg p = z)}" (is "?A = ?B")
 proof
   show "?A \<subseteq> ?B"
   proof
     fix h
     assume "h \<in> ?A"
     also from assms have "\<dots> \<subseteq> A" by (rule hom_deg_set_subset)
     finally show "h \<in> ?B" using \<open>h \<in> ?A\<close> by (auto dest: hom_deg_setD)
   qed
 next
   show "?B \<subseteq> ?A"
   proof
     fix h
     assume "h \<in> ?B"
     hence "h \<in> A" and "homogeneous h" and "h = 0 \<or> poly_deg h = z" by simp_all
     from this(3) show "h \<in> ?A"
     proof
       assume "h = 0"
       with \<open>h \<in> A\<close> have "0 \<in> A" by simp
       thus ?thesis unfolding \<open>h = 0\<close> by (rule zero_in_hom_deg_set)
     next
       assume "poly_deg h = z"
       with \<open>homogeneous h\<close> have "h = hom_component h z" by (simp add: hom_component_of_homogeneous)
       with \<open>h \<in> A\<close> show ?thesis unfolding hom_deg_set_def by (rule rev_image_eqI)
     qed
   qed
 qed
 
 lemma hom_deg_set_sum_list_listset:
   assumes "A = sum_list ` listset ss"
   shows "hom_deg_set z A = sum_list ` listset (map (hom_deg_set z) ss)" (is "?A = ?B")
 proof
   show "?A \<subseteq> ?B"
   proof
     fix h
     assume "h \<in> ?A"
     then obtain a where "a \<in> A" and h: "h = hom_component a z" unfolding hom_deg_set_def ..
     from this(1) obtain qs where "qs \<in> listset ss" and a: "a = sum_list qs" unfolding assms ..
     have "h = hom_component (sum_list qs) z" by (simp only: a h)
     also have "\<dots> = sum_list (map (\<lambda>q. hom_component q z) qs)"
       by (induct qs) (simp_all add: hom_component_plus)
     also have "\<dots> \<in> ?B"
     proof (rule imageI)
       show "map (\<lambda>q. hom_component q z) qs \<in> listset (map (hom_deg_set z) ss)"
         unfolding hom_deg_set_def using \<open>qs \<in> listset ss\<close> refl by (rule listset_map_imageI)
     qed
     finally show "h \<in> ?B" .
   qed
 next
   show "?B \<subseteq> ?A"
   proof
     fix h
     assume "h \<in> ?B"
     then obtain qs where "qs \<in> listset (map (hom_deg_set z) ss)" and h: "h = sum_list qs" ..
     from this(1) obtain qs' where "qs' \<in> listset ss" and qs: "qs = map (\<lambda>q. hom_component q z) qs'"
       unfolding hom_deg_set_def by (rule listset_map_imageE)
     have "h = sum_list (map (\<lambda>q. hom_component q z) qs')" by (simp only: h qs)
     also have "\<dots> = hom_component (sum_list qs') z" by (induct qs') (simp_all add: hom_component_plus)
     finally have "h = hom_component (sum_list qs') z" .
     moreover have "sum_list qs' \<in> A" unfolding assms using \<open>qs' \<in> listset ss\<close> by (rule imageI)
     ultimately show "h \<in> ?A" unfolding hom_deg_set_def by (rule image_eqI)
   qed
 qed
 
 lemma direct_decomp_hom_deg_set:
   assumes "direct_decomp A ss" and "\<And>s. s \<in> set ss \<Longrightarrow> homogeneous_set s"
   shows "direct_decomp (hom_deg_set z A) (map (hom_deg_set z) ss)"
 proof (rule direct_decompI)
   from assms(1) have "sum_list ` listset ss = A" by (rule direct_decompD)
   from this[symmetric] show "sum_list ` listset (map (hom_deg_set z) ss) = hom_deg_set z A"
     by (simp only: hom_deg_set_sum_list_listset)
 next
   from assms(1) have "inj_on sum_list (listset ss)" by (rule direct_decompD)
   moreover have "listset (map (hom_deg_set z) ss) \<subseteq> listset ss"
   proof (rule listset_mono)
     fix i
     assume "i < length ss"
     hence "map (hom_deg_set z) ss ! i = hom_deg_set z (ss ! i)" by simp
     also from \<open>i < length ss\<close> have "\<dots> \<subseteq> ss ! i" by (intro hom_deg_set_subset assms(2) nth_mem)
     finally show "map (hom_deg_set z) ss ! i \<subseteq> ss ! i" .
   qed simp
   ultimately show "inj_on sum_list (listset (map (hom_deg_set z) ss))" by (rule inj_on_subset)
 qed
 
 subsection \<open>Interpreting Polynomial Rings as Vector Spaces over the Coefficient Field\<close>
 
 text \<open>There is no need to set up any further interpretation, since interpretation \<open>phull\<close> is exactly
   what we need.\<close>
 
 lemma subspace_ideal: "phull.subspace (ideal (F::('b::comm_powerprod \<Rightarrow>\<^sub>0 'a::field) set))"
   using ideal.span_zero ideal.span_add
 proof (rule phull.subspaceI)
   fix c p
   assume "p \<in> ideal F"
   thus "c \<cdot> p \<in> ideal F" unfolding map_scale_eq_times by (rule ideal.span_scale)
 qed
 
 lemma subspace_Polys: "phull.subspace (P[X]::(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field) set)"
   using zero_in_Polys Polys_closed_plus Polys_closed_map_scale by (rule phull.subspaceI)
 
 lemma subspace_hom_deg_set:
   assumes "phull.subspace A"
   shows "phull.subspace (hom_deg_set z A)" (is "phull.subspace ?A")
 proof (rule phull.subspaceI)
   from assms have "0 \<in> A" by (rule phull.subspace_0)
   thus "0 \<in> ?A" by (rule zero_in_hom_deg_set)
 next
   fix p q
   assume "p \<in> ?A" and "q \<in> ?A"
   with phull.subspace_add show "p + q \<in> ?A" by (rule hom_deg_set_closed_plus) (rule assms)
 next
   fix c p
   assume "p \<in> ?A"
   with phull.subspace_scale show "c \<cdot> p \<in> ?A" by (rule hom_deg_set_closed_scalar) (rule assms)
 qed
 
 lemma hom_deg_set_Polys_eq_span:
   "hom_deg_set z P[X] = phull.span (monomial (1::'a::field) ` deg_sect X z)" (is "?A = ?B")
 proof
   show "?A \<subseteq> ?B"
   proof
     fix p
     assume "p \<in> ?A"
     also from this have "\<dots> = {p \<in> P[X]. homogeneous p \<and> (p = 0 \<or> poly_deg p = z)}"
       by (simp only: hom_deg_set_alt_homogeneous_set[OF homogeneous_set_Polys])
     finally have "p \<in> P[X]" and "homogeneous p" and "p \<noteq> 0 \<Longrightarrow> poly_deg p = z" by simp_all
     thus "p \<in> ?B"
     proof (induct p rule: poly_mapping_plus_induct)
       case 1
       from phull.span_zero show ?case .
     next
       case (2 p c t)
       let ?m = "monomial c t"
       from 2(1) have "t \<in> keys ?m" by simp
       hence "t \<in> keys (?m + p)" using 2(2) by (rule in_keys_plusI1)
       hence "?m + p \<noteq> 0" by auto
       hence "poly_deg (monomial c t + p) = z" by (rule 2)
       from 2(4) have "keys (?m + p) \<subseteq> .[X]" by (rule PolysD)
       with \<open>t \<in> keys (?m + p)\<close> have "t \<in> .[X]" ..
       hence "?m \<in> P[X]" by (rule Polys_closed_monomial)
       have "t \<in> deg_sect X z"
       proof (rule deg_sectI)
         from 2(5) \<open>t \<in> keys (?m + p)\<close> have "deg_pm t = poly_deg (?m + p)"
           by (rule homogeneousD_poly_deg)
         also have "\<dots> = z" by fact
         finally show "deg_pm t = z" .
       qed fact
       hence "monomial 1 t \<in> monomial 1 ` deg_sect X z" by (rule imageI)
       hence "monomial 1 t \<in> ?B" by (rule phull.span_base)
       hence "c \<cdot> monomial 1 t \<in> ?B" by (rule phull.span_scale)
       hence "?m \<in> ?B" by simp
       moreover have "p \<in> ?B"
       proof (rule 2)
         from 2(4) \<open>?m \<in> P[X]\<close> have "(?m + p) - ?m \<in> P[X]" by (rule Polys_closed_minus)
         thus "p \<in> P[X]" by simp
       next
         have 1: "deg_pm s = z" if "s \<in> keys p" for s
         proof -
           from that 2(2) have "s \<noteq> t" by blast
           hence "s \<notin> keys ?m" by simp
           with that have "s \<in> keys (?m + p)" by (rule in_keys_plusI2)
           with 2(5) have "deg_pm s = poly_deg (?m + p)" by (rule homogeneousD_poly_deg)
           also have "\<dots> = z" by fact
           finally show ?thesis .
         qed
         show "homogeneous p" by (rule homogeneousI) (simp add: 1)
 
         assume "p \<noteq> 0"
         show "poly_deg p = z"
         proof (rule antisym)
           show "poly_deg p \<le> z" by (rule poly_deg_leI) (simp add: 1)
         next
           from \<open>p \<noteq> 0\<close> have "keys p \<noteq> {}" by simp
           then obtain s where "s \<in> keys p" by blast
           hence "z = deg_pm s" by (simp only: 1)
           also from \<open>s \<in> keys p\<close> have "\<dots> \<le> poly_deg p" by (rule poly_deg_max_keys)
           finally show "z \<le> poly_deg p" .
         qed
       qed
       ultimately show ?case by (rule phull.span_add)
     qed
   qed
 next
   show "?B \<subseteq> ?A"
   proof
     fix p
     assume "p \<in> ?B"
     then obtain M u where "M \<subseteq> monomial 1 ` deg_sect X z" and "finite M" and p: "p = (\<Sum>m\<in>M. u m \<cdot> m)"
       by (auto simp: phull.span_explicit)
     from this(1) obtain T where "T \<subseteq> deg_sect X z" and M: "M = monomial 1 ` T"
       and inj: "inj_on (monomial (1::'a)) T" by (rule subset_imageE_inj)
     define c where "c = (\<lambda>t. u (monomial 1 t))"
     from inj have "p = (\<Sum>t\<in>T. monomial (c t) t)" by (simp add: p M sum.reindex c_def)
     also have "\<dots> \<in> ?A"
     proof (intro hom_deg_set_closed_sum zero_in_Polys Polys_closed_plus)
       fix t
       assume "t \<in> T"
       hence "t \<in> deg_sect X z" using \<open>T \<subseteq> deg_sect X z\<close> ..
       hence "t \<in> .[X]" and eq: "deg_pm t = z" by (rule deg_sectD)+
       from this(1) have "monomial (c t) t \<in> P[X]" (is "?m \<in> _") by (rule Polys_closed_monomial)
       thus "?m \<in> ?A"
         by (simp add: hom_deg_set_alt_homogeneous_set[OF homogeneous_set_Polys] poly_deg_monomial
             monomial_0_iff eq)
     qed
     finally show "p \<in> ?A" .
   qed
 qed
 
 subsection \<open>(Projective) Hilbert Function\<close>
 
 interpretation phull: vector_space map_scale
   apply standard
   subgoal by (fact map_scale_distrib_left)
   subgoal by (fact map_scale_distrib_right)
   subgoal by (fact map_scale_assoc)
   subgoal by (fact map_scale_one_left)
   done
 
 definition Hilbert_fun :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field) set \<Rightarrow> nat \<Rightarrow> nat"
   where "Hilbert_fun A z = phull.dim (hom_deg_set z A)"
 
 lemma Hilbert_fun_empty [simp]: "Hilbert_fun {} = 0"
   by (rule ext) (simp add: Hilbert_fun_def hom_deg_set_def)
 
 lemma Hilbert_fun_zero [simp]: "Hilbert_fun {0} = 0"
   by (rule ext) (simp add: Hilbert_fun_def hom_deg_set_def)
 
 lemma Hilbert_fun_direct_decomp:
   assumes "finite X" and "A \<subseteq> P[X]" and "direct_decomp (A::(('x::countable \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::field) set) ps"
     and "\<And>s. s \<in> set ps \<Longrightarrow> homogeneous_set s" and "\<And>s. s \<in> set ps \<Longrightarrow> phull.subspace s"
   shows "Hilbert_fun A z = (\<Sum>p\<in>set ps. Hilbert_fun p z)"
 proof -
   from assms(3, 4) have dd: "direct_decomp (hom_deg_set z A) (map (hom_deg_set z) ps)"
     by (rule direct_decomp_hom_deg_set)
   have "Hilbert_fun A z = phull.dim (hom_deg_set z A)" by (fact Hilbert_fun_def)
   also from dd have "\<dots> = sum phull.dim (set (map (hom_deg_set z) ps))"
   proof (rule phull.dim_direct_decomp)
     from assms(1) have "finite (deg_sect X z)" by (rule finite_deg_sect)
     thus "finite (monomial (1::'a) ` deg_sect X z)" by (rule finite_imageI)
   next
     from assms(2) have "hom_deg_set z A \<subseteq> hom_deg_set z P[X]"
       unfolding hom_deg_set_def by (rule image_mono)
     thus "hom_deg_set z A \<subseteq> phull.span (monomial 1 ` deg_sect X z)"
       by (simp only: hom_deg_set_Polys_eq_span)
   next
     fix s
     assume "s \<in> set (map (hom_deg_set z) ps)"
     then obtain s' where "s' \<in> set ps" and s: "s = hom_deg_set z s'" unfolding set_map ..
     from this(1) have "phull.subspace s'" by (rule assms(5))
     thus "phull.subspace s" unfolding s by (rule subspace_hom_deg_set)
   qed
   also have "\<dots> = sum (phull.dim \<circ> hom_deg_set z) (set ps)" unfolding set_map using finite_set
   proof (rule sum.reindex_nontrivial)
     fix s1 s2
     note dd
     moreover assume "s1 \<in> set ps" and "s2 \<in> set ps" and "s1 \<noteq> s2"
     moreover have "0 \<in> hom_deg_set z s" if "s \<in> set ps" for s
     proof (rule zero_in_hom_deg_set)
       from that have "phull.subspace s" by (rule assms(5))
       thus "0 \<in> s" by (rule phull.subspace_0)
     qed
     ultimately have "hom_deg_set z s1 \<inter> hom_deg_set z s2 = {0}" by (rule direct_decomp_map_Int_zero)
     moreover assume "hom_deg_set z s1 = hom_deg_set z s2"
     ultimately show "phull.dim (hom_deg_set z s1) = 0" by simp
   qed
   also have "\<dots> = (\<Sum>p\<in>set ps. Hilbert_fun p z)" by (simp only: o_def Hilbert_fun_def)
   finally show ?thesis .
 qed
 
 context pm_powerprod
 begin
 
 lemma image_lt_hom_deg_set:
   assumes "homogeneous_set A"
   shows "lpp ` (hom_deg_set z A - {0}) = {t \<in> lpp ` (A - {0}). deg_pm t = z}" (is "?B = ?A")
 proof (intro set_eqI iffI)
   fix t
   assume "t \<in> ?A"
   hence "t \<in> lpp ` (A - {0})" and deg_t[symmetric]: "deg_pm t = z" by simp_all
   from this(1) obtain p where "p \<in> A - {0}" and t: "t = lpp p" ..
   from this(1) have "p \<in> A" and "p \<noteq> 0" by simp_all
   from this(1) have 1: "hom_component p z \<in> hom_deg_set z A" (is "?p \<in> _")
     unfolding hom_deg_set_def by (rule imageI)
   from \<open>p \<noteq> 0\<close> have "?p \<noteq> 0" and "lpp ?p = t" unfolding t deg_t by (rule hom_component_lpp)+
   note this(2)[symmetric]
   moreover from 1 \<open>?p \<noteq> 0\<close> have "?p \<in> hom_deg_set z A - {0}" by simp
   ultimately show "t \<in> ?B" by (rule image_eqI)
 next
   fix t
   assume "t \<in> ?B"
   then obtain p where "p \<in> hom_deg_set z A - {0}" and t: "t = lpp p" ..
   from this(1) have "p \<in> hom_deg_set z A" and "p \<noteq> 0" by simp_all
   with assms have "p \<in> A" and "homogeneous p" and "poly_deg p = z"
     by (simp_all add: hom_deg_set_alt_homogeneous_set)
   from this(1) \<open>p \<noteq> 0\<close> have "p \<in> A - {0}" by simp
   hence 1: "t \<in> lpp ` (A - {0})" using t by (rule rev_image_eqI)
   from \<open>p \<noteq> 0\<close> have "t \<in> keys p" unfolding t by (rule punit.lt_in_keys)
   with \<open>homogeneous p\<close> have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
   with 1 show "t \<in> ?A" by (simp add: \<open>poly_deg p = z\<close>)
 qed
 
 lemma Hilbert_fun_alt:
   assumes "finite X" and "A \<subseteq> P[X]" and "phull.subspace A"
   shows "Hilbert_fun A z = card (lpp ` (hom_deg_set z A - {0}))" (is "_ = card ?A")
 proof -
   have "?A \<subseteq> lpp ` (hom_deg_set z A - {0})" by simp
   then obtain B where sub: "B \<subseteq> hom_deg_set z A - {0}" and eq1: "?A = lpp ` B"
     and inj: "inj_on lpp B" by (rule subset_imageE_inj)
   have "Hilbert_fun A z = phull.dim (hom_deg_set z A)" by (fact Hilbert_fun_def)
   also have "\<dots> = card B"
   proof (rule phull.dim_eq_card)
     show "phull.span B = phull.span (hom_deg_set z A)"
     proof
       from sub have "B \<subseteq> hom_deg_set z A" by blast
       thus "phull.span B \<subseteq> phull.span (hom_deg_set z A)" by (rule phull.span_mono)
     next
       from assms(3) have "phull.subspace (hom_deg_set z A)" by (rule subspace_hom_deg_set)
       hence "phull.span (hom_deg_set z A) = hom_deg_set z A" by (simp only: phull.span_eq_iff)
       also have "\<dots> \<subseteq> phull.span B"
       proof (rule ccontr)
         assume "\<not> hom_deg_set z A \<subseteq> phull.span B"
         then obtain p0 where "p0 \<in> hom_deg_set z A - phull.span B" (is "_ \<in> ?B") by blast
         note assms(1) this
         moreover have "?B \<subseteq> P[X]"
         proof (rule subset_trans)
           from assms(2) show "hom_deg_set z A \<subseteq> P[X]" by (rule Polys_closed_hom_deg_set)
         qed blast
         ultimately obtain p where "p \<in> ?B" and p_min: "\<And>q. punit.ord_strict_p q p \<Longrightarrow> q \<notin> ?B"
           by (rule punit.ord_p_minimum_dgrad_p_set[OF dickson_grading_varnum, where m=0,
                     simplified dgrad_p_set_varnum]) blast
         from this(1) have "p \<in> hom_deg_set z A" and "p \<notin> phull.span B" by simp_all
         from phull.span_zero this(2) have "p \<noteq> 0" by blast
         with \<open>p \<in> hom_deg_set z A\<close> have "p \<in> hom_deg_set z A - {0}" by simp
         hence "lpp p \<in> lpp ` (hom_deg_set z A - {0})" by (rule imageI)
         also have "\<dots> = lpp ` B" by (simp only: eq1)
         finally obtain b where "b \<in> B" and eq2: "lpp p = lpp b" ..
         from this(1) sub have "b \<in> hom_deg_set z A - {0}" ..
         hence "b \<in> hom_deg_set z A" and "b \<noteq> 0" by simp_all
         from this(2) have lcb: "punit.lc b \<noteq> 0" by (rule punit.lc_not_0)
         from \<open>p \<noteq> 0\<close> have lcp: "punit.lc p \<noteq> 0" by (rule punit.lc_not_0)
         from \<open>b \<in> B\<close> have "b \<in> phull.span B" by (rule phull.span_base)
         hence "(punit.lc p / punit.lc b) \<cdot> b \<in> phull.span B" (is "?b \<in> _") by (rule phull.span_scale)
         with \<open>p \<notin> phull.span B\<close> have "p - ?b \<noteq> 0" by auto
         moreover from lcb lcp \<open>b \<noteq> 0\<close> have "lpp ?b = lpp p"
           by (simp add: punit.map_scale_eq_monom_mult punit.lt_monom_mult eq2)
         moreover from lcb have "punit.lc ?b = punit.lc p" by (simp add: punit.map_scale_eq_monom_mult)
         ultimately have "lpp (p - ?b) \<prec> lpp p" by (rule punit.lt_minus_lessI)
         hence "punit.ord_strict_p (p - ?b) p" by (rule punit.lt_ord_p)
         hence "p - ?b \<notin> ?B" by (rule p_min)
         hence "p - ?b \<notin> hom_deg_set z A \<or> p - ?b \<in> phull.span B" by simp
         thus False
         proof
           assume *: "p - ?b \<notin> hom_deg_set z A"
           from phull.subspace_scale have "?b \<in> hom_deg_set z A"
           proof (rule hom_deg_set_closed_scalar)
             show "phull.subspace A" by fact
           next
             show "b \<in> hom_deg_set z A" by fact
           qed
           with phull.subspace_diff \<open>p \<in> hom_deg_set z A\<close> have "p - ?b \<in> hom_deg_set z A"
             by (rule hom_deg_set_closed_minus) (rule assms(3))
           with * show ?thesis ..
         next
           assume "p - ?b \<in> phull.span B"
           hence "p - ?b + ?b \<in> phull.span B" using \<open>?b \<in> phull.span B\<close> by (rule phull.span_add)
           hence "p \<in> phull.span B" by simp
           with \<open>p \<notin> phull.span B\<close> show ?thesis ..
         qed
       qed
       finally show "phull.span (hom_deg_set z A) \<subseteq> phull.span B" .
     qed
   next
     show "phull.independent B"
     proof
       assume "phull.dependent B"
       then obtain B' u b' where "finite B'" and "B' \<subseteq> B" and "(\<Sum>b\<in>B'. u b \<cdot> b) = 0"
         and "b' \<in> B'" and "u b' \<noteq> 0" unfolding phull.dependent_explicit by blast
       define B0 where "B0 = {b \<in> B'. u b \<noteq> 0}"
       have "B0 \<subseteq> B'" by (simp add: B0_def)
       with \<open>finite B'\<close> have "(\<Sum>b\<in>B0. u b \<cdot> b) = (\<Sum>b\<in>B'. u b \<cdot> b)"
         by (rule sum.mono_neutral_left) (simp add: B0_def)
       also have "\<dots> = 0" by fact
       finally have eq: "(\<Sum>b\<in>B0. u b \<cdot> b) = 0" .
       define t where "t = ordered_powerprod_lin.Max (lpp ` B0)"
       from \<open>b' \<in> B'\<close> \<open>u b' \<noteq> 0\<close> have "b' \<in> B0" by (simp add: B0_def)
       hence "lpp b' \<in> lpp ` B0" by (rule imageI)
       hence "lpp ` B0 \<noteq> {}" by blast
       from \<open>B0 \<subseteq> B'\<close> \<open>finite B'\<close> have "finite B0" by (rule finite_subset)
       hence "finite (lpp ` B0)" by (rule finite_imageI)
       hence "t \<in> lpp ` B0" unfolding t_def using \<open>lpp ` B0 \<noteq> {}\<close>
         by (rule ordered_powerprod_lin.Max_in)
       then obtain b0 where "b0 \<in> B0" and t: "t = lpp b0" ..
       note this(1)
       moreover from \<open>B0 \<subseteq> B'\<close> \<open>B' \<subseteq> B\<close> have "B0 \<subseteq> B" by (rule subset_trans)
       also have "\<dots> \<subseteq> hom_deg_set z A - {0}" by fact
       finally have "b0 \<in> hom_deg_set z A - {0}" .
       hence "b0 \<noteq> 0" by simp
       hence "t \<in> keys b0" unfolding t by (rule punit.lt_in_keys)
       have "lookup (\<Sum>b\<in>B0. u b \<cdot> b) t = (\<Sum>b\<in>B0. u b * lookup b t)" by (simp add: lookup_sum)
       also from \<open>finite B0\<close> have "\<dots> = (\<Sum>b\<in>{b0}. u b * lookup b t)"
       proof (rule sum.mono_neutral_right)
         from \<open>b0 \<in> B0\<close> show "{b0} \<subseteq> B0" by simp
       next
         show "\<forall>b\<in>B0 - {b0}. u b * lookup b t = 0"
         proof
           fix b
           assume "b \<in> B0 - {b0}"
           hence "b \<in> B0" and "b \<noteq> b0" by simp_all
           from this(1) have "lpp b \<in> lpp ` B0" by (rule imageI)
           with \<open>finite (lpp ` B0)\<close> have "lpp b \<preceq> t" unfolding t_def
             by (rule ordered_powerprod_lin.Max_ge)
           have "t \<notin> keys b"
           proof
             assume "t \<in> keys b"
             hence "t \<preceq> lpp b" by (rule punit.lt_max_keys)
             with \<open>lpp b \<preceq> t\<close> have "lpp b = lpp b0"
               unfolding t by (rule ordered_powerprod_lin.antisym)
             from inj \<open>B0 \<subseteq> B\<close> have "inj_on lpp B0" by (rule inj_on_subset)
             hence "b = b0" using \<open>lpp b = lpp b0\<close> \<open>b \<in> B0\<close> \<open>b0 \<in> B0\<close> by (rule inj_onD)
             with \<open>b \<noteq> b0\<close> show False ..
           qed
           thus "u b * lookup b t = 0" by (simp add: in_keys_iff)
         qed
       qed
       also from \<open>t \<in> keys b0\<close> \<open>b0 \<in> B0\<close> have "\<dots> \<noteq> 0" by (simp add: B0_def in_keys_iff)
       finally show False by (simp add: eq)
     qed
   qed
   also have "\<dots> = card ?A" unfolding eq1 using inj by (rule card_image[symmetric])
   finally show ?thesis .
 qed
 
 end (* pm_powerprod *)
 
 end (* theory *)
diff --git a/thys/MuchAdoAboutTwo/MuchAdoAboutTwo.thy b/thys/MuchAdoAboutTwo/MuchAdoAboutTwo.thy
--- a/thys/MuchAdoAboutTwo/MuchAdoAboutTwo.thy
+++ b/thys/MuchAdoAboutTwo/MuchAdoAboutTwo.thy
@@ -1,2059 +1,2059 @@
 (*  Title:       Much Ado about Two
     Author:      Sascha Böhme <boehmes@informatik.tu-muenchen.de>, 2007
     Maintainer:  Sascha Böhme <boehmes@informatik.tu-muenchen.de>
 *)
 
 
 section \<open>Much Ado about Two\<close>
 
 (*<*)
 theory MuchAdoAboutTwo
-imports "HOL-Library.Permutation"
+imports "HOL-Library.List_Permutation"
 begin
 (*>*)
 
 
 text \<open>
 
 Due to Donald E. Knuth, it is known for some time that certain sorting
 functions for lists of arbitrary types can be proved correct by only showing
 that they are correct for boolean lists (\cite{KnuthSortingAndSearching},
 see also \cite{LogicalAbstractionsInHaskell}).
 This reduction idea, i.e. reducing a proof for an arbitrary type to a proof for a fixed type with a fixed number of values, has also instances in other
 fields.
 Recently, in \cite{MuchAdoAboutTwo}, a similar result as Knuth's 0-1-principle
 is explained for the problem of parallel prefix computation 
 \cite{PrefixSumsAndTheirApplications}.
 That is the task to compute, for given $x_1, \ldots, x_n$ and an associative
 operation $\oplus$, the values $x_1$, $x_1 \oplus x_2$, $\ldots$,
  $x_1 \oplus x_2 \oplus \cdots \oplus x_n$.
 There are several solutions which optimise this computation, and an
 obvious question is to ask whether these solutions are correct.
 One way to answer this question is given in \cite{MuchAdoAboutTwo}.
 There, a ``0-1-2-principle'' is proved which relates an unspecified solution
 of the parallel prefix computation, expressed as a function \<open>candidate\<close>,
 with \<open>scanl1\<close>, a functional representation of the parallel prefix
 computation. The essence proved in the mentioned paper is as follows:
 If \<open>candidate\<close> and \<open>scanl1\<close> behave identical on all lists over
 a type which has three elements, then \<open>candidate\<close> is semantically
 equivalent to \<open>scanl1\<close>, that is, \<open>candidate\<close> is a correct solution
 of the parallel prefix computation.
 
 Although it seems that nearly nothing is known about the function
 \<open>candidate\<close>, it turns out that the type of \<open>candidate\<close> already
 suffices for the proof of the paper's result. The key is relational
 parametricity \cite{TypesAbstractionsAndParametricPolymorphism} in the form of
 a free theorem \cite{TheoremsForFree}. This, some rewriting and a few 
 properties about list-processing functions thrown in allow to proof the
 ``0-1-2-principle''.
 
 The paper first shows some simple properties and derives a specialisation of
 the free theorem. The proof of the main theorem itself is split up in two 
 parts. The first, and considerably more complicated part relates lists over a
 type with three values to lists of integer lists. Here, the paper uses
 several figures to demonstrate and shorten several proofs. The second part then
 relates lists of integer list with lists over arbitrary types, and consists of
 applying the free theorem and some rewriting. The combination of these two
 parts then yields the theorem.
 
 
 
 Th article at hand formalises the proofs given in \cite{MuchAdoAboutTwo},
 which is called here ``the original paper''. Compared to that paper, there are 
 several differences in this article. The major differences are listed below.
 A more detailed collection follows thereafter.
 
 \begin{itemize}
 \item The original paper requires lists to be non-empty. Eventhough lists in
 Isabelle may also be empty, we stick to Isabelle's list datatype instead of
 declaring a new datatype, due to the huge, already existing theory about
 lists in Isabelle. As a consequence, however, several modifications become
 necessary.
 
 \item The figure-based proofs of the original paper are replaced by formal
 proofs. This forms a major part of this article (see Section 6).
 
 \item Instead of integers, we restrict ourselves to natural numbers. Thus,
 several conditions can be simplified since every natural number is greater
 than or equal to \<open>0\<close>. This decision has no further influence on the 
 proofs because they never consider negative integers.
 
 \item Mainly due to differences between Haskell and Isabelle, certain notations
 are different here compared to the original paper. List concatenation is
 denoted by \<open>@\<close> instead of $++$, and in writing down intervals, we use
 \<open>[0..<k + 1]\<close> instead of \<open>[0..k]\<close>. Moreover, we write \<open>f\<close>
 instead of $\oplus$ and \<open>g\<close> instead of $\otimes$. Functions mapping
 an element of the three-valued type to an arbitrary type are denoted by
 \<open>h\<close>.
 
 \end{itemize}
 
 Whenever we use lemmas from already existing Isabelle theories, we qualify
 them by their theory name. For example, instead of \<open>map_map\<close>, we
 write \<open>List.map_map\<close> to point out that this lemma is taken from
 Isabelle's list theory.
 
 
 
 The following comparison shows all differences of this article compared to the
 original paper. The items below follow the structure of the original paper
 (and also this article's structure). They also highlight the challenges which
 needed to be solved in formalising the original paper.
 
 \begin{itemize}
 \item Introductions of several list functions (e.g. \<open>length\<close>,
 \<open>map\<close>, \<open>take\<close>) are dropped. They exist already in Isabelle's list
 theory and are be considered familiar to the reader.
 
 \item The free theorem given in Lemma 1 of the original paper is not sufficient
 for later proofs, because the assumption is not appropriate in the context
 of Isabelle's lists, which may also be empty. Thus, here, Lemma 1 is a
 derived version of the free theorem given as Lemma 1 in the original paper,
 and some additional proof-work is done.
 
 \item Before proceeding in the original paper's way, we state and proof
 additional lemmas, which are not part of Isabelle's libraries. These lemmas
 are not specific to this article and may also be used in other theories.
 
 \item Laws 1 to 8 and Lemma 2 of the original paper are explicitly proved.
 Most of the proofs follow directly from existing results of Isabelle's list
 theory. To proof Law 7, Law 8 and Lemma 2, more work was necessary, especially
 for Law 8.
 
 \item Lemma 3 and its proof are nearly the same here as in the original paper.
 Only the additional assumptions of Lemma 1, due to Isabelle's list datatype,
 have to be shown.
 
 \item Lemma 4 is split up in several smaller lemmas, and the order of them
 tries to follow the structure of the original paper's Lemma 4.
 
 For every figure of the original paper, there is now one separate proof.
 These proofs constitute the major difference in the structure of this article
 compared to the original paper. 
 
 The proof of Lemma 4 in the original paper concludes by combining the results
 of the figure-based proofs to a non-trivial permutation property. These three
 sentences given in the original paper are split up in five separate lemmas
 and according proofs, and therefore, they as well form a major difference to
 the original paper.
 
 \item Lemma 5 is mostly identical to the version in the original paper. It has
 one additional assumption required by Lemma 4. Moreover, the proof is slightly
 more structured, and some steps needed a bit more argumentation than in the
 original paper.
 
 \item In principle, Proposition 1 is identical to the according proposition in
 the original paper. However, to fulfill the additional requirement of Lemma 5,
 an additional lemma was proved. This, however, is only necessary, because we
 use Isabelle's list type which allows lists to be empty.
 
 \item Proposition 2 contains one non-trivial step, which is proved as a
 seperate lemma. Note that this is not due to any decisions of using special
 datatypes, but inherent in the proof itself.  Apart from that, the proof is
 identical to the original paper's proof of Proposition 2.
 
 \item The final theorem is, as in the original paper, just a combination of
 Proposition 1 and Proposition 2. Only the assumptions are extended due to
 Isabelle's list datatype.
 
 \end{itemize}
 
 
 \<close>
 
 
 
 
 
 section \<open>Basic definitions\<close>
 
 
 
 fun foldl1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a"
 where
   "foldl1 f (x # xs) = foldl f x xs"
 
 fun scanl1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "scanl1 f xs = map (\<lambda>k. foldl1 f (take k xs))
                      [1..<length xs + 1]"
 
 
 text \<open>
 The original paper further relies on associative functions. Thus, we define
 another predicate to be able to express this condition:
 \<close>
 
 definition
   "associative f \<equiv> (\<forall>x y z. f x (f y z) = f (f x y) z)"
 
 
 text \<open>
 The following constant symbols represents our unspecified function. We want to
 show that this function is semantically equivalent to \<open>scanl1\<close>, provided
 that the first argument is an associative function.
 \<close>
 
 consts 
   candidate :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list"
 
 
 text \<open>
 With the final theorem, it suffices to show that \<open>candidate\<close> behaves like
 \<open>scanl1\<close> on all lists of the following type, to conclude that 
 \<open>canditate\<close> is semantically equivalent to \<open>scanl1\<close>.
 \<close>
 
 datatype three = Zero | One | Two
 
 
 
 text \<open>
 Although most of the functions mentioned in the original paper already exist
 in Isabelle's list theory, we still need to define two more functions:
 \<close>
 
 fun wrap :: "'a \<Rightarrow> 'a list"
 where
   "wrap x = [x]"
 
 fun ups :: "nat \<Rightarrow> nat list list"
 where
   "ups n = map (\<lambda>k. [0..<k + 1]) [0..<n + 1]"
 
 
 
 
 
 section \<open>A Free Theorem\<close>
 
 text \<open>
 The key to proof the final theorem is the following free theorem \cite{TypesAbstractionsAndParametricPolymorphism,TheoremsForFree} of \<open>candidate\<close>. 
 Since there is no proof possible without specifying the underlying
 (functional) language (which would be beyond the scope of this work),
 this lemma is expected to hold. As a consequence, all following lemmas and also
 the final theorem only hold under this provision.
 \<close>
 
 axiomatization where
   candidate_free_theorem:
     "\<And>x y. h (f x y) = g (h x) (h y) \<Longrightarrow> map h (candidate f zs) = candidate g (map h zs)"
 
 
 
 text \<open>
 In what follows in this section, the previous lemma is specialised to a lemma 
 for non-empty lists. More precisely, we want to restrict the above assumption
 to be applicable for non-empty lists. This is already possible without
 modifications when having a list datatype which does not allow for empty lists.
 However, before being able to also use Isabelle's list datatype, further
 conditions on \<open>f\<close> and \<open>zs\<close> are necessary.
 
 To prove the derived lemma, we first introduce a datatype for non-empty lists,
 and we furthermore define conversion functions to map the new datatype on
 Isabelle lists and back.
 \<close>
 
 datatype 'a nel 
   = NE_One 'a 
   | NE_Cons 'a "'a nel"
 
 fun n2l :: "'a nel \<Rightarrow> 'a list"
 where
   "n2l (NE_One x)     = [x]"
 | "n2l (NE_Cons x xs) = x # n2l xs"
 
 fun l2n :: "'a list \<Rightarrow> 'a nel"
 where
   "l2n [x]      = NE_One x"
 | "l2n (x # xs) = (case xs of []      \<Rightarrow> NE_One x
                             | (_ # _) \<Rightarrow> NE_Cons x (l2n xs))"
 
 
 text \<open>
 The following results relate Isabelle lists and non-empty lists:
 \<close>
 
 lemma non_empty_n2l: "n2l xs \<noteq> []"
 by (cases xs, auto)
 
 
 lemma n2l_l2n_id: "x \<noteq> [] \<Longrightarrow> n2l (l2n x) = x"
 proof (induct x)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case by (cases xs, auto)
 qed
 
 
 lemma n2l_l2n_map_id:
   assumes "\<And>x. x \<in> set zs \<Longrightarrow> x \<noteq> []"
   shows "map (n2l \<circ> l2n) zs = zs"
 using assms 
 proof (induct zs)
   case Nil thus ?case by simp
 next
   case (Cons z zs)
   hence "\<And>x. x \<in> set zs \<Longrightarrow> x \<noteq> []" using List.set_subset_Cons by auto
   with Cons have IH: "map (n2l \<circ> l2n) zs = zs" by blast
 
   have 
   "map (n2l \<circ> l2n) (z # zs)
    = (n2l \<circ> l2n) z # map (n2l \<circ> l2n) zs" by simp
   also have 
   "\<dots> = z # map (n2l \<circ> l2n) zs" using Cons and n2l_l2n_id by auto
   also have 
   "\<dots> = z # zs" using IH by simp
   finally show ?case .
 qed
 
 
 text \<open>
 Based on the previous lemmas, we can state and proof a specialised version
 of \<open>candidate\<close>'s free theorem, suitable for our setting as explained 
 before.
 \<close>
 
 lemma Lemma_1:
   assumes A1: "\<And>(x::'a list) (y::'a list). 
                  x \<noteq> [] \<Longrightarrow> y \<noteq> [] \<Longrightarrow> h (f x y) = g (h x) (h y)"
       and A2: "\<And>x y. x \<noteq> [] \<Longrightarrow> y \<noteq> [] \<Longrightarrow> f x y \<noteq> []"
       and A3: "\<And>x. x \<in> set zs \<Longrightarrow> x \<noteq> []"
   shows "map h (candidate f zs) = candidate g (map h zs)"
 proof -
   \<comment> \<open>We define two functions, @{text "fn :: 'a nel \<Rightarrow> 'a nel \<Rightarrow> 'a nel"} and\<close>
   \<comment> \<open>@{text "hn :: 'a nel \<Rightarrow> b"}, which wrap @{text f} and @{text h} in the\<close>
   \<comment> \<open>setting of non-empty lists.\<close>
   let ?fn = "\<lambda>x y. l2n (f (n2l x) (n2l y))"
   let ?hn = "h \<circ> n2l"
 
   \<comment> \<open>Our new functions fulfill the preconditions of @{text candidate}'s\<close>
   \<comment> \<open>free theorem:\<close>
   have "\<And>(x::'a nel) (y::'a nel). ?hn (?fn x y) = g (?hn x) (?hn y)"
     proof -
       fix x y
       let ?xl = "n2l (x :: 'a nel)"
       let ?yl = "n2l (y :: 'a nel)"
       have 
       "?hn (?fn x y)
        = h (n2l (l2n (f (n2l x) (n2l y))))" by simp
       also have 
       "\<dots> = h (f ?xl ?yl)" 
           using A2 [where x="?xl" and y="?yl"]
           and n2l_l2n_id [where x="f (n2l x) (n2l y)"] 
           and non_empty_n2l [where xs=x] 
           and non_empty_n2l [where xs=y] by simp
       also have 
       "\<dots> = g (h ?xl) (h ?yl)"
           using A1 and non_empty_n2l and non_empty_n2l by auto
       also have 
       "\<dots> = g (?hn x) (?hn y)" by simp
       finally show "?hn (?fn x y) = g (?hn x) (?hn y)" .
     qed
   with candidate_free_theorem [where f="?fn" and h="?hn" and g = g]
   have ne_free_theorem: 
   "map ?hn (candidate ?fn (map l2n zs)) = candidate g (map ?hn (map l2n zs))"
       by auto
 
   \<comment> \<open>We use @{text candidate}'s free theorem again to show the following\<close>
   \<comment> \<open>property:\<close>
   have n2l_candidate: 
     "\<And>zs. map n2l (candidate ?fn zs) = candidate f (map n2l zs)"
     proof -
       fix zs
       have "\<And>x y. n2l (?fn x y) = f (n2l x) (n2l y)"
         proof -
           fix x y
           show "n2l (?fn x y) = f (n2l x) (n2l y)"
             using n2l_l2n_id [where x="f (n2l x) (n2l y)"] 
               and A2 [where x="n2l x" and y="n2l y"]
               and non_empty_n2l [where xs=x] and non_empty_n2l [where xs=y] 
             by simp
         qed
       with candidate_free_theorem [where h=n2l and f="?fn" and g=f]
       show "map n2l (candidate ?fn zs) = candidate f (map n2l zs)" by simp
     qed
 
   \<comment> \<open>Now, with the previous preparations, we conclude the thesis by the\<close>
   \<comment> \<open>following rewriting:\<close>
   have 
   "map h (candidate f zs)
    = map h (candidate f (map (n2l \<circ> l2n) zs))"
       using n2l_l2n_map_id [where zs=zs] and A3 by simp
   also have 
   "\<dots> = map h (candidate f (map n2l (map l2n zs)))"
       using List.map_map [where f=n2l and g=l2n and xs=zs] by simp 
   also have 
   "\<dots>= map h (map n2l (candidate ?fn (map l2n zs)))"
       using n2l_candidate by auto
   also have 
   "\<dots> = map ?hn (candidate ?fn (map l2n zs))"
       using List.map_map by auto
   also have
   "\<dots> = candidate g (map ?hn (map l2n zs))"
       using ne_free_theorem by simp
   also have 
   "\<dots> = candidate g (map ((h \<circ> n2l) \<circ> l2n) zs)" 
       using List.map_map [where f="h \<circ> n2l" and g=l2n] by simp
   also have 
   "\<dots> = candidate g (map (h \<circ> (n2l \<circ> l2n)) zs)" 
       using Fun.o_assoc [symmetric, where f=h and g=n2l and h=l2n] by simp
   also have 
   "\<dots> = candidate g (map h (map (n2l \<circ> l2n) zs))"
       using List.map_map [where f=h and g="n2l \<circ> l2n"] by simp
   also have 
   "\<dots> = candidate g (map h zs)" 
       using n2l_l2n_map_id [where zs=zs] and A3 by auto
   finally show ?thesis .
 qed
 
 
 
 
 
 section \<open>Useful lemmas\<close>
 
 text \<open>
 In this section, we state and proof several lemmas, which neither occur in the
 original paper nor in Isabelle's libraries.
 \<close>
 
 lemma upt_map_Suc:
   "k > 0 \<Longrightarrow> [0..<k + 1] = 0 # map Suc [0..<k]"
 using List.upt_conv_Cons and List.map_Suc_upt by simp
 
 
 lemma divide_and_conquer_induct:
   assumes A1: "P []"
       and A2: "\<And>x. P [x]"
       and A3: "\<And>xs ys. \<lbrakk> xs \<noteq> [] ; ys \<noteq> [] ; P xs ; P ys \<rbrakk> \<Longrightarrow> P (xs @ ys)"
   shows "P zs"
 proof (induct zs)
   case Nil with A1 show ?case by simp
 next
   case (Cons z zs) 
   hence IH: "P zs" by simp
   show ?case
   proof (cases zs)
     case Nil with A2 show ?thesis by simp
   next
     case Cons with IH and A2 and A3 [where xs="[z]" and ys=zs] 
     show ?thesis by auto
   qed
 qed
 
 lemmas divide_and_conquer 
   = divide_and_conquer_induct [case_names Nil One Partition]
 
 
 lemma all_set_inter_empty_distinct:
   assumes "\<And>xs ys. js = xs @ ys \<Longrightarrow> set xs \<inter> set ys = {}"
   shows "distinct js"
 using assms proof (induct js rule: divide_and_conquer)
   case Nil thus ?case by simp
 next
   case One thus ?case by simp
 next
   case (Partition xs ys)
   hence P: "\<And>as bs. xs @ ys = as @ bs \<Longrightarrow> set as \<inter> set bs = {}" by simp
 
   have "\<And>xs1 xs2. xs = xs1 @ xs2 \<Longrightarrow> set xs1 \<inter> set xs2 = {}"
     proof -
       fix xs1 xs2
       assume "xs = xs1 @ xs2"
       hence "set xs1 \<inter> set (xs2 @ ys) = {}"
         using P [where as=xs1 and bs="xs2 @ ys"] by simp
       thus "set xs1 \<inter> set xs2 = {}" 
         using List.set_append and Set.Int_Un_distrib by auto
     qed
   with Partition have distinct_xs: "distinct xs" by simp
   have "\<And>ys1 ys2. ys = ys1 @ ys2 \<Longrightarrow> set ys1 \<inter> set ys2 = {}"
     proof -
       fix ys1 ys2
       assume "ys = ys1 @ ys2"
       hence "set (xs @ ys1) \<inter> set ys2 = {}"
         using P [where as="xs @ ys1" and bs=ys2] by simp
       thus "set ys1 \<inter> set ys2 = {}" 
         using List.set_append and Set.Int_Un_distrib by auto
     qed
   with Partition have distinct_ys: "distinct ys" by simp
   from Partition and distinct_xs and distinct_ys show ?case by simp
 qed
 
 
 
 lemma partitions_sorted:
   assumes "\<And>xs ys x y. \<lbrakk> js = xs @ ys ; x \<in> set xs ; y \<in> set ys \<rbrakk> \<Longrightarrow> x \<le> y"
   shows "sorted js"
 using assms proof (induct js rule: divide_and_conquer)
   case Nil thus ?case by simp
 next
   case One thus ?case by simp
 next
   case (Partition xs ys)
   hence P: "\<And>as bs x y. \<lbrakk> xs @ ys = as @ bs ; x \<in> set as ; y \<in> set bs\<rbrakk> \<Longrightarrow> x \<le> y"
     by simp
 
   have "\<And>xs1 xs2 x y. \<lbrakk> xs = xs1 @ xs2 ; x \<in> set xs1 ; y \<in> set xs2 \<rbrakk> \<Longrightarrow> x \<le> y"
     proof -
       fix xs1 xs2
       assume "xs = xs1 @ xs2"
       hence "\<And>x y. \<lbrakk> x \<in> set xs1 ; y \<in> set (xs2 @ ys) \<rbrakk> \<Longrightarrow> x \<le> y"
         using P [where as=xs1 and bs="xs2 @ ys"] by simp
       thus "\<And>x y. \<lbrakk> x \<in> set xs1 ; y \<in> set xs2 \<rbrakk> \<Longrightarrow> x \<le> y"
         using List.set_append by auto
     qed
   with Partition have sorted_xs: "sorted xs" by simp
   have "\<And>ys1 ys2 x y. \<lbrakk> ys = ys1 @ ys2 ; x \<in> set ys1 ; y \<in> set ys2 \<rbrakk> \<Longrightarrow> x \<le> y"
     proof -
       fix ys1 ys2
       assume "ys = ys1 @ ys2"
       hence "\<And>x y. \<lbrakk> x \<in> set (xs @ ys1) ; y \<in> set ys2 \<rbrakk> \<Longrightarrow> x \<le> y"
         using P [where as="xs @ ys1" and bs=ys2] by simp
       thus "\<And>x y. \<lbrakk> x \<in> set ys1 ; y \<in> set ys2 \<rbrakk> \<Longrightarrow> x \<le> y"
         using List.set_append by auto
     qed
   with Partition have sorted_ys: "sorted ys" by simp
 
   have "\<forall>x \<in> set xs. \<forall>y \<in> set ys. x \<le> y"
     using P [where as=xs and bs=ys] by simp
   with sorted_xs and sorted_ys show ?case using List.sorted_append by auto
 qed
 
 
 
 section \<open>Preparatory Material\<close>
 
 text \<open>
 In the original paper, the following lemmas L1 to L8 are given without a proof,
 although it is hinted there that most of them follow from parametricity
 properties \cite{TypesAbstractionsAndParametricPolymorphism,TheoremsForFree}.
 Alternatively, most of them can be shown by induction over lists.
 However, since we are using Isabelle's list datatype, we rely on already
 existing results.
 \<close>
 
 lemma L1: "map g (map f xs) = map (g \<circ> f) xs"
 using List.map_map by auto
 
 lemma L2: "length (map f xs) = length xs"
 using List.length_map by simp
 
 lemma L3: "take k (map f xs) = map f (take k xs)"
 using List.take_map by auto
 
 lemma L4: "map f \<circ> wrap = wrap \<circ> f"
 by (simp add: fun_eq_iff)
 
 lemma L5: "map f (xs @ ys) = (map f xs) @ (map f ys)"
 using List.map_append by simp
 
 lemma L6: "k < length xs \<Longrightarrow> (map f xs) ! k = f (xs ! k)"
 using List.nth_map by simp
 
 
 lemma L7: "\<And>k. k < length xs \<Longrightarrow> map (nth xs) [0..<k + 1] = take (k + 1) xs"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) 
   thus ?case
   proof (cases k)
     case 0 thus ?thesis by simp
   next
     case (Suc k')
     hence "k > 0" by simp
     hence "map (nth (x # xs)) [0..<k + 1] 
            = map (nth (x # xs)) (0 # map Suc [0..<k])" 
         using upt_map_Suc by simp
     also have "\<dots> = ((x # xs) ! 0) # (map (nth (x # xs) \<circ> Suc) [0..<k])"
         using L1 by simp
     also have "\<dots> = x # map (nth xs) [0..<k]" by simp
     also have "\<dots> = x # map (nth xs) [0..<k' + 1]" using Suc by simp
     also have "\<dots> = x # take (k' + 1) xs" using Cons and Suc by simp
     also have "\<dots> = take (k + 1) (x # xs)" using Suc by simp
     finally show ?thesis .
   qed
 qed
 
 
 text \<open>
 In Isabelle's list theory, a similar result for \<open>foldl\<close> already exists.
 Therefore, it is easy to prove the following lemma for \<open>foldl1\<close>.
 Note that this lemma does not occur in the original paper.
 \<close>
 
 lemma foldl1_append:
   assumes "xs \<noteq> []"
   shows "foldl1 f (xs @ ys) = foldl1 f (foldl1 f xs # ys)"
 proof -
   have non_empty_list: "xs \<noteq> [] \<Longrightarrow> \<exists>y ys. xs = y # ys" by (cases xs, auto)
   with assms obtain x xs' where x_xs_def: "xs = x # xs'" by auto
 
   have "foldl1 f (xs @ ys) = foldl f x (xs' @ ys)" using x_xs_def by simp
   also have "\<dots> = foldl f (foldl f x xs') ys" using List.foldl_append by simp
   also have "\<dots> = foldl f (foldl1 f (x # xs')) ys" by simp
   also have "\<dots> = foldl1 f (foldl1 f xs # ys)" using x_xs_def by simp
   finally show ?thesis .
 qed
 
 
 text \<open>
 This is a special induction scheme suitable for proving L8. It is not mentioned
 in the original paper.
 \<close>
 
 lemma foldl1_induct':
   assumes "\<And>f x. P f [x]"
       and "\<And>f x y. P f [x, y]" 
       and "\<And>f x y z zs. P f (f x y # z # zs) \<Longrightarrow> P f (x # y # z # zs)"
       and "\<And>f. P f []"
   shows "P f xs"
 proof (induct xs rule: List.length_induct)
   fix xs
   assume A: "\<forall>ys::'a list. length ys < length (xs::'a list) \<longrightarrow> P f ys"
   thus "P f xs"
   proof (cases xs)
     case Nil with assms show ?thesis by simp
   next
     case (Cons x1 xs1)
     hence xs1: "xs = x1 # xs1" by simp
     thus ?thesis
     proof (cases xs1)
       case Nil with assms and xs1 show ?thesis by simp
     next
       case (Cons x2 xs2)
       hence xs2: "xs1 = x2 # xs2" by simp
       thus ?thesis
       proof (cases xs2)
         case Nil with assms and xs1 and xs2 show ?thesis by simp
       next
         case (Cons x3 xs3)
         hence "xs2 = x3 # xs3" by simp
         with assms and xs1 xs2 and A show ?thesis by simp
       qed
     qed
   qed
 qed
   
 lemmas foldl1_induct = foldl1_induct' [case_names One Two More Nil]
 
 
 lemma L8:
   assumes "associative f"
       and "xs \<noteq> []"
       and "ys \<noteq> []"
   shows "foldl1 f (xs @ ys) = f (foldl1 f xs) (foldl1 f ys)"
 using assms proof (induct f ys rule: foldl1_induct)
   case (One f y)
   have 
   "foldl1 f (xs @ [y]) 
    = foldl1 f (foldl1 f xs # [y])" 
       using foldl1_append [where xs=xs] and One by simp
   also have 
   "\<dots> = f (foldl1 f xs) y" by simp
   also have 
   "\<dots> = f (foldl1 f xs) (foldl1 f [y])" by simp
   finally show ?case .
 next
   case (Two f x y)
   have 
   "foldl1 f (xs @ [x, y]) 
    = foldl1 f (foldl1 f xs # [x, y])"
       using foldl1_append [where xs=xs] and Two by simp
   also have 
   "\<dots> = foldl1 f (f (foldl1 f xs) x # [y])" by simp
   also have 
   "\<dots> = f (f (foldl1 f xs) x) y" by simp
   also have 
   "\<dots> = f (foldl1 f xs) (f x y)" using Two 
       unfolding associative_def by simp
   also have 
   "\<dots> = f (foldl1 f xs) (foldl1 f [x, y])" by simp
   finally show ?case .
 next
   case (More f x y z zs)
   hence IH: "foldl1 f (xs @ f x y # z # zs) 
              = f (foldl1 f xs) (foldl1 f (f x y # z # zs))" by simp
 
   have 
   "foldl1 f (xs @ x # y # z # zs) 
    = foldl1 f (foldl1 f xs # x # y # z # zs)"
       using foldl1_append [where xs=xs] and More by simp
   also have 
   "\<dots> = foldl1 f (f (foldl1 f xs) x # y # z # zs)" by simp
   also have 
   "\<dots> = foldl1 f (f (f (foldl1 f xs) x) y # z # zs)" by simp
   also have 
   "\<dots> = foldl1 f (f (foldl1 f xs) (f x y) # z # zs)"
       using More unfolding associative_def by simp
   also have 
   "\<dots> = foldl1 f (foldl1 f xs # f x y # z # zs)" by simp
   also have 
   "\<dots> = foldl1 f (xs @ f x y # z # zs)"
       using foldl1_append [where xs=xs] and More by simp
   also have 
   "\<dots> = f (foldl1 f xs) (foldl1 f (x # y # z # zs))"
       using IH by simp
   finally show ?case .
 next
   case Nil thus ?case by simp
 qed
 
 
 text \<open>
 The next lemma is applied in several following proofs whenever the equivalence
 of two lists is shown.
 \<close>
 
 lemma Lemma_2:
   assumes "length xs = length ys"
       and "\<And>k. k < length xs \<Longrightarrow> xs ! k = ys ! k"
   shows "xs = ys"
 using assms by (auto simp: List.list_eq_iff_nth_eq)
 
 
 
 text \<open>
 In the original paper, this lemma and its proof appear inside of Lemma 3.
 However, this property will be useful also in later proofs and is thus 
 separated.
 \<close>
 
 lemma foldl1_map:
   assumes "associative f"
       and "xs \<noteq> []"
       and "ys \<noteq> []"
   shows "foldl1 f (map h (xs @ ys)) 
          = f (foldl1 f (map h xs)) (foldl1 f (map h ys))"
 proof -
   have 
   "foldl1 f (map h (xs @ ys)) 
    = foldl1 f (map h xs @ map h ys)"
       using L5 by simp
   also have 
   "\<dots> = f (foldl1 f (map h xs)) (foldl1 f (map h ys))" 
       using assms and L8 [where f=f] by auto
   finally show ?thesis .
 qed
 
 
 lemma Lemma_3:
   fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
     and h :: "nat \<Rightarrow> 'a"
   assumes "associative f"
   shows "map (foldl1 f \<circ> map h) (candidate (@) (map wrap [0..<n+1])) 
          = candidate f (map h [0..<n+1])"
 proof - 
   \<comment> \<open>The following three properties @{text P1}, @{text P2} and @{text P3}\<close>
   \<comment> \<open>are preconditions of Lemma 1.\<close>
   have P1: 
   "\<And>x y. \<lbrakk> x \<noteq> [] ; y \<noteq> [] \<rbrakk>
    \<Longrightarrow> foldl1 f (map h (x @ y)) = f (foldl1 f (map h x)) (foldl1 f (map h y))"
       using assms and foldl1_map by blast
 
   have P2: "\<And>x y. x \<noteq> [] \<Longrightarrow> y \<noteq> [] \<Longrightarrow> x @ y  \<noteq> []" by auto
 
   have P3: "\<And>x. x \<in> set (map wrap [0..<n+1]) \<Longrightarrow> x \<noteq> []" by auto
 
   \<comment> \<open>The proof for the thesis is now equal to the one of the original paper:\<close>
   from Lemma_1 [where h="foldl1 f \<circ> map h" and zs="map wrap [0..<n+1]"
        and f="(@)"] and P1 P2 P3
   have 
   "map (foldl1 f \<circ> map h) (candidate (@) (map wrap [0..<n+1])) 
    = candidate f (map (foldl1 f \<circ> map h) (map wrap [0..<n+1]))"
       by auto
   also have 
   "\<dots> = candidate f (map (foldl1 f \<circ> map h \<circ> wrap) [0..<n+1])" 
       by (simp add: L1)
   also have
   "\<dots> = candidate f (map (foldl1 f \<circ> wrap \<circ> h) [0..<n+1])" 
       using L4 by (simp add: Fun.o_def)
   also have 
   "\<dots> = candidate f (map h [0..<n+1])" 
       by (simp add: Fun.o_def)
   finally show ?thesis .
 qed
 
 
 
 
 
 section \<open>Proving Proposition 1\<close>
 
 
 subsection \<open>Definitions of Lemma 4\<close>
 
 text \<open>
 In the same way as in the original paper, the following two functions are 
 defined:
 \<close>
 
 fun f1 :: "three \<Rightarrow> three \<Rightarrow> three"
 where
   "f1 x    Zero = x"
 | "f1 Zero One  = One"
 | "f1 x    y    = Two"
 
 fun f2 :: "three \<Rightarrow> three \<Rightarrow> three"
 where
   "f2 x Zero = x"
 | "f2 x One  = One"
 | "f2 x Two  = Two"
 
 
 text \<open>
 Both functions are associative as is proved by case analysis:
 \<close>
 
 lemma f1_assoc: "associative f1"
 unfolding associative_def proof auto
   fix x y z
   show "f1 x (f1 y z) = f1 (f1 x y) z" 
   proof (cases z)
     case Zero thus ?thesis by simp
   next
     case One 
     hence z_One: "z = One" by simp
     thus ?thesis by (cases y, simp_all, cases x, simp_all)
   next
     case Two thus ?thesis by simp
   qed
 qed
 
 lemma f2_assoc: "associative f2" 
 unfolding associative_def proof auto
   fix x y z
   show "f2 x (f2 y z) = f2 (f2 x y) z" by (cases z, auto)
 qed
 
 
 text \<open>
 Next, we define two other functions, again according to the original paper.
 Note that \<open>h1\<close> has an extra parameter \<open>k\<close> which is only implicit in
 the original paper.
 \<close>
 
 fun h1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> three"
 where
   "h1 k i j = (if i = j then One
                else if j \<le> k then Zero
                else Two)"
 
 fun h2 :: "nat \<Rightarrow> nat \<Rightarrow> three"
 where
   "h2 i j = (if i = j then One
              else if i + 1 = j then Two
              else Zero)"
 
 
 
 subsection \<open>Figures and Proofs\<close>
 
 text \<open>
 In the original paper, this lemma is depicted in (and proved by) Figure~2.
 Therefore, it carries this unusual name here.
 \<close>
 
 lemma Figure_2: 
   assumes "i \<le> k"
   shows "foldl1 f1 (map (h1 k i) [0..<k + 1]) = One"
 proof -
   let ?mr = "replicate i Zero @ [One] @ replicate (k - i) Zero"
 
   have P1: "map (h1 k i) [0..<k + 1] = ?mr"
     proof -
       have Q1: "length (map (h1 k i) [0..<k + 1]) = length ?mr"
         using assms by simp
       
       have Q2: "\<And>j. j < length (map (h1 k i) [0..<k + 1])
                     \<Longrightarrow> (map (h1 k i) [0..<k + 1]) ! j = ?mr ! j"
         proof -
           fix j
           assume "j < length (map (h1 k i) [0..<k + 1])"
           hence j_k: "j < k + 1" by simp
           have M1: "(map (h1 k i) [0..<k + 1]) ! i = One"
             using L6 [where f="h1 k i" and xs="[0..<k + 1]"] and assms
               and List.nth_upt [where i=0 and k=i and j="k + 1"] by simp
           have M2: "j \<noteq> i \<Longrightarrow> (map (h1 k i) [0..<k + 1]) ! j = Zero"
             using L6 [where f="h1 k i" and xs="[0..<k + 1]"] and j_k
               and List.nth_upt [where i=0 and j="k + 1"] by simp
           have R1: "?mr ! i = One"
             using List.nth_append [where xs="replicate i Zero"] by simp
           have R2: "j < i \<Longrightarrow> ?mr ! j = Zero"
             using List.nth_append [where xs="replicate i Zero"] by simp
           have R3: "j > i \<Longrightarrow> ?mr ! j = Zero"
             using List.nth_append [where xs="replicate i Zero @ [One]"]
               and j_k by simp
           
           show "(map (h1 k i) [0..<k + 1]) ! j = ?mr ! j"
           proof (cases "i = j")
             assume "i = j"
             with M1 and R1 show ?thesis by simp
           next
             assume i_ne_j: "i \<noteq> j"
             thus ?thesis
             proof (cases "i < j")
               assume "i < j"
               with M2 and R3 show ?thesis by simp
             next 
               assume "\<not>(i < j)"
               with i_ne_j have "i > j" by simp
               with M2 and R2 show ?thesis by simp
             qed
           qed
         qed
       
       from Q1 Q2 and Lemma_2 show ?thesis by blast
     qed
 
   have P2: "\<And>j. j > 0 \<Longrightarrow> foldl1 f1 (replicate j Zero) = Zero"
     proof -
       fix j
       assume "(j::nat) > 0"
       thus "foldl1 f1 (replicate j Zero) = Zero"
       proof (induct j)
         case 0 thus ?case by simp
       next
         case (Suc j) thus ?case by (cases j, auto)
       qed
     qed
 
   have P3: "\<And>j. foldl1 f1 ([One] @ replicate j Zero) = One"
     proof -
       fix j
       show "foldl1 f1 ([One] @ replicate j Zero) = One"
         using L8 [where f=f1 and xs="[One]" and ys="replicate (Suc j) Zero"] 
           and f1_assoc and P2 [where j="Suc j"] by simp
     qed
   
   have "foldl1 f1 ?mr = One"
     proof (cases i)
       case 0
       thus ?thesis using P3 by simp
     next
       case (Suc i)
       hence 
       "foldl1 f1 (replicate (Suc i) Zero @ [One] @ replicate (k - Suc i) Zero)
        = f1 (foldl1 f1 (replicate (Suc i) Zero))
             (foldl1 f1 ([One] @ replicate (k - Suc i) Zero))"
           using L8 [where xs="replicate (Suc i) Zero" 
                     and ys="[One] @ replicate (k - Suc i) Zero"] 
           and f1_assoc by simp
       also have 
       "\<dots> = One" 
           using P2 [where j="Suc i"] and P3 [where j="k - Suc i"] by simp
       finally show ?thesis using Suc by simp
     qed
   with P1 show ?thesis by simp
 qed
 
 
 
 text \<open>
 In the original paper, this lemma is depicted in (and proved by) Figure~3.
 Therefore, it carries this unusual name here.
 \<close>
 
 lemma Figure_3: 
   assumes "i < k"
   shows "foldl1 f2 (map (h2 i) [0..<k + 1]) = Two" 
 proof -
   let ?mr = "replicate i Zero @ [One, Two] @ replicate (k - i - 1) Zero"
 
   have P1: "map (h2 i) [0..<k + 1] = ?mr"
     proof -
       have Q1: "length (map (h2 i) [0..<k + 1]) = length ?mr"
         using assms by simp
       
       have Q2: "\<And>j. j < length (map (h2 i) [0..<k + 1])
                     \<Longrightarrow> (map (h2 i) [0..<k + 1]) ! j = ?mr ! j"
         proof -
           fix j
           assume "j < length (map (h2 i) [0..<k + 1])"
           hence j_k: "j < k + 1" by simp
           have M1: "(map (h2 i) [0..<k + 1]) ! i = One" 
             using L6 [where xs="[0..<k + 1]" and f="h2 i" and k=i] and assms 
             and List.nth_upt [where i=0 and k=i and j="k + 1"] by simp
           have M2: "(map (h2 i) [0..<k + 1]) ! (i + 1) = Two"
             using L6 [where xs="[0..<k + 1]" and f="h2 i" and k="i + 1"] 
             and assms and List.nth_upt [where i=0 and k="i + 1" and j="k + 1"]
             by simp
           have M3: "j < i \<or> j > i + 1 \<Longrightarrow> (map (h2 i) [0..<k + 1]) ! j = Zero" 
             using L6 [where xs="[0..<k + 1]" and f="h2 i" and k=j] 
             and assms and List.nth_upt [where i=0 and k=j and j="k + 1"]
             and j_k by auto
           have R1: "j < i \<Longrightarrow> ?mr ! j = Zero" 
             using List.nth_append [where xs="replicate i Zero"] by simp
           have R2: "?mr ! i = One"
             using List.nth_append [where xs="replicate i Zero"] by simp
           have R3: "?mr ! (i + 1) = Two"
             using List.nth_append [where xs="replicate i Zero @ [One]"] by simp
           have R4: "j > i + 1 \<Longrightarrow> ?mr ! j = Zero"
             using List.nth_append [where xs="replicate i Zero @ [One,Two]"]
             and j_k by simp
           show "(map (h2 i) [0..<k + 1]) ! j = ?mr ! j"
           proof (cases "j < i")
             assume "j < i" with M3 and R1 show ?thesis by simp
           next
             assume "\<not>(j < i)"
             hence j_ge_i: "j \<ge> i" by simp
             thus ?thesis
             proof (cases "j = i")
               assume "j = i" with M1 and R2 show ?thesis by simp
             next
               assume "\<not>(j = i)"
               with j_ge_i have j_gt_i: "j > i" by simp
               thus ?thesis
               proof (cases "j = i + 1")
                 assume "j = i + 1" with M2 and R3 show ?thesis by simp
               next
                 assume "\<not>(j = i + 1)"
                 with j_gt_i have "j > i + 1" by simp
                 with M3 and R4 show ?thesis by simp
               qed
             qed
           qed
         qed
       from Q1 Q2 and Lemma_2 show ?thesis by blast
     qed
  
   have P2: "\<And>j. j > 0 \<Longrightarrow> foldl1 f2 (replicate j Zero) = Zero"
     proof -
       fix j
       assume j_0: "(j::nat) > 0"
       show "foldl1 f2 (replicate j Zero) = Zero"
       using j_0 proof (induct j)
         case 0 thus ?case by simp
       next
         case (Suc j) thus ?case by (cases j, auto)
       qed
     qed
  
   have P3: "\<And>j. foldl1 f2 ([One, Two] @ replicate j Zero) = Two"
     proof -
       fix j
       show "foldl1 f2 ([One, Two] @ replicate j Zero) = Two"
         using L8 [where f=f2 and xs="[One,Two]" 
         and ys="replicate (Suc j) Zero"] and f2_assoc and P2 [where j="Suc j"]
         by simp
     qed
 
   have "foldl1 f2 ?mr = Two" 
     proof (cases i)
       case 0 thus ?thesis using P3 by simp
     next
       case (Suc i)
       hence 
       "foldl1 f2 (replicate (Suc i) Zero @ [One, Two] 
                                          @ replicate (k - Suc i - 1) Zero)
        = f2 (foldl1 f2 (replicate (Suc i) Zero))
             (foldl1 f2 ([One, Two] @  replicate (k - Suc i - 1) Zero))"
           using L8 [where f=f2 and xs="replicate (Suc i) Zero" 
                     and ys="[One, Two] @ replicate (k - Suc i - 1) Zero"] 
           and f2_assoc by simp
       also have 
       "\<dots> = Two"
           using P2 [where j="Suc i"] and P3 [where j="k - Suc i - 1"] by simp
       finally show ?thesis using Suc by simp
     qed
   with P1 show ?thesis by simp
 qed
 
 
 
 text \<open>
 Counterparts of the following two lemmas are shown in the proof of Lemma 4 in
 the original paper. Since here, the proof of Lemma 4 is seperated in several
 smaller lemmas, also these two properties are given separately.
 \<close>
 
 lemma L9:
   assumes "\<And> (f :: three \<Rightarrow> three \<Rightarrow> three) h. associative f 
              \<Longrightarrow> foldl1 f (map h js) = foldl1 f (map h [0..<k + 1])"
       and "i \<le> k"
   shows "foldl1 f1 (map (h1 k i) js) = One"
 using assms and f1_assoc and Figure_2 by auto
 
 
 lemma L10:
   assumes "\<And> (f :: three \<Rightarrow> three \<Rightarrow> three) h. associative f 
              \<Longrightarrow> foldl1 f (map h js) = foldl1 f (map h [0..<k + 1])"
       and "i < k"
   shows "foldl1 f2 (map (h2 i) js) = Two"
 using assms and f2_assoc and Figure_3 by auto
 
 
 
 text \<open>
 In the original paper, this lemma is depicted in (and proved by) Figure~4.
 Therefore, it carries this unusual name here. This lemma expresses that every
 \<open>i \<le> k\<close> is contained in \<open>js\<close> at least once.
 \<close>
 
 lemma Figure_4:
   assumes "foldl1 f1 (map (h1 k i) js) = One"
       and "js \<noteq> []"
   shows "i \<in> set js" 
 proof (rule ccontr)
   assume i_not_in_js: "i \<notin> set js"
 
   have One_not_in_map_js: "One \<notin> set (map (h1 k i) js)" 
     proof 
       assume "One \<in> set (map (h1 k i) js)" 
       hence "One \<in> (h1 k i) ` (set js)" by simp
       then obtain j where j_def: "j \<in> set js \<and> One = h1 k i j" 
         using Set.image_iff [where f="h1 k i"] by auto
       hence "i = j" by (simp split: if_splits)
       with i_not_in_js and j_def show False by simp
     qed
   
   have f1_One: "\<And>x y. x \<noteq> One \<and> y \<noteq> One \<Longrightarrow> f1 x y \<noteq> One"
     proof - 
       fix x y
       assume "x \<noteq> One \<and> y \<noteq> One"
       thus "f1 x y \<noteq> One" by (cases y, cases x, auto)
     qed
   
   have "\<And>xs. \<lbrakk> xs \<noteq> [] ; One \<notin> set xs \<rbrakk> \<Longrightarrow> foldl1 f1 xs \<noteq> One"
     proof -
       fix xs
       assume A: "(xs :: three list) \<noteq> []"
       thus "One \<notin> set xs \<Longrightarrow> foldl1 f1 xs \<noteq> One"
       proof (induct xs rule: divide_and_conquer)
         case Nil thus ?case by simp
       next
         case (One x)
         thus "foldl1 f1 [x] \<noteq> One" by simp
       next
         case (Partition xs ys)
         hence "One \<notin> set xs \<and> One \<notin> set ys" by simp
         with Partition have "foldl1 f1 xs \<noteq> One \<and> foldl1 f1 ys \<noteq> One" by simp
         with f1_One have "f1 (foldl1 f1 xs) (foldl1 f1 ys) \<noteq> One" by simp
         with L8 [symmetric, where f=f1] and f1_assoc and Partition 
         show "foldl1 f1 (xs @ ys) \<noteq> One" by auto
       qed
     qed
   with One_not_in_map_js and assms show False by auto
 qed
 
 
 
 text \<open>
 In the original paper, this lemma is depicted in (and proved by) Figure~5.
 Therefore, it carries this unusual name here. This lemma expresses that every
 \<open>i \<le> k\<close> is contained in \<open>js\<close> at most once.
 \<close>
 
 lemma Figure_5:
   assumes "foldl1 f1 (map (h1 k i) js) = One"
       and "js = xs @ ys"
   shows "\<not>(i \<in> set xs \<and> i \<in> set ys)"
 proof (rule ccontr)
   assume "\<not>\<not>(i \<in> set xs \<and> i \<in> set ys)"
   hence i_xs_ys: "i \<in> set xs \<and> i \<in> set ys" by simp
 
   from i_xs_ys have xs_not_empty: "xs \<noteq> []" by auto
   from i_xs_ys have ys_not_empty: "ys \<noteq> []" by auto
 
   have f1_Zero: "\<And>x y. x \<noteq> Zero \<or> y \<noteq> Zero \<Longrightarrow> f1 x y \<noteq> Zero"
     proof -
       fix x y 
       show "x \<noteq> Zero \<or> y \<noteq> Zero \<Longrightarrow> f1 x y \<noteq> Zero"
       by (cases y, simp_all, cases x, simp_all)
     qed
 
   have One_foldl1: "\<And>xs. One \<in> set xs \<Longrightarrow> foldl1 f1 xs \<noteq> Zero"
     proof -
       fix xs
       assume One_xs: "One \<in> set xs"
       thus "foldl1 f1 xs \<noteq> Zero"
       proof (induct xs rule: divide_and_conquer)
         case Nil thus ?case by simp
       next
         case One thus ?case by simp
       next
         case (Partition xs ys)
         hence "One \<in> set xs \<or> One \<in> set ys" by simp
         with Partition have "foldl1 f1 xs \<noteq> Zero \<or> foldl1 f1 ys \<noteq> Zero" by auto
         with f1_Zero have "f1 (foldl1 f1 xs) (foldl1 f1 ys) \<noteq> Zero" by simp
         thus ?case using L8 [symmetric, where f=f1] and f1_assoc and Partition
           by auto
       qed
     qed
 
   have f1_Two: "\<And>x y. x \<noteq> Zero \<and> y \<noteq> Zero \<Longrightarrow> f1 x y = Two"
     proof -
       fix x y 
       show "x \<noteq> Zero \<and> y \<noteq> Zero \<Longrightarrow> f1 x y = Two"
       by (cases y, simp_all, cases x, simp_all)
     qed
   
   from i_xs_ys
   have "One \<in> set (map (h1 k i) xs) \<and> One \<in> set (map (h1 k i) ys)" by simp
   hence "foldl1 f1 (map (h1 k i) xs) \<noteq> Zero 
          \<and> foldl1 f1 (map (h1 k i) ys) \<noteq> Zero"
     using One_foldl1 by simp
   hence "f1 (foldl1 f1 (map (h1 k i) xs)) (foldl1 f1 (map (h1 k i) ys)) = Two"
     using f1_Two by simp
   hence "foldl1 f1 (map (h1 k i) (xs @ ys)) = Two"
     using foldl1_map [symmetric, where h="h1 k i"] and f1_assoc 
       and xs_not_empty and ys_not_empty by auto
   with assms show False by simp
 qed
 
 
 
 text \<open>
 In the original paper, this lemma is depicted in (and proved by) Figure~6.
 Therefore, it carries this unusual name here. This lemma expresses that
 \<open>js\<close> contains only elements of \<open>[0..<k + 1]\<close>.
 \<close>
 
 lemma Figure_6:
   assumes "\<And>i. i \<le> k \<Longrightarrow> foldl1 f1 (map (h1 k i) js) = One"
       and "i > k"
   shows "i \<notin> set js"
 proof
   assume i_in_js: "i \<in> set js"
 
   have Two_map: "Two \<in> set (map (h1 k 0) js)"
     proof -
       have "Two = h1 k 0 i" using assms by simp
       with i_in_js show ?thesis using IntI by (auto split: if_splits)
     qed
   
   have f1_Two: "\<And>x y. x = Two \<or> y = Two \<Longrightarrow> f1 x y = Two"
     proof -
       fix x y
       show "x = Two \<or> y = Two \<Longrightarrow> f1 x y = Two" by (cases y, auto)
     qed
 
   have "\<And>xs. Two \<in> set xs \<Longrightarrow> foldl1 f1 xs = Two"
     proof -
       fix xs
       assume Two_xs: "Two \<in> set xs"
       thus "foldl1 f1 xs = Two" using Two_xs
       proof (induct xs rule: divide_and_conquer)
         case Nil thus ?case by simp
       next
         case One thus ?case by simp
       next
         case (Partition xs ys)
         hence "Two \<in> set xs \<or> Two \<in> set ys" by simp
         hence "foldl1 f1 xs = Two \<or> foldl1 f1 ys = Two" using Partition by auto
         with f1_Two have "f1 (foldl1 f1 xs) (foldl1 f1 ys) = Two" by simp
         thus "foldl1 f1 (xs @ ys) = Two" 
           using L8 [symmetric, where f=f1] and f1_assoc and Partition by auto
       qed
     qed
 
   with Two_map have "foldl1 f1 (map (h1 k 0) js) = Two" by simp
   with assms show False by auto
 qed
 
 
 
 text \<open>
 In the original paper, this lemma is depicted in (and proved by) Figure~7.
 Therefore, it carries this unusual name here. This lemma expresses that every
 \<open>i \<le> k\<close> in \<open>js\<close> is eventually followed by \<open>i + 1\<close>.
 \<close>
 
 lemma Figure_7:
   assumes "foldl1 f2 (map (h2 i) js) = Two"
       and "js = xs @ ys"
       and "xs \<noteq> []"
       and "i = last xs"
   shows "(i + 1) \<in> set ys"
 proof (rule ccontr)
   assume Suc_i_not_in_ys: "(i + 1) \<notin> set ys"
 
   have last_map_One: "last (map (h2 i) xs) = One"
     proof -
       have 
       "last (map (h2 i) xs) 
         = (map (h2 i) xs) ! (length (map (h2 i) xs) - 1)" 
           using List.last_conv_nth [where xs="map (h2 i) xs"] and assms by simp
       also have 
       "\<dots> = (map (h2 i) xs) ! (length xs - 1)" using L2 by simp
       also have 
       "\<dots> = h2 i (xs ! (length xs - 1))" 
           using L6 and assms by simp
       also have 
       "\<dots> = h2 i (last xs)" 
           using List.last_conv_nth [symmetric,where xs=xs] and assms by simp
       also have 
       "\<dots> = One" using assms by simp
       finally show ?thesis .
     qed
   
   have "\<And>xs. \<lbrakk>  xs \<noteq> [] ; last xs = One \<rbrakk> \<Longrightarrow> foldl1 f2 xs = One"
     proof -
       fix xs
       assume last_xs_One: "last xs = One"
       assume xs_not_empty: "xs \<noteq> []"
       hence xs_partition: "xs = butlast xs @ [last xs]" by simp
       show "foldl1 f2 xs = One"
       proof (cases "butlast xs")
         case Nil with xs_partition and last_xs_One show ?thesis by simp
       next
         case Cons
         hence butlast_not_empty: "butlast xs \<noteq> []" by simp
         
         have 
         "foldl1 f2 xs = foldl1 f2 (butlast xs @ [last xs])" 
             using xs_partition by simp
         also have 
         "\<dots> = f2 (foldl1 f2 (butlast xs)) (foldl1 f2 [last xs])" 
             using L8 [where f=f2] and f2_assoc and butlast_not_empty by simp
         also have 
         "\<dots> = One" using last_xs_One by simp
         finally show ?thesis .
       qed
     qed
   with last_map_One have foldl1_map_xs: "foldl1 f2 (map (h2 i) xs) = One" 
     using assms by simp
 
   have ys_not_empty: "ys \<noteq> []" using foldl1_map_xs and assms by auto
 
   have Two_map_ys: "Two \<notin> set (map (h2 i) ys)"
     proof
       assume "Two \<in> set (map (h2 i) ys)"
       hence "Two \<in> (h2 i) ` (set ys)" by simp
       then obtain j where j_def: "j \<in> set ys \<and> Two = h2 i j" 
         using Set.image_iff [where f="h2 i"] by auto
       hence "i + 1 = j" by (simp split: if_splits)
       with Suc_i_not_in_ys and j_def show False by simp
     qed
   
   have f2_One: "\<And>x y. x \<noteq> Two \<and> y \<noteq> Two \<Longrightarrow> f2 x y \<noteq> Two"
     proof -
       fix x y
       show "x \<noteq> Two \<and> y \<noteq> Two \<Longrightarrow> f2 x y \<noteq> Two" by (cases y, auto) 
     qed
 
   have "\<And>xs. \<lbrakk> xs \<noteq> [] ; Two \<notin> set xs \<rbrakk> \<Longrightarrow> foldl1 f2 xs \<noteq> Two"
     proof -
       fix xs
       assume xs_not_empty: "(xs :: three list) \<noteq> []"
       thus "Two \<notin> set xs \<Longrightarrow> foldl1 f2 xs \<noteq> Two"
       proof (induct xs rule: divide_and_conquer)
         case Nil thus ?case by simp
       next
         case One thus ?case by simp
       next
         case (Partition xs ys)
         hence "Two \<notin> set xs \<and> Two \<notin> set ys" by simp
         hence "foldl1 f2 xs \<noteq> Two \<and> foldl1 f2 ys \<noteq> Two" using Partition by simp
         hence "f2 (foldl1 f2 xs) (foldl1 f2 ys) \<noteq> Two" using f2_One by simp
         thus "foldl1 f2 (xs @ ys) \<noteq> Two" 
           using L8 [symmetric, where f=f2] and f2_assoc and Partition by simp
       qed
     qed
   with Two_map_ys have foldl1_map_ys: "foldl1 f2 (map (h2 i) ys) \<noteq> Two" 
     using ys_not_empty by simp
 
   from f2_One 
   have "f2 (foldl1 f2 (map (h2 i) xs)) (foldl1 f2 (map (h2 i) ys)) \<noteq> Two"
     using foldl1_map_xs and foldl1_map_ys by simp
   hence "foldl1 f2 (map (h2 i) (xs @ ys)) \<noteq> Two" 
     using foldl1_map [symmetric, where h="h2 i" and f=f2] and f2_assoc 
       and assms and ys_not_empty by simp
   with assms show False by simp
 qed
   
 
 
 subsection \<open>Permutations and Lemma 4\<close>
 
 text \<open>
 In the original paper, the argumentation goes as follows:
 From \<open>Figure_4\<close> and \<open>Figure_5\<close> we can show that \<open>js\<close>
 contains every \<open>i \<le> k\<close> exactly once, and from \<open>Figure_6\<close> we can
 furthermore show that \<open>js\<close> contains no other elements. Thus, \<open>js\<close>
 must be a permutation of \<open>[0..<k + 1]\<close>.
 
 Here, however, the argumentation is different, because we want to use already
 existing results. Therefore, we show first, that the sets of \<open>js\<close> and
 \<open>[0..<k + 1]\<close> are equal using the results of \<open>Figure_4\<close> and
 \<open>Figure_6\<close>. Second, we show that \<open>js\<close> is a distinct list, i.e. no
 element occurs twice in \<open>js\<close>. Since also \<open>[0..<k + 1]\<close> is
 distinct, the multisets of \<open>js\<close> and \<open>[0..<k + 1]\<close> are equal,
 and therefore, both lists are permutations.
 \<close>
 
 lemma js_is_a_permutation:
   assumes A1: "\<And> (f :: three \<Rightarrow> three \<Rightarrow> three) h. associative f
                 \<Longrightarrow> foldl1 f (map h js) = foldl1 f (map h [0..<k + 1])"
       and A2: "js \<noteq> []"
   shows "js <~~> [0..<k + 1]"
 proof -
   from A1 and L9 have L9': 
   "\<And>i. i \<le> k \<Longrightarrow> foldl1 f1 (map (h1 k i) js) = One" by auto
 
   from L9' and Figure_4 and A2 have P1: "\<And>i. i \<le> k \<Longrightarrow> i \<in> set js" by auto
   from L9' and Figure_5 have P2:
     "\<And>i xs ys. \<lbrakk> i \<le> k ; js = xs @ ys \<rbrakk> \<Longrightarrow> \<not>(i \<in> set xs \<and> i \<in> set ys)" by blast
   from L9' and Figure_6 have P3: "\<And>i. i > k \<Longrightarrow> i \<notin> set js" by auto
 
   have set_eq: "set [0..<k + 1] = set js"
     proof
       from P1 show "set [0..<k + 1] \<subseteq> set js" by auto
     next
       show "set js \<subseteq> set [0..<k + 1]"
       proof
         fix j
         assume "j \<in> set js"
         hence "\<not>(j \<notin> set js)" by simp
         with P3 have "\<not>(j > k)" using HOL.contrapos_nn by auto
         hence "j \<le> k" by simp
         thus "j \<in> set [0..<k + 1]" by auto
       qed
     qed
 
   have "\<And>xs ys. js = xs @ ys \<Longrightarrow> set xs \<inter> set ys = {}"
     proof -
       fix xs ys
       assume js_xs_ys: "js = xs @ ys"
       with set_eq have i_xs_ys: "\<And>i. i \<in> set xs \<or> i \<in> set ys \<Longrightarrow> i \<le> k" by auto
       have "\<And>i. i \<le> k \<Longrightarrow> (i \<in> set xs) = (i \<notin> set ys)"
         proof
           fix i
           assume "i \<in> set xs"
           moreover assume "i \<le> k"
           ultimately show "i \<notin> set ys" using js_xs_ys and P2 by simp
         next
           fix i
           assume "i \<notin> set ys"
           moreover assume "i \<le> k"
           ultimately show "i \<in> set xs" using js_xs_ys and P2 and P1 by auto
         qed
       thus "set xs \<inter> set ys = {}" using i_xs_ys by auto
     qed
   with all_set_inter_empty_distinct have "distinct js" using A2 by auto
   with set_eq have "mset js = mset [0..<k + 1]"
     using Multiset.set_eq_iff_mset_eq_distinct 
           [where x=js and y="[0..<k + 1]"] by simp
   thus "js <~~> [0..<k + 1]" 
-    using Permutation.mset_eq_perm [where xs=js and ys="[0..<k + 1]"] 
+    using mset_eq_perm [where xs=js and ys="[0..<k + 1]"] 
     by simp
 qed
 
 
 
 text \<open>
 The result of \<open>Figure_7\<close> is too specific. Instead of having that every
 \<open>i\<close> is eventually followed by \<open>i + 1\<close>, it more useful to know
 that every \<open>i\<close> is followed by all \<open>i + r\<close>, where 
 \<open>r > 0\<close>. This result follows easily by induction from 
 \<open>Figure_7\<close>.
 \<close>
 
 lemma Figure_7_trans:
   assumes A1: "\<And>i xs ys. \<lbrakk> i < k ; js = xs @ ys ; xs \<noteq> [] ; i = last xs \<rbrakk>
                          \<Longrightarrow> (i + 1) \<in> set ys"
       and A2: "(r::nat) > 0"
       and A3: "i + r \<le> k"
       and A4: "js = xs @ ys"
       and A5: "xs \<noteq> []"
       and A6: "i = last xs"
   shows "(i + r) \<in> set ys"
 using A2 A3 proof (induct r)
   case 0 thus ?case by simp
 next
   case (Suc r)
   hence IH: "0 < r \<Longrightarrow> (i + r) \<in> set ys" by simp
   from Suc have i_r_k: "i + Suc r \<le> k" by simp
   show ?case
   proof (cases r)
     case 0 thus ?thesis using A1 and i_r_k and A4 and A5 and A6 by auto
   next
     case Suc 
     with IH have "(i + r) \<in> set ys" by simp
     then obtain p where p_def: "p < length ys \<and> ys ! p = i + r" 
       using List.in_set_conv_nth [where x="i + r"] by auto
     
     let ?xs = "xs @ take (p + 1) ys"
     let ?ys = "drop (p + 1) ys"
 
     have "i + r < k" using i_r_k by simp
     moreover have "js = ?xs @ ?ys" using A4 by simp
     moreover have "?xs \<noteq> []" using A5 by simp
     moreover have "i + r = last ?xs" 
       using p_def and List.take_Suc_conv_app_nth [where i=p and xs=ys] by simp
     ultimately have "(i + Suc r) \<in> set ?ys" using A1 [where i="i + r"] by auto
     thus "(i + Suc r) \<in> set ys" 
       using List.set_drop_subset [where xs=ys] by auto
   qed
 qed
 
 
 
 text \<open>
 Since we want to use Lemma \<open>partitions_sorted\<close> to show that \<open>js\<close>
 is sorted, we need yet another result which can be obtained using the
 previous lemma and some further argumentation:
 \<close>
 
 lemma js_partition_order:
   assumes A1: "js <~~> [0..<k + 1]"
       and A2: "\<And>i xs ys. \<lbrakk> i < k ; js = xs @ ys ; xs \<noteq> [] ; i = last xs \<rbrakk>
                          \<Longrightarrow> (i + 1) \<in> set ys"
       and A3: "js = xs @ ys"
       and A4: "i \<in> set xs" 
       and A5: "j \<in> set ys"
   shows "i \<le> j"
 proof (rule ccontr)
   assume "\<not>(i \<le> j)"
   hence i_j: "i > j" by simp
 
   from A5 obtain pj where pj_def: "pj < length ys \<and> ys ! pj = j" 
     using List.in_set_conv_nth [where x=j] by auto
 
   let ?xs = "xs @ take (pj + 1) ys"
   let ?ys = "drop (pj + 1) ys"
 
   let ?r = "i - j"
 
   from A1 and A3 have "distinct (xs @ ys)" 
-    using Permutation.perm_distinct_iff [where xs="xs @ ys"] by auto
+    using perm_distinct_iff [where xs="xs @ ys"] by auto
   hence xs_ys_inter_empty: "set xs \<inter> set ys = {}" by simp
 
   from A2 and Figure_7_trans have
   "\<And>i r xs ys. \<lbrakk> r > 0 ; i + r \<le> k ; js = xs @ ys ; xs \<noteq> [] ; i = last xs \<rbrakk>
                \<Longrightarrow> (i + r) \<in> set ys" by blast
   moreover from i_j have "?r > 0" by simp
   moreover have "j + ?r \<le> k"
     proof -
       have "i \<in> set js" using A4 and A3 by simp
       hence "i \<in> set [0..<k + 1]" 
-        using A1 and Permutation.perm_set_eq by blast
+        using A1 and perm_set_eq by blast
       hence "i \<le> k" by auto
       thus ?thesis using i_j by simp
     qed
   moreover have "js = ?xs @ ?ys" using A3 by simp
   moreover have "?xs \<noteq> []" using A4 by auto
   moreover have "j = last (?xs)"
     using pj_def and List.take_Suc_conv_app_nth [where i=pj and xs=ys] by simp
   ultimately have "(j + ?r) \<in> set ?ys" by blast
   hence "i \<in> set ys" using i_j and List.set_drop_subset [where xs=ys] by auto
   with A4 and xs_ys_inter_empty show False by auto
 qed
 
 
 
 text \<open>
 With the help of the previous lemma, we show now that \<open>js\<close> equals
 \<open>[0..<k + 1]\<close>, if both lists are permutations and every \<open>i\<close> is
 eventually followed by \<open>i + 1\<close> in \<open>js\<close>.
 \<close>
 
 lemma js_equals_upt_k:
   assumes A1: "js <~~> [0..<k + 1]"
       and A2: "\<And>i xs ys. \<lbrakk> i < k ; js = xs @ ys ; xs \<noteq> [] ; i = last xs \<rbrakk>
                          \<Longrightarrow> (i + 1) \<in> set ys"
   shows "js = [0..<k + 1]"
 proof -
   from A1 and A2 and js_partition_order
   have "\<And>xs ys x y. \<lbrakk> js = xs @ ys ; x \<in> set xs ; y \<in> set ys \<rbrakk> \<Longrightarrow> x \<le> y"
     by blast
   hence "sorted js" using partitions_sorted by blast
   moreover have "distinct js" 
-    using A1 and Permutation.perm_distinct_iff and List.distinct_upt by blast
+    using A1 and perm_distinct_iff and List.distinct_upt by blast
   moreover have "sorted [0..<k + 1]"
     using List.sorted_upt by blast 
   moreover have "distinct [0..<k + 1]" by simp
   moreover have "set js = set [0..<k + 1]" 
-    using A1 and Permutation.perm_set_eq by blast
+    using A1 and perm_set_eq by blast
   ultimately show "js = [0..<k + 1]" using List.sorted_distinct_set_unique 
     by blast
 qed
 
 
 
 text \<open>
 From all the work done before, we conclude now Lemma 4:
 \<close>
 
 lemma Lemma_4:
   assumes "\<And>(f :: three \<Rightarrow> three \<Rightarrow> three) h. associative f  
              \<Longrightarrow> foldl1 f (map h js) = foldl1 f (map h [0..<k + 1])"
       and "js \<noteq> []"
   shows "js = [0..<k + 1]"
 proof -
   from assms and js_is_a_permutation have "js <~~> [0..<k + 1]" by auto
   moreover 
   from assms and L10 and Figure_7
   have "\<And>i xs ys. \<lbrakk> i < k ; js = xs @ ys ; xs \<noteq> [] ; i = last xs \<rbrakk>
                   \<Longrightarrow> (i + 1) \<in> set ys" by blast
   ultimately show ?thesis using js_equals_upt_k by auto
 qed
 
 
 
 subsection \<open>Lemma 5\<close>
 
 text \<open>
 This lemma is a lifting of Lemma 4 to the overall computation of 
 \<open>scanl1\<close>. Its proof follows closely the one given in the original paper.
 \<close>
 
 lemma Lemma_5:
   assumes "\<And>(f :: three \<Rightarrow> three \<Rightarrow> three) h. associative f
              \<Longrightarrow> map (foldl1 f \<circ> map h) jss = scanl1 f (map h [0..<n + 1])"
       and "\<And>js. js \<in> set jss \<Longrightarrow> js \<noteq> []"
   shows "jss = ups n"
 proof -
   have P1: "length jss = length (ups n)" 
     proof -
       obtain f :: "three \<Rightarrow> three \<Rightarrow> three" where f_assoc: "associative f"
         using f1_assoc by auto
 
       fix h
       have 
       "length jss = length (map (foldl1 f \<circ> map h) jss)" by (simp add: L2)
       also have 
       "\<dots> = length (scanl1 f (map h [0..<n + 1]))" 
           using assms and f_assoc by simp
       also have 
       "\<dots> = length (map (\<lambda>k. foldl1 f (take (k + 1) (map h [0..<n + 1])))
                        [0..<length (map h [0..<n + 1])])" by simp
       also have 
       "\<dots> = length [0..<length (map h [0..<n + 1])]" by (simp add: L2)
       also have
       "\<dots> = length [0..<length [0..<n + 1]]" by (simp add: L2)
       also have 
       "\<dots> = length [0..<n + 1]" by simp
       also have 
       "\<dots> = length (map (\<lambda>k. [0..<k + 1]) [0..<n + 1])" by (simp add: L2)
       also have 
       "\<dots> = length (ups n)" by simp
       finally show ?thesis .
     qed
 
   have P2: "\<And>k. k < length jss \<Longrightarrow> jss ! k = (ups n) ! k"
     proof -
       fix k
       assume k_length_jss: "k < length jss"
       hence non_empty_jss_k: "jss ! k \<noteq> []" using assms by simp
 
       from k_length_jss 
       have k_length_length: "k < length [1..<length [0..<n + 1] + 1]"
         using P1 by simp
       hence k_length: "k < length [0..<n + 1]"
         using List.length_upt [where i=1 and j="length [0..<n + 1] + 1"] 
         by simp 
 
       have "\<And>(f :: three \<Rightarrow> three \<Rightarrow> three) h. associative f
                   \<Longrightarrow> foldl1 f (map h (jss ! k)) = foldl1 f (map h [0..<k + 1])"
         proof -
           fix f h
           assume f_assoc: "associative (f :: three \<Rightarrow> three \<Rightarrow> three)"
           have 
           "foldl1 f (map h (jss ! k))
            = (map (foldl1 f \<circ> map h) jss) ! k" 
               using L6 and k_length_jss by auto
           also have 
           "\<dots> = (scanl1 f (map h [0..<n + 1])) ! k" 
               using assms and f_assoc by simp
           also have 
           "\<dots> = (map (\<lambda>k. foldl1 f (take k (map h [0..<n + 1])))
                     [1..<length (map h [0..<n + 1]) + 1]) ! k" by simp
           also have 
           "\<dots> = (map (\<lambda>k. foldl1 f (take k (map h [0..<n + 1]))) 
                     [1..<length [0..<n + 1] + 1]) ! k" 
               by (simp add: L2)
           also have 
           "\<dots> = (\<lambda>k. foldl1 f (take k (map h [0..<n + 1])))
                   ([1..<length [0..<n + 1] + 1] ! k)"
             using L6 [where xs="[1..<length [0..<n + 1] + 1]"
               and f="(\<lambda>k. foldl1 f (take k (map h [0..<n + 1])))"] 
               and k_length_length by auto
           also have 
           "\<dots> = foldl1 f (take (k + 1) (map h [0..<n + 1]))"
               proof -
                 have "[1..<length [0..<n + 1] + 1] ! k  = k + 1"
                   using List.nth_upt [where i=1 and j="length [0..<n + 1] + 1"]
                     and k_length by simp
                 thus ?thesis by simp
               qed
           also have 
           "\<dots> = foldl1 f (map h (take (k + 1) [0..<n + 1]))"
               using L3 [where k="k + 1" and xs="[0..<n + 1]" and f=h] by simp
           also have "\<dots> = foldl1 f (map h [0..<k + 1])"
               using List.take_upt [where i=0 and m="k + 1" and n="n + 1"]
                 and k_length by simp
           finally show 
           "foldl1 f (map h (jss ! k)) = foldl1 f (map h [0..<k + 1])" .
         qed
       with Lemma_4 and non_empty_jss_k have P3: "jss ! k = [0..<k + 1]" 
         by blast
 
       have 
       "(ups n) ! k 
        = (map (\<lambda>k. [0..<k + 1]) [0..<n + 1]) ! k" by simp
       also have 
       "\<dots> = (\<lambda>k. [0..<k + 1]) ([0..<n + 1] ! k)" 
           using L6 [where xs="[0..<n + 1]"] and k_length by auto
       also have 
       "\<dots> = [0..<k + 1]" 
           using List.nth_upt [where i=0 and j="n + 1"] and k_length by simp
       finally have "(ups n) ! k = [0..<k + 1]" .
       
       with P3 show "jss ! k = (ups n) ! k" by simp
     qed
 
   from P1 P2 and Lemma_2 show "jss = ups n" by blast
 qed
 
 
 
 subsection \<open>Proposition 1\<close>
 
 text \<open>
 In the original paper, only non-empty lists where considered, whereas here,
 the used list datatype allows also for empty lists. Therefore, we need to 
 exclude non-empty lists to have a similar setting as in the original paper.
 
 In the case of Proposition 1, we need to show that every list contained in
 the result of \<open>candidate (@) (map wrap [0..<n + 1])\<close> is non-empty.
 The idea is to interpret empty lists by the value \<open>Zero\<close> and non-empty
 lists by the value \<open>One\<close>, and to apply the assumptions.
 \<close>
 
 lemma non_empty_candidate_results:
   assumes "\<And> (f :: three \<Rightarrow> three \<Rightarrow> three) (xs :: three list). 
              \<lbrakk> associative f ; xs \<noteq> [] \<rbrakk>  \<Longrightarrow> candidate f xs = scanl1 f xs"
       and "js \<in> set (candidate (@) (map wrap [0..<n + 1]))"
   shows   "js \<noteq> []"
 proof -
   \<comment> \<open>We define a mapping of lists to values of @{text three} as explained\<close>
   \<comment> \<open>above, and a function which behaves like @{text @} on values of\<close>
   \<comment> \<open>@{text three}.\<close>
   let ?h = "\<lambda>xs. case xs of [] \<Rightarrow> Zero | (_#_) \<Rightarrow> One"
   let ?g = "\<lambda>x y. if (x = One \<or> y = One) then One else Zero"
   have g_assoc: "associative ?g" unfolding associative_def by auto
 
   \<comment> \<open>Our defined functions fulfill the requirements of the free theorem of\<close>
   \<comment> \<open>@{text candidate}, that is:\<close>
   have req_free_theorem: "\<And>xs ys. ?h (xs @ ys) = ?g (?h xs) (?h ys)"
     proof -
       fix xs ys
       show "?h (xs @ ys) = ?g (?h xs) (?h ys)"
         by (cases xs, simp_all, cases ys, simp_all)
     qed
 
   \<comment> \<open>Before applying the assumptions, we show that @{text candidate}'s\<close>
   \<comment> \<open>counterpart @{text scanl1}, applied to a non-empty list, returns only\<close>
   \<comment> \<open>a repetition of the value @{text One}.\<close>
   have set_scanl1_is_One: 
     "set (scanl1 ?g (map ?h (map wrap [0..<n + 1]))) = {One}"
     proof -
       have const_One: "map (\<lambda>x. One) [0..<n + 1] = replicate (n + 1) One"
         proof (induct n)
           case 0 thus ?case by simp
         next
           case (Suc n) 
           have 
           "map (\<lambda>x. One) [0..<Suc n + 1]
            = map (\<lambda>x. One) ([0..<Suc n] @ [Suc n])" by simp
           also have 
           "\<dots> = map (\<lambda>x. One) [0..<Suc n] @ map (\<lambda>x. One) [Suc n]"
               by simp
           also have "\<dots> = replicate (Suc n) One @ replicate 1 One" 
               using Suc by simp
           also have "\<dots> = replicate (Suc n + 1) One" 
               using List.replicate_add 
                       [symmetric, where x=One and n="Suc n" and m=1]
               by simp
           finally show ?case .
         qed
 
       have foldl1_One: "\<And>xs. foldl1 ?g (One # xs) = One" 
         proof -
           fix xs
           show "foldl1 ?g (One # xs) = One" 
           proof (induct xs rule: measure_induct [where f=length])
             fix x
             assume "\<forall>y. length y < length (x::three list) 
                         \<longrightarrow> foldl1 ?g (One # y) = One"
             thus "foldl1 ?g (One # x) = One" by (cases x, auto)
           qed
         qed
 
       have 
       "scanl1 ?g (map ?h (map wrap [0..<n + 1]))
        = scanl1 ?g (map (?h \<circ> wrap) [0..<n + 1])" 
           using L1 [where g="?h" and f=wrap and xs="[0..<n + 1]"] by simp
       also have 
       "\<dots> = scanl1 ?g (map (\<lambda>x. One) [0..<n + 1])" by (simp add: Fun.o_def)
       also have 
       "\<dots> = scanl1 ?g (replicate (n + 1) One)" using const_One by auto
       also have 
       "\<dots> = map (\<lambda>k. foldl1 ?g (take k (replicate (n + 1) One)))
                [1..<length (replicate (n + 1) One) + 1]" by simp
       also have 
       "\<dots> = map (\<lambda>k. foldl1 ?g (take k (replicate (n + 1) One)))
                (map Suc [0..<length (replicate (n + 1) One)])" 
           using List.map_Suc_upt by simp
       also have 
       "\<dots> = map ((\<lambda>k. foldl1 ?g (take k (replicate (n + 1) One))) \<circ> Suc)
                [0..<length (replicate (n + 1) One)]" 
           using L1 by simp
       also have 
       "\<dots> = map (\<lambda>k. foldl1 ?g (replicate (min (k + 1) (n + 1)) One))
                [0..<n + 1]" using Fun.o_def by simp
       also have 
       "\<dots> = map (\<lambda>k. foldl1 ?g (One # replicate (min k n) One)) 
                [0..<n + 1]" by simp
       also have 
       "\<dots> = map (\<lambda>k. One) [0..<n + 1]" using foldl1_One by simp
       also have 
       "\<dots> = replicate (n + 1) One" using const_One by simp
       finally show ?thesis using List.set_replicate [where n="n + 1"] by simp
     qed
 
   \<comment> \<open>Thus, with the assumptions and the free theorem of candidate, we show\<close>
   \<comment> \<open>that results of @{text candidate}, after applying @{text h}, can only\<close>
   \<comment> \<open>have the value @{text One}.\<close>
   have 
   "scanl1 ?g (map ?h (map wrap [0..<n + 1])) 
    = candidate ?g (map ?h (map wrap [0..<n + 1]))" 
       using assms and g_assoc by auto
   also have 
   "\<dots> = map ?h (candidate (@) (map wrap [0..<n + 1]))"
       using candidate_free_theorem [symmetric, where f="(@)" and g="?g" 
       and h="?h" and zs="(map wrap [0..<n + 1])"] and req_free_theorem by auto
   finally have set_is_One: 
   "\<And>x. x \<in> set (map ?h (candidate (@) (map wrap [0..<n + 1])))
        \<Longrightarrow> x = One" 
       using set_scanl1_is_One by auto
 
   \<comment> \<open>Now, it is easy to conclude the thesis.\<close>
   from assms
   have "?h js \<in> ?h ` set (candidate (@) (map wrap [0..<n + 1]))" by auto
   with set_is_One have "?h js = One" by simp
   thus "js \<noteq> []" by auto
 qed
 
 
 
 text \<open>
 Proposition 1 is very similar to the corresponding one shown in the original
 paper except of a slight modification due to the choice of using Isabelle's
 list datatype.
 
 Strictly speaking, the requirement that \<open>xs\<close> must be non-empty in the
 assumptions of Proposition 1 is not necessary, because only non-empty lists
 are applied in the proof. However, the additional requirement eases the proof
 obligations of the final theorem, i.e. this additions allows more (or easier)
 applications of the final theorem.
 \<close>
 
 lemma Proposition_1:
   assumes "\<And> (f :: three \<Rightarrow> three \<Rightarrow> three) (xs :: three list). 
              \<lbrakk> associative f ; xs \<noteq> [] \<rbrakk>  \<Longrightarrow> candidate f xs = scanl1 f xs"
   shows "candidate (@) (map wrap [0..<n + 1]) = ups n"
 proof -
   \<comment> \<open>This addition is necessary because we are using Isabelle's list datatype\<close>
   \<comment> \<open>which allows for empty lists.\<close>
   from assms and non_empty_candidate_results have non_empty_candidate: 
   "\<And>js. js \<in> set (candidate (@) (map wrap [0..<n + 1])) \<Longrightarrow> js \<noteq> []"
       by auto
 
   have "\<And>(f:: three \<Rightarrow> three \<Rightarrow> three) h. associative f
         \<Longrightarrow> map (foldl1 f \<circ> map h) (candidate (@) (map wrap [0..<n + 1])) 
            = scanl1 f (map h [0..<n + 1])" 
     proof -
       fix f h
       assume f_assoc: "associative (f :: three \<Rightarrow> three \<Rightarrow> three)"
       hence 
       "map (foldl1 f \<circ> map h) (candidate (@) (map wrap [0..<n + 1])) 
        = candidate f (map h [0..<n + 1])" using Lemma_3 by auto
       also have 
       "\<dots> = scanl1 f (map h [0..<n + 1])" 
           using assms [where xs="map h [0..<n + 1]"] and f_assoc by simp
       finally show 
       "map (foldl1 f \<circ> map h) (candidate (@) (map wrap [0..<n + 1]))
        = scanl1 f (map h [0..<n + 1])" .
     qed
   with Lemma_5 and non_empty_candidate show ?thesis by auto
 qed
 
 
 
 
 
 section \<open>Proving Proposition 2\<close>
 
 
 text \<open>
 Before proving Proposition 2, a non-trivial step of that proof is shown first.
 In the original paper, the argumentation simply applies L7 and the definition
 of \<open>map\<close> and \<open>[0..<k + 1]\<close>. However, since, L7 requires that
 \<open>k\<close> must be less than \<open>length [0..<length xs]\<close> and this does
 not simply follow for the bound occurrence of \<open>k\<close>, a more complicated
 proof is necessary. Here, it is shown based on Lemma 2.
 \<close>
       
 lemma Prop_2_step_L7:
   "map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) [0..<length xs]
    = map (\<lambda>k. foldl1 g (take (k + 1) xs)) [0..<length xs]" 
 proof -   
   have P1: 
   "length (map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) [0..<length xs])
    = length (map (\<lambda>k. foldl1 g (take (k + 1) xs)) [0..<length xs])" 
       by (simp add: L2)
       
   have P2: 
   "\<And>k. k < length (map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) 
                        [0..<length xs]) 
        \<Longrightarrow> (map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) [0..<length xs]) ! k
           = (map (\<lambda>k. foldl1 g (take (k + 1) xs)) [0..<length xs]) ! k"
     proof -
       fix k
       assume k_length: 
         "k < length (map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1]))
                          [0..<length xs])"
       hence k_length': "k < length xs" by (simp add: L2)
         
       have 
       "(map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) [0..<length xs]) ! k 
        = (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) ([0..<length xs] ! k)"
           using L6 and k_length by (simp add: L2)
       also have 
       "\<dots> = foldl1 g (map (nth xs) [0..<k + 1])" 
           using k_length' by (auto simp: L2)
       also have 
       "\<dots> = foldl1 g (take (k + 1) xs)" 
           using L7 [where k=k and xs=xs] and k_length' by simp
       also have 
       "\<dots> = (\<lambda>k. foldl1 g (take (k + 1) xs)) ([0..<length xs] ! k)" 
           using k_length' by (auto simp: L2)
       also have 
       "\<dots> = (map (\<lambda>k. foldl1 g (take (k + 1) xs)) [0..<length xs]) ! k" 
           using L6 [symmetric] and k_length by (simp add: L2)
       finally show
       "(map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) [0..<length xs]) ! k 
        = (map (\<lambda>k. foldl1 g (take (k + 1) xs)) [0..<length xs]) ! k" .
     qed
       
   from P1 P2 and Lemma_2 show ?thesis by blast
 qed
 
 
 
 text \<open>
 Compared to the original paper, here, Proposition 2 has the additional 
 assumption that \<open>xs\<close> is non-empty. The proof, however, is identical
 to the the one given in the original paper, except for the non-trivial step
 shown before.
 \<close>
 
 lemma Proposition_2:
   assumes A1: "\<And> n. candidate (@) (map wrap [0..<n + 1]) = ups n"
       and A2: "associative g"
       and A3: "xs \<noteq> []"
   shows "candidate g xs = scanl1 g xs"
 proof -
   \<comment> \<open>First, based on Lemma 2, we show that\<close>
   \<comment> \<open>@{term "xs = map (nth xs) [0..<length xs]"}\<close>
   \<comment> \<open>by the following facts P1 and P2.\<close>
 
   have P1: "length xs = length (map (nth xs) [0..<length xs])" 
     proof -
       have 
       "length xs 
        = length [0..<length xs]" by simp
       also have 
       "\<dots> = length (map (nth xs) [0..<length xs])"
           using L2 [symmetric] by auto
       finally show ?thesis .
     qed
 
   have P2: "\<And>k. k < length xs \<Longrightarrow> xs ! k = (map (nth xs) [0..<length xs]) ! k"
     proof -
       fix k
       assume k_length_xs: "k < length xs"
       hence k_length_xs': "k < length [0..<length xs]" by simp
       have 
       "xs ! k = nth xs ([0..<length xs] ! k)" 
           using k_length_xs by simp
       also have 
       "\<dots> = (map (nth xs) [0..<length xs]) ! k" 
           using L6 [symmetric] and k_length_xs' by auto
       finally show "xs ! k = (map (nth xs) [0..<length xs]) ! k" .
     qed
 
   from P1 P2 and Lemma_2 have "xs = map (nth xs) [0..<length xs]" by blast
   
   \<comment> \<open>Thus, with some rewriting, we show the thesis.\<close>
   hence 
   "candidate g xs 
    = candidate g (map (nth xs) [0..<length xs])" by simp
   also have 
   "\<dots> = map (foldl1 g \<circ> map (nth xs))
            (candidate (@) (map wrap [0..<length xs]))"
       using Lemma_3 [symmetric, where h="nth xs" and n="length xs - 1"] 
       and A2 and A3 by auto
   also have 
   "\<dots> = map (foldl1 g \<circ> map (nth xs)) (ups (length xs - 1))"
       using A1 [where n="length xs - 1"] and A3 by simp
   also have 
   "\<dots> = map (foldl1 g \<circ> map (nth xs)) (map (\<lambda>k. [0..<k + 1]) [0..<length xs])"
       using A3 by simp
   also have 
   "\<dots> = map (\<lambda>k. foldl1 g (map (nth xs) [0..<k + 1])) [0..<length xs]"
       using L1 [where g="foldl1 g \<circ> map (nth xs)" and f="(\<lambda>k. [0..<k + 1])"] 
       by (simp add: Fun.o_def)
   also have 
   "\<dots> = map (\<lambda>k. foldl1 g (take (k + 1) xs)) [0..<length xs]" 
       using Prop_2_step_L7 by simp
   also have
   "\<dots> = map (\<lambda>k. foldl1 g (take k xs)) (map (\<lambda>k. k + 1) [0..<length xs])"
       by (simp add: L1)
   also have
   "\<dots> = map (\<lambda>k. foldl1 g (take k xs)) [1..<length xs + 1]"
       using List.map_Suc_upt by simp
   also have 
   "\<dots> = scanl1 g xs" by simp
   finally show ?thesis .
 qed
 
 
 
 
 section \<open>The Final Result\<close>
 
 text \<open>
 Finally, we the main result follows directly from Proposition 1 and 
 Proposition 2.
 \<close>
 
 theorem The_0_1_2_Principle:
   assumes "\<And> (f :: three \<Rightarrow> three \<Rightarrow> three) (xs :: three list). 
              \<lbrakk> associative f ; xs \<noteq> [] \<rbrakk> \<Longrightarrow> candidate f xs = scanl1 f xs"
       and "associative g"
       and "ys \<noteq> []"
   shows "candidate g ys = scanl1 g ys"
 using Proposition_1 Proposition_2 and assms by blast
 
 
 
 
 
 text \<open>
 \section*{Acknowledgments}
 
 I thank Janis Voigtl\"ander for sharing a draft of his paper before its
 publication with me.
 
 \<close>
 
 
 
 (*<*)
 end
 (*>*)
 
diff --git a/thys/Polynomial_Factorization/ROOT b/thys/Polynomial_Factorization/ROOT
--- a/thys/Polynomial_Factorization/ROOT
+++ b/thys/Polynomial_Factorization/ROOT
@@ -1,74 +1,74 @@
 chapter AFP
 
 session "JNF-AFP-Lib" (AFP) in "Lib" = "HOL-Algebra" +
   description "Theories from HOL-Library and the Archive of Formal Proofs that are used by this entry"
   options [timeout = 600]
   sessions
     Containers
     "Abstract-Rewriting"
     Gauss_Jordan Matrix
     Polynomial_Interpolation
     Show
     VectorSpace
     "HOL-Cardinals"
   theories
     Containers.Set_Impl
     Matrix.Utility
     Matrix.Ordered_Semiring
     "Abstract-Rewriting.SN_Order_Carrier"
     "Abstract-Rewriting.Relative_Rewriting"
     Show.Show_Instances
     VectorSpace.VectorSpace
     Polynomial_Interpolation.Missing_Polynomial
     Polynomial_Interpolation.Ring_Hom_Poly
     "HOL-Library.AList"
     "HOL-Library.Cardinality"
     "HOL-Library.Char_ord"
     "HOL-Library.Code_Binary_Nat"
     "HOL-Library.Code_Target_Numeral"
     "HOL-Library.DAList"
     "HOL-Library.DAList_Multiset"
     "HOL-Library.Infinite_Set"
     "HOL-Library.Lattice_Syntax"
     "HOL-Library.Mapping"
     "HOL-Library.Monad_Syntax"
     "HOL-Library.More_List"
     "HOL-Library.Multiset"
-    "HOL-Library.Permutation"
+    "HOL-Library.List_Permutation"
     "HOL-Library.Permutations"
     "HOL-Library.IArray"
     "HOL-Library.Phantom_Type"
     "HOL-Library.Ramsey"
     "HOL-Library.RBT_Impl"
     "HOL-Library.Simps_Case_Conv"
     "HOL-Library.While_Combinator"
     "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
     "HOL-Computational_Algebra.Fraction_Field"
     "HOL-Computational_Algebra.Polynomial"
     "HOL-Computational_Algebra.Primes"
     "HOL-Cardinals.Order_Union"
     "HOL-Cardinals.Wellorder_Extension"
 
 
 session Polynomial_Factorization (AFP) = "JNF-AFP-Lib" + 
   description "Algebraic Numbers"
   options [timeout = 600]
   sessions
     Partial_Function_MR
     Polynomial_Interpolation
     Show
     Sqrt_Babylonian
   theories
     Missing_Multiset
     Missing_List
     Precomputation
     Order_Polynomial
     Explicit_Roots
     Dvd_Int_Poly
     Rational_Root_Test
     Kronecker_Factorization
     Square_Free_Factorization
     Rational_Factorization
   document_files
     "root.bib"
     "root.tex"
diff --git a/thys/Program-Conflict-Analysis/Interleave.thy b/thys/Program-Conflict-Analysis/Interleave.thy
--- a/thys/Program-Conflict-Analysis/Interleave.thy
+++ b/thys/Program-Conflict-Analysis/Interleave.thy
@@ -1,417 +1,417 @@
 (*  Title:       Conflict analysis/List Interleaving Operator
     Author:      Peter Lammich <peter.lammich@uni-muenster.de>
     Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
 *)
 section "List Interleaving Operator"
 theory Interleave
-imports Main "HOL-Library.Permutation" Misc
+imports Main "HOL-Library.List_Permutation" Misc
 begin
 text_raw \<open>\label{thy:Interleave}\<close>
 
 text \<open>
   This theory defines an operator to return the set of all possible interleavings of two lists.
 \<close>
 
 (*
   Is \<Otimes>-operator needed ?
     Should we better do a reformulation of \<otimes> on sets of lists, to get an associative, commutative operator with identity (ACI ?) ?
 *)
 
 subsection "Definitions"
 
 subsubsection "Prepend and concatenate lifted to sets"
 
 definition list_set_cons :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<cdot>" 65)
   where [simp]: "a\<cdot>S = (#) a ` S"
 
 definition list_set_append :: "'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<odot>" 65)
   where [simp]: "a\<odot>S = (@) a ` S"
 
 subsubsection "The interleaving operator"
 
 function
   interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" (infixr "\<otimes>" 64)
 where
   "[]\<otimes>b = {b}"
   | "a\<otimes>[] = {a}"
   | "a#l \<otimes> b#r = ((a\<cdot>(l \<otimes> b#r)) \<union> (b\<cdot>(a#l \<otimes> r)))"
 by pat_completeness auto
 termination by lexicographic_order
 
 
 subsection "Properties"
 
 subsubsection "Lifted prepend and concatenate operators"
 lemma cons_set_cons_eq: "a#l \<in> b\<cdot>S = (a=b & l\<in>S)"
   by auto
 lemma append_set_append_eq: "\<lbrakk>length a = length b\<rbrakk> \<Longrightarrow> a@l \<in> b\<odot>S = (a=b & l\<in>S)"
   by auto
 
 lemma list_set_cons_cases[cases set]: "\<lbrakk>w\<in>a\<cdot>S; !!w'. \<lbrakk> w=a#w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by auto
 lemma list_set_append_cases[cases set]: "\<lbrakk>w\<in>a\<odot>S; !!w'. \<lbrakk> w=a@w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by auto
 
 subsubsection "Standard simplification-, introduction-, elimination-, and induction rules"
 lemma interleave_cons1: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> x#a \<otimes> b"
   apply(case_tac b)
   apply(auto)
 done
   
 lemma interleave_cons2: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> a \<otimes> x#b"
   apply(case_tac a)
   apply(auto)
 done
 
 lemmas interleave_cons = interleave_cons1 interleave_cons2
 
 
 lemma interleave_empty[simp]: "[]\<in>a\<otimes>b = (a=[] & b=[])"
   apply(case_tac a)
   apply(case_tac b)
   apply(simp)
   apply(simp)
   apply(case_tac b)
   apply(auto)
 done
 
 (* TODO: Is this wise as default simp ?*)
 lemma interleave_length[rule_format, simp]: "ALL x : a\<otimes>b . length x = length a + length b"
   apply(induct rule: interleave.induct)
   apply(auto)
 done
 
 lemma interleave_same[simp]: "y\<in>l\<otimes>y = (l=[])"
   apply (rule iffI)
   apply (subgoal_tac "length y = length l + length y")
   apply (simp del: interleave_length)
   apply (erule interleave_length)
   apply simp
 done
 
 lemma interleave_comm[simp]: "a\<otimes>b = b\<otimes>a" (is "?P f a b")
   apply(induct rule: interleave.induct)
   apply(auto)
 done
 
 lemma interleave_cont_conc[rule_format, simp]: "ALL b . a@b \<in> a\<otimes>b"
   apply(induct_tac a)
   apply(auto simp add: interleave_cons)
 done
 
 lemma interleave_cont_rev_conc[simp]: "b@a \<in> a\<otimes>b"
   apply (subgoal_tac "b@a \<in> b\<otimes>a")
   apply(simp)
   apply(simp only: interleave_cont_conc)
 done
 
 lemma interleave_not_empty: "a\<otimes>b ~= {}" 
   apply(induct rule: interleave.induct)
   apply(auto)
 done
 
 lemma cons_interleave_split: "\<lbrakk>a#l \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=a#lh & l \<in> lh\<otimes>l2 | l2=a#lh & l \<in> l1\<otimes>lh )"
   apply(case_tac l1)
   apply(auto)
   apply(case_tac l2)
   apply(auto)
 done
 
 lemma cons_interleave_cases[cases set, case_names left right]: "\<lbrakk>a#l \<in> l1\<otimes>l2; !!lh . \<lbrakk>l1=a#lh; l \<in> lh\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!lh. \<lbrakk>l2=a#lh; l \<in> l1\<otimes>lh\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by (blast dest: cons_interleave_split)
 
 lemma interleave_cases[cases set, case_names empty left right]: "\<lbrakk>l\<in>l1\<otimes>l2; \<lbrakk> l=[]; l1=[]; l2=[] \<rbrakk> \<Longrightarrow> P; !!a l' l1'. \<lbrakk>l=a#l'; l1=a#l1'; l'\<in>l1'\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!a l' l2'. \<lbrakk>l=a#l'; l2=a#l2'; l'\<in>l1\<otimes>l2'\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   apply (cases l)
   apply (simp)
   apply simp
   apply (erule cons_interleave_cases)
   apply simp_all
   done
 
 lemma interleave_elem_induct[induct set, case_names empty left right]: 
   "!!w1 w2. \<lbrakk> w\<in>w1\<otimes>w2; P [] [] []; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) (e#w1) w2; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) w1 (e#w2) \<rbrakk> \<Longrightarrow> P w w1 w2"
   by (induct w) (auto elim!: cons_interleave_cases intro!: interleave_cons)
 
 lemma interleave_rev_cons1[rule_format]: "ALL a b . l \<in> a\<otimes>b \<longrightarrow> l@[x] \<in> a@[x] \<otimes> b" (is "?P l") 
 proof (induct l)
   case Nil show ?case by (simp)
   case (Cons e l)
     assume IH[rule_format]: "?P l"
     show "?P (e#l)" proof (intro allI impI)
       fix a b
       assume "e#l \<in> a\<otimes>b"
       then obtain c where SPLIT: "a=e#c & l\<in>c\<otimes>b | b=e#c & l\<in>a\<otimes>c" by (blast dest: cons_interleave_split)
       with IH have "a=e#c & l@[x]\<in>c@[x]\<otimes>b | b=e#c & l@[x]\<in>a@[x]\<otimes>c" by auto
       hence "a=e#c & e#l@[x]\<in>e#c@[x]\<otimes>b | b=e#c & e#l@[x]\<in>a@[x]\<otimes>e#c" by (auto simp add: interleave_cons)
       thus "(e#l)@[x]\<in>a@[x]\<otimes>b" by auto
     qed
 qed
 
 corollary interleave_rev_cons2: "l \<in> a\<otimes>b \<Longrightarrow> l@[x] \<in> a \<otimes> b@[x]"
 proof -
   assume "l \<in> a\<otimes>b"
   hence "l\<in>b\<otimes>a" by auto
   hence "l@[x] \<in> b@[x] \<otimes> a" by (blast dest: interleave_rev_cons1)
   thus ?thesis by auto
 qed
 
 lemmas interleave_rev_cons = interleave_rev_cons1 interleave_rev_cons2
 
 
 subsubsection "Interleaving and list concatenation"
 
 lemma interleave_append1: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> x@a \<otimes> b" proof -
   have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> x@a \<otimes> b" (is "?P x") proof (induct x)
     show "?P []" by simp
   next
     fix e
     fix x::"'a list"
     assume IH: "?P x"
     show "?P (e#x)" proof (intro impI allI)
       fix l::"'a list" 
       fix a b
       assume "l \<in> a \<otimes> b"
       with IH have "x@l \<in> x@a \<otimes> b" by auto
       with interleave_cons1 show "(e # x) @ l \<in> (e # x) @ a \<otimes> b" by force
     qed
   qed
   moreover assume "l \<in> a \<otimes> b"
   ultimately show ?thesis by blast
 qed
 
 lemma interleave_append2: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> a \<otimes> x@b" proof -
   have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> a \<otimes> x@b" (is "?P x") proof (induct x)
     show "?P []" by simp
   next
     fix a 
     fix x::"'a list"
     assume IH: "\<forall>l a b. l \<in> a \<otimes> b \<longrightarrow> x @ l \<in> a \<otimes> x @ b"
     show "\<forall>l aa b. l \<in> aa \<otimes> b \<longrightarrow> (a # x) @ l \<in> aa \<otimes> (a # x) @ b" proof (intro impI allI)
       fix l::"'a list" 
       fix aa b
       assume "l \<in> aa \<otimes> b"
 
       with IH have "x@l \<in> aa \<otimes> x@b" by auto
       with interleave_cons2 show "(a # x) @ l \<in> aa \<otimes> (a # x) @ b" by force
     qed
   qed
   moreover assume "l \<in> a \<otimes> b"
   ultimately show ?thesis by blast
 qed
 
 lemmas interleave_append = interleave_append1 interleave_append2
 
 lemma interleave_rev_append1: "!!a b w. w\<in>a\<otimes>b \<Longrightarrow> w@w' \<in> a@w' \<otimes> b"
 proof (induct w' rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc e w') note IHP=this
   hence "w@w'\<in>a@w'\<otimes>b" by auto
   thus ?case using interleave_rev_cons1[of "w@w'" "a@w'" "b"] by (simp)
 qed
 lemma interleave_rev_append2: "w\<in>a\<otimes>b \<Longrightarrow> w@w' \<in> a \<otimes> b@w'"
   by (simp only: interleave_comm[of a b] interleave_comm[of a "b@w'"]) (blast dest: interleave_rev_append1)
 lemmas interleave_rev_append = interleave_rev_append1 interleave_rev_append2
 
 lemma interleave_rev1[rule_format]: "ALL w1 w2 . (w\<in>w1\<otimes>w2) \<longrightarrow> (rev w \<in> rev w1 \<otimes> rev w2)" (is "?P w")
 proof (induct w)
   case Nil show ?case by (simp)
   case (Cons e w)
     assume IH[rule_format]: "?P w"
     show ?case proof (clarsimp)
       fix w1 w2
       assume "e # w \<in> w1 \<otimes> w2"
       then obtain w' where "w1=e#w' & w\<in>w'\<otimes>w2 | w2=e#w' & w\<in>w1\<otimes>w'" by (blast dest: cons_interleave_split)
       with IH have "w1=e#w' & rev w\<in>rev w' \<otimes> rev w2 | w2=e#w' & rev w \<in> rev w1 \<otimes> rev w'" by auto
       thus "rev w @ [e]\<in>rev w1 \<otimes> rev w2" by (auto simp add: interleave_rev_cons)
     qed
 qed
 
 corollary interleave_rev2: "(rev w \<in> rev w1 \<otimes> rev w2) \<Longrightarrow> (w\<in>w1\<otimes>w2)" 
   apply (subgoal_tac "(rev w\<in>rev w1\<otimes>rev w2) = (rev (rev w) \<in> rev (rev w1) \<otimes> rev (rev w2))")
   apply(simp)
   apply (blast dest: interleave_rev1)
 done
 
 lemmas interleave_rev = interleave_rev1 interleave_rev2
 
 lemma rev_cons_interleave_split: "\<lbrakk>l@[a] \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=lh@[a] & l \<in> lh\<otimes>l2 | l2=lh@[a] & l \<in> l1\<otimes>lh )"
 proof -
   assume "l@[a] \<in> l1\<otimes>l2"
   hence "a#rev l \<in> rev l1 \<otimes> rev l2" by (auto dest: interleave_rev)
   then obtain lh where "rev l1 = a#lh & rev l \<in> lh\<otimes>rev l2 | rev l2 = a#lh & rev l \<in> rev l1 \<otimes> lh" by (blast dest: cons_interleave_split)
   hence "rev l1 = a#lh & l \<in> rev lh \<otimes> l2 | rev l2 = a#lh & l \<in> l1 \<otimes> rev lh" by (auto dest: interleave_rev)
   hence "l1 = rev lh @ [a] & l \<in> rev lh \<otimes> l2 | l2 = rev lh @ [a] & l \<in> l1 \<otimes> rev lh" by (simp add: rev_swap)
   thus ?thesis by blast
 qed
 
 subsubsection "Associativity"
  
 lemma interleave_s_assoc1[rule_format]: "ALL w1 ws w2 w3 . (w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3))" proof (induct w)
   case Nil show ?case by (auto)
   case (Cons e w)
     assume IH: "ALL w1 ws w2 w3 . w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3)"
     show ?case proof (intro impI allI)
       fix w1 ws w2 w3
       assume A: "e#w \<in> w1 \<otimes> ws \<and> ws \<in> w2 \<otimes> w3"
       then obtain wh where CASES: "w1=e#wh & w\<in>wh\<otimes>ws | ws=e#wh & w\<in>w1\<otimes>wh" by (blast dest!: cons_interleave_split)
       moreover {
         assume CASE: "w1=e#wh & w\<in>wh\<otimes>ws"
         with A IH obtain ws' where "ws'\<in>wh\<otimes>w2 & w\<in>ws'\<otimes>w3" by (blast)
         hence "e#ws'\<in> (e#wh)\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
         with CASE have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
       } moreover {
         assume CASE: "ws=e#wh & w\<in>w1\<otimes>wh"
         with A obtain whh where "w2=e#whh & wh\<in>whh\<otimes>w3 | w3=e#whh & wh\<in>w2\<otimes>whh" by (blast dest!: cons_interleave_split)
         moreover {
           assume SCASE: "w2=e#whh & wh\<in>whh\<otimes>w3"
           with CASE IH obtain ws' where "ws'\<in>w1\<otimes>whh & w\<in>ws'\<otimes>w3" by blast
           with SCASE have "e#ws'\<in>w1\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
           hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
         } moreover {
           assume SCASE: "w3=e#whh & wh\<in>w2\<otimes>whh"
           with CASE IH obtain ws' where "ws'\<in>w1\<otimes>w2 & w\<in>ws'\<otimes>whh" by blast
           with SCASE have "ws'\<in>w1\<otimes>w2 & e#w \<in> ws'\<otimes>w3" by (auto simp add: interleave_cons)
           hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
         } ultimately have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
       } ultimately show "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
     qed
 qed
 
 lemma interleave_s_assoc2: "\<lbrakk>w\<in>ws\<otimes>w3; ws\<in>w1\<otimes>w2\<rbrakk> \<Longrightarrow> EX ws' : w2\<otimes>w3 . w \<in> w1\<otimes>ws'" proof -
   assume "w \<in> ws \<otimes> w3" "ws \<in> w1 \<otimes> w2"
   hence "w \<in> w3 \<otimes> ws & ws \<in> w2 \<otimes> w1" by simp
   hence "EX ws':w3\<otimes>w2 . w\<in>ws'\<otimes>w1" by (simp only: interleave_s_assoc1)
   thus ?thesis by simp
 qed
   
 lemmas interleave_s_assoc = interleave_s_assoc1 interleave_s_assoc2
 
 subsubsection "Relation to other standard list operations"
 
 lemma interleave_set: "w\<in>w1\<otimes>w2 \<Longrightarrow> set w = set w1 \<union> set w2"
   by (induct rule: interleave_elem_induct) auto
 lemma interleave_map: "w\<in>w1\<otimes>w2 \<Longrightarrow> map f w \<in> map f w1 \<otimes> map f w2"
   by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)
 lemma interleave_filter: "w\<in>w1\<otimes>w2 \<Longrightarrow> filter f w \<in> filter f w1 \<otimes> filter f w2"
   by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)
 
 
 subsubsection "Relation to sublist order"
 
 lemma ileq_interleave_alt: "l'\<preceq>l == \<exists>lb. l\<in>lb \<otimes> l'" proof (rule eq_reflection)
   {fix l' l have "l'\<preceq>l \<Longrightarrow> \<exists>lb. l\<in>lb \<otimes> l'" by (induct rule: less_eq_list_induct) (simp, (blast intro: interleave_cons)+)}
   moreover {fix l have "!!lb l'. l\<in>lb\<otimes>l' \<Longrightarrow> l'\<preceq>l" by (induct l) (auto intro: less_eq_list_drop elim!: cons_interleave_cases)}
   ultimately show "(l'\<preceq>l) = (\<exists>lb. l\<in>lb \<otimes> l')" by blast
 qed
 
 lemma ileq_interleave: "w\<in>w1\<otimes>w2 \<Longrightarrow> w1\<preceq>w & w2\<preceq>w"
   by (unfold ileq_interleave_alt, auto)
 
 lemma ilt_ex_notempty: "x < y \<longleftrightarrow> (\<exists>xs. xs \<noteq> [] \<and> y \<in> xs \<otimes> x)"
   apply (auto simp add: order_less_le ileq_interleave_alt)
   apply (case_tac lb)
   apply auto
 done
 
 
 lemma ilt_interleave1: "\<lbrakk>w\<in>w1\<otimes>w2; w1~=[]\<rbrakk> \<Longrightarrow> w2<w"
   by (simp only: ilt_ex_notempty, blast)
 lemma ilt_interleave2: "\<lbrakk>w\<in>w1\<otimes>w2; w2~=[]\<rbrakk> \<Longrightarrow> w1<w"
   by (simp only: ilt_ex_notempty interleave_comm[of w1 w2], blast)
 lemmas ilt_interleave = ilt_interleave1 ilt_interleave2
 
 
 subsubsection "Exotic/specialized lemmas"
 \<comment> \<open>Recover structure of @{text w} wrt. to structure of @{text "w1"}\<close>
 lemma interleave_recover1[rule_format]: "ALL w1a w1b w2 . w\<in>(w1a@w1b)\<otimes>w2 \<longrightarrow> (EX wa wb w2a w2b . w=wa@wb & w2=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b)" 
   (is "?P w" is "ALL w1a w1b w2 . ?PRE w w1a w1b w2 \<longrightarrow> ?CONS w w1a w1b w2")
 proof (induct w)
   case Nil show ?case by (auto)
   case (Cons e w)
     assume IH[rule_format]: "?P w"
     show "?P (e#w)" proof (intro allI impI)
       fix w1a w1b w2
       assume PRE: "e # w \<in> w1a @ w1b \<otimes> w2"
       {
         assume CASE: "w1a=[]"
         with PRE have "e#w=[]@(e#w) & w2=[]@w2 & []\<in>w1a\<otimes>[] & e#w\<in>w1b\<otimes>w2" by (auto)
         hence "?CONS (e#w) w1a w1b w2" by blast
       } moreover {
         assume CASE: "w1a~=[]"
         with PRE obtain wh where SCASES: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2 | w2=e#wh & w\<in>w1a@w1b\<otimes>wh" by (blast dest: cons_interleave_split)
         moreover {
           assume SCASE: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2"
           with CASE obtain w1ah where W1AFMT: "w1a=e#w1ah & w1ah@w1b=wh" by (cases w1a, auto)
           with SCASE have "w\<in>w1ah@w1b\<otimes>w2" by auto
           with IH[of w1ah w1b w2] obtain wa wb w2a w2b where "w=wa@wb & w2=w2a@w2b & wa\<in>w1ah\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (blast)
           with W1AFMT have "e#w=(e#wa)@wb & e#w\<in>e#wa\<otimes>wb & w2=w2a@w2b & e#wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
           hence "?CONS (e#w) w1a w1b w2" by blast
         } moreover {
           assume SCASE: "w2=e#wh & w\<in>w1a@w1b\<otimes>wh"
           with IH[of w1a w1b wh] obtain wa wb w2a w2b where "w=wa@wb & wh=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by blast
           with SCASE have "e#w=(e#wa)@wb & w2=(e#w2a)@w2b & e#wa\<in>w1a\<otimes>e#w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
           hence "?CONS (e#w) w1a w1b w2" by blast
         }
         ultimately have "?CONS (e#w) w1a w1b w2" by blast
       }
       ultimately show "?CONS (e#w) w1a w1b w2" by blast
     qed
 qed
 
 lemma interleave_recover2: "w\<in>w1\<otimes>(w2a@w2b) \<Longrightarrow> EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b"
 proof -
   assume "w\<in>w1\<otimes>(w2a@w2b)"
   hence "w\<in>(w2a@w2b)\<otimes>w1" by auto
   hence "EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w2a\<otimes>w1a & wb\<in>w2b\<otimes>w1b" by (blast dest: interleave_recover1)
   thus ?thesis by auto
 qed
 
 lemmas interleave_recover = interleave_recover1 interleave_recover2
 
 \<comment> \<open>Split operands according to element of result\<close>
 lemma interleave_unconc: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 \<Longrightarrow> \<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22"
 proof (induct l1)
   case Nil hence "w1=[]@w1 & w2=[]@w2 & []\<in>[]\<otimes>[] & l2\<in>w1\<otimes>w2" by auto
   thus ?case by fast
 next
   case (Cons e l1') note IHP=this
   hence "e#(l1'@l2)\<in>w1\<otimes>w2" by auto
   with cons_interleave_split obtain w' where "(w1=e#w' & l1'@l2\<in>w'\<otimes>w2) | (w2=e#w' & l1'@l2\<in>w1\<otimes>w')" (is "?C1 | ?C2") by (fast)
   moreover {
     assume CASE: ?C1
     moreover then obtain w11' w12' w21 w22 where "w'=w11'@w12' \<and> w2=w21@w22 \<and> l1'\<in>w11'\<otimes>w21 \<and> l2\<in>w12'\<otimes>w22" by (fast dest: IHP(1))
     moreover hence "e#w'=(e#w11')@w12' & e#l1'\<in>(e#w11')\<otimes>w21" by (auto dest: interleave_cons)
     ultimately have ?case by fast
   } moreover {
     assume CASE: ?C2
     moreover then obtain w11 w12 w21' w22' where "w1=w11@w12 \<and> w'=w21'@w22' \<and> l1'\<in>w11\<otimes>w21' \<and> l2\<in>w12\<otimes>w22'" by (fast dest: IHP(1))
     moreover hence "e#w'=(e#w21')@w22' & e#l1'\<in>w11\<otimes>(e#w21')" by (auto dest: interleave_cons)
     ultimately have ?case by fast
   } ultimately show ?case by fast
 qed
 
 \<comment> \<open>Reverse direction of @{thm [source] "interleave_unconc"}\<close>
 lemma interleave_reconc: "!!w11 w21 l2 w12 w22 . \<lbrakk>l1\<in>w11\<otimes>w21;l2\<in>w12\<otimes>w22\<rbrakk> \<Longrightarrow> l1@l2\<in>(w11@w12)\<otimes>(w21@w22)"
 proof (induct l1)
   case Nil thus ?case by (auto)
 next
   case (Cons e l1') note IHP=this
   then obtain w' where "(w11=e#w' & l1'\<in>w'\<otimes>w21) | (w21=e#w' & l1'\<in>w11\<otimes>w')" (is "?C1 | ?C2") by (fast dest: cons_interleave_split)
   moreover {
     assume CASE: ?C1
     moreover with IHP have "l1'@l2\<in>(w'@w12)\<otimes>(w21@w22)" by auto
     ultimately have ?case by (auto dest: interleave_cons)
   } moreover {
     assume CASE: ?C2
     moreover with IHP have "l1'@l2\<in>(w11@w12)\<otimes>(w'@w22)" by auto
     ultimately have ?case by (auto dest: interleave_cons)
   } ultimately show ?case by fast
 qed
 
 (* interleave_unconc and interleave_reconc as equivalence *)
 lemma interleave_unconc_eq: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 = (\<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22)"
   by (fast dest: interleave_reconc interleave_unconc)
 
 
 end
diff --git a/thys/Selection_Heap_Sort/Sort.thy b/thys/Selection_Heap_Sort/Sort.thy
--- a/thys/Selection_Heap_Sort/Sort.thy
+++ b/thys/Selection_Heap_Sort/Sort.thy
@@ -1,35 +1,35 @@
 (*  Title:      Sort.thy
     Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)
 
 section \<open>Locale Sort\<close>
 
 theory Sort
 imports Main 
-  "HOL-Library.Permutation"
+  "HOL-Library.List_Permutation"
 begin
 
 text \<open>
 First, we start from the definition of sorting algorithm. {\em What
   are the basic properties that any sorting algorithm must satisfy? }
 There are two
 basic features any sorting algorithm must satisfy:
 \begin{itemize}
 \item The elements of sorted array must be in some order,
   e.g. ascending or descending order. In this paper we are sorting in
   ascending order.
   $$sorted\ (sort\ \ l)$$
 
 \item The algorithm does not change or delete elements of the given
   array, e.g. the sorted array is the permutation of the input
   array. 
   $$sort\ l\ <\sim \sim>\ l$$
 \end{itemize}
 
 \<close>
 
 locale Sort =
   fixes sort :: "'a::linorder list \<Rightarrow> 'a list"
   assumes sorted: "sorted (sort l)"
   assumes permutation: "sort l <~~> l"
 
 end
diff --git a/thys/Simpl/ex/Quicksort.thy b/thys/Simpl/ex/Quicksort.thy
--- a/thys/Simpl/ex/Quicksort.thy
+++ b/thys/Simpl/ex/Quicksort.thy
@@ -1,281 +1,281 @@
 (*
     Author:      Norbert Schirmer
     Maintainer:  Norbert Schirmer, norbert.schirmer at web de
     License:     LGPL
 *)
 
 (*  Title:      Quicksort.thy
     Author:     Norbert Schirmer, TU Muenchen
 
 Copyright (C) 2004-2008 Norbert Schirmer
 Some rights reserved, TU Muenchen
 
 This library is free software; you can redistribute it and/or modify
 it under the terms of the GNU Lesser General Public License as
 published by the Free Software Foundation; either version 2.1 of the
 License, or (at your option) any later version.
 
 This library is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 Lesser General Public License for more details.
 
 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 USA
 *)
 
 section "Example: Quicksort on Heap Lists"
 
 theory Quicksort
-imports "../Vcg" "../HeapList" "HOL-Library.Permutation"
+imports "../Vcg" "../HeapList" "HOL-Library.List_Permutation"
 begin
 
 record globals_heap =
   next_' :: "ref \<Rightarrow> ref"
   cont_' :: "ref \<Rightarrow> nat"
 
 record 'g vars = "'g state" +
   p_'    :: "ref"
   q_'    :: "ref"
   le_'   :: "ref"
   gt_'   :: "ref"
   hd_'   :: "ref"
   tl_'   :: "ref"
 
 procedures
   append(p,q|p) =
     "IF \<acute>p=Null THEN \<acute>p :== \<acute>q ELSE \<acute>p\<rightarrow>\<acute>next :== CALL append(\<acute>p\<rightarrow>\<acute>next,\<acute>q) FI"
 
   append_spec:
    "\<forall>\<sigma> Ps Qs.
      \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
            \<acute>p :== PROC append(\<acute>p,\<acute>q)
          \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
 
   append_modifies:
    "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
 
 
 lemma (in append_impl) append_modifies:
   shows
    "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
   apply (hoare_rule HoarePartial.ProcRec1)
   apply (vcg spec=modifies)
   done
 
 
 lemma (in append_impl) append_spec:
   shows "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>
             \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
                 \<acute>p :== PROC append(\<acute>p,\<acute>q)
             \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
   apply (hoare_rule HoarePartial.ProcRec1)
   apply vcg
   apply fastforce
   done
 
 primrec sorted:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list  \<Rightarrow> bool"
 where
 "sorted le [] = True" |
 "sorted le (x#xs) = ((\<forall>y\<in>set xs. le x y) \<and> sorted le xs)"
 
 lemma perm_set_eq:
   assumes perm: "xs <~~> ys"
   shows "set xs = set ys"
   using perm
   by induct auto
 
 lemma perm_Cons_eq [iff]: "x#xs <~~> x#ys = (xs <~~> ys)"
   by auto
 
 lemma perm_app_Cons_eq1 : "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
 proof -
   have app_Cons: "xs@y#ys <~~> y#xs@ys"
     by (rule perm_sym, rule perm_append_Cons)
   show ?thesis
   proof
     assume "xs@y#ys <~~> zs"
     with app_Cons [THEN perm_sym]
     show "y#xs@ys <~~> zs"
       by (rule perm.trans)
   next
     assume " y#xs@ys <~~> zs"
     with app_Cons
     show "xs@y#ys <~~> zs"
       by (rule perm.trans)
   qed
 qed
 
 lemma perm_app_Cons_eq2 : "zs <~~> xs@y#ys = (zs <~~> y#xs@ys)"
 proof -
   have "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
     by (rule perm_app_Cons_eq1)
   thus ?thesis
     by (iprover intro: perm_sym)
 qed
 
 lemmas perm_app_Cons_simps = perm_app_Cons_eq1 [THEN sym]
                              perm_app_Cons_eq2 [THEN sym]
 
 lemma sorted_append[simp]:
  "sorted le (xs@ys) = (sorted le xs \<and> sorted le ys \<and>
                        (\<forall>x \<in> set xs. \<forall>y \<in> set ys. le x y))"
 by (induct xs, auto)
 
 lemma perm_append_blocks:
   assumes ws_ys: "ws <~~> ys"
   assumes xs_zs: "xs <~~> zs"
   shows "ws@xs <~~> ys@zs"
 using ws_ys
 proof (induct)
   case (swap l x y)
   from xs_zs
   show "(l # x # y) @ xs <~~> (x # l # y) @ zs"
   by (induct) auto
 qed (insert xs_zs , auto)
 
 procedures quickSort(p|p) =
  "IF \<acute>p=Null THEN SKIP
   ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
        \<acute>le :== Null;;
        \<acute>gt :== Null;;
        WHILE \<acute>tl\<noteq>Null DO
          \<acute>hd :== \<acute>tl;;
          \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
          IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
          THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
               \<acute>le :== \<acute>hd
          ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
               \<acute>gt :== \<acute>hd
          FI
        OD;;
        \<acute>le :== CALL quickSort(\<acute>le);;
        \<acute>gt :== CALL quickSort(\<acute>gt);;
        \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
        \<acute>le :== CALL append(\<acute>le,\<acute>p);;
        \<acute>p :== \<acute>le
   FI"
 
   quickSort_spec:
   "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC quickSort(\<acute>p)
        \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
         sorted (\<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
         Ps <~~> sortedPs) \<and>
         (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
 
   quickSort_modifies:
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
 
 
 lemma (in quickSort_impl) quickSort_modifies:
   shows
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
 apply (hoare_rule HoarePartial.ProcRec1)
 apply (vcg spec=modifies)
 done
 
 lemma (in quickSort_impl) quickSort_spec:
 shows
   "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace>
                   \<acute>p :== PROC quickSort(\<acute>p)
                 \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
                  sorted (\<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
                  Ps <~~> sortedPs) \<and>
                  (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
 apply (hoare_rule HoarePartial.ProcRec1)
 apply (hoare_rule anno =
  "IF \<acute>p=Null THEN SKIP
   ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
        \<acute>le :== Null;;
        \<acute>gt :== Null;;
        WHILE \<acute>tl\<noteq>Null
        INV \<lbrace> (\<exists>les grs tls. List \<acute>le \<acute>next les \<and> List \<acute>gt \<acute>next grs \<and>
                List \<acute>tl \<acute>next tls \<and>
                Ps <~~> \<acute>p#tls@les@grs \<and>
                distinct(\<acute>p#tls@les@grs) \<and>
                (\<forall>x\<in>set les. x\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont) \<and>
                (\<forall>x\<in>set grs. \<acute>p\<rightarrow>\<acute>cont < x\<rightarrow>\<acute>cont)) \<and>
                \<acute>p=\<^bsup>\<sigma>\<^esup>p \<and>
                \<acute>cont=\<^bsup>\<sigma>\<^esup>cont \<and>
                List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>
                (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>
        DO
          \<acute>hd :== \<acute>tl;;
          \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
          IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
          THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
               \<acute>le :== \<acute>hd
          ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
               \<acute>gt :== \<acute>hd
          FI
        OD;;
        \<acute>le :== CALL quickSort(\<acute>le);;
        \<acute>gt :== CALL quickSort(\<acute>gt);;
        \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
        \<acute>le :== CALL append(\<acute>le,\<acute>p);;
        \<acute>p :== \<acute>le
   FI" in HoarePartial.annotateI)
 apply vcg
 apply   fastforce
 apply  clarsimp
 apply  (rule conjI)
 apply   clarify
 apply   (rule conjI)
 apply    (rule_tac x="tl#les" in exI)
 apply    simp
 apply    (rule_tac x="grs" in exI)
 apply    simp
 apply    (rule_tac x="ps" in exI)
 apply    simp
 apply    (erule perm.trans)
 apply    simp
 apply    (simp add: perm_app_Cons_simps)
 apply   (simp add: perm_set_eq)
 apply  clarify
 apply  (rule conjI)
 apply   (rule_tac x="les" in exI)
 apply   simp
 apply   (rule_tac x="tl#grs" in exI)
 apply   simp
 apply   (rule_tac x="ps" in exI)
 apply   simp
 apply   (erule perm.trans)
 apply   simp
 apply   (simp add: perm_app_Cons_simps)
 apply  (simp add: perm_set_eq)
 apply clarsimp
 apply (rule_tac ?x=grs in exI)
 apply (rule conjI)
 apply  (erule heap_eq_ListI1)
 apply  clarify
 apply  (erule_tac x=x in allE)back
 apply  blast
 apply clarsimp
 apply (rule_tac x="sortedPs" in exI)
 apply (rule conjI)
 apply  (erule heap_eq_ListI1)
 apply  (clarsimp)
 apply  (erule_tac x=x in allE) back back
 apply  (fast dest!: perm_set_eq)
 apply (rule_tac x="p#sortedPsa" in exI)
 apply (rule conjI)
 apply  (fastforce dest!: perm_set_eq)
 apply (rule conjI)
 apply  (force dest!: perm_set_eq)
 apply clarsimp
 apply (rule conjI)
 apply  (fastforce dest!: perm_set_eq)
 apply (rule conjI)
 apply  (fastforce dest!: perm_set_eq)
 apply (rule conjI)
 apply  (erule perm.trans)
 apply  (simp add:  perm_app_Cons_simps list_all_iff)
 apply  (fastforce intro!: perm_append_blocks)
 apply clarsimp
 apply (erule_tac x=x in allE)+
 apply (force dest!: perm_set_eq)
 done
 
 end
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,8324 @@
 (* 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.RBT_Mapping"
-    "HOL-Library.Permutation"
+    "HOL-Library.List_Permutation"
     "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 "t1 <~~> 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 mset_eq_perm)
 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
       }
       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
   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
   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
     using valuate_nonpos[of "rhs eq" "\<lambda>x. \<langle>\<V> s\<rangle> x - v x"]
     apply force
     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])
 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. t <~~> ?t}"
   proof
     fix x
     assume "x \<in> ?Al L"
     have "x <~~> ?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. t <~~> ?t}"
       by simp
   qed
   moreover
   have "finite {t. t <~~> ?t}"
     by (rule perm_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
             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
             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)
             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
           using valuate_nonpos[of "rhs ?eq" "\<lambda> x. \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x"]
           apply force
           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
         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
       qed
       ultimately
       have False
         using diff_satified dir2
         by (auto split: if_splits)
     }
     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
         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
         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) 
         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/Simplex/Simplex_Auxiliary.thy b/thys/Simplex/Simplex_Auxiliary.thy
--- a/thys/Simplex/Simplex_Auxiliary.thy
+++ b/thys/Simplex/Simplex_Auxiliary.thy
@@ -1,236 +1,236 @@
 (* Authors: F. Maric, M. Spasic *)
 section \<open>Auxiliary Results\<close>
 theory Simplex_Auxiliary
   imports 
-    "HOL-Library.Permutation"
+    "HOL-Library.List_Permutation"
     "HOL-Library.Mapping"
 begin
 
 (* -------------------------------------------------------------------------- *)
 (* MoreList *)
 (* -------------------------------------------------------------------------- *)
 lemma map_reindex:
   assumes "\<forall> i < length l. g (l ! i) = f i"
   shows "map f [0..<length l] = map g l"
   using assms
   by (induct l rule: rev_induct) (auto simp add: nth_append split: if_splits)
 
 lemma map_parametrize_idx: 
   "map f l = map (\<lambda>i. f (l ! i)) [0..<length l]"
   by (induct l rule: rev_induct) (auto simp add: nth_append)
 
 lemma last_tl:
   assumes "length l > 1"
   shows "last (tl l) = last l"
   using assms
   by (induct l) auto
 
 lemma hd_tl:
   assumes "length l > 1"
   shows "hd (tl l) = l ! 1"
   using assms
   by (induct l) (auto simp add: hd_conv_nth)
 
 lemma butlast_empty_conv_length:
   shows "(butlast l = []) = (length l \<le> 1)"
   by (induct l) (auto split: if_splits)
 
 lemma butlast_nth:
   assumes "n + 1 < length l"
   shows "butlast l ! n = l ! n"
   using assms
   by (induct l rule: rev_induct) (auto simp add: nth_append)
 
 lemma last_take_conv_nth:
   assumes "0 < n" "n \<le> length l"
   shows "last (take n l) = l ! (n - 1)"
   using assms
   by (cases "l = []") (auto simp add: last_conv_nth min_def)
 
 lemma tl_nth:
   assumes "l \<noteq> []" 
   shows "tl l ! n = l ! (n + 1)"
   using assms
   by (induct l) auto
 
 lemma interval_3split:
   assumes "i < n"
   shows "[0..<n] = [0..<i] @ [i] @ [i+1..<n]"
 proof-
   have "[0..<n] = [0..<i + 1] @ [i + 1..<n]"
     using upt_add_eq_append[of 0 "i + 1" "n - i - 1"]
     using \<open>i < n\<close>
     by (auto simp del: upt_Suc)
   then show ?thesis
     by simp
 qed
 
 abbreviation "list_min l \<equiv> foldl min (hd l) (tl l)"
 lemma list_min_Min[simp]: "l \<noteq> [] \<Longrightarrow> list_min l = Min (set l)"
 proof (induct l rule: rev_induct)
   case (snoc a l')
   then show ?case
     by (cases "l' = []") (auto simp add: ac_simps)
 qed simp
 
 (* Minimal element of a list satisfying the given property *)
 
 definition min_satisfying :: "(('a::linorder) \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
   "min_satisfying P l \<equiv>
     let xs = filter P l in
     if xs = [] then None else Some (list_min xs)"
 
 lemma min_satisfying_None:
   "min_satisfying P l = None \<longrightarrow> 
     (\<forall> x \<in> set l. \<not> P x)"
   unfolding min_satisfying_def Let_def
   by (simp add: filter_empty_conv)
 
 lemma min_satisfying_Some: 
   "min_satisfying P l = Some x \<longrightarrow> 
       x \<in> set l \<and> P x \<and> (\<forall> x' \<in> set l. x' < x \<longrightarrow> \<not> P x')"
 proof (safe)
   let ?xs = "filter P l"
   assume "min_satisfying P l = Some x"
   then have "set ?xs \<noteq> {}" "x = Min (set ?xs)"
     unfolding min_satisfying_def Let_def
     by (auto split: if_splits simp add: filter_empty_conv)
   then show "x \<in> set l" "P x" 
     using Min_in[of "set ?xs"]
     by simp_all
   fix x'
   assume "x' \<in> set l" "P x'" "x' < x"
   have "x' \<notin> set ?xs"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then have "x' \<ge> x"
       using \<open>x = Min (set ?xs)\<close>
       by simp
     then show False
       using \<open>x' < x\<close>
       by simp
   qed
   then show "False"
     using \<open>x' \<in> set l\<close> \<open>P x'\<close>
     by simp
 qed
 
 (* -------------------------------------------------------------------------- *)
 (* MoreNat *)
 (* -------------------------------------------------------------------------- *)
 
 lemma min_element:
   fixes k :: nat
   assumes "\<exists> (m::nat). P m"
   shows "\<exists> mm. P mm \<and> (\<forall> m'. m' < mm \<longrightarrow> \<not> P m')"
 proof-
   from assms obtain m where "P m"
     by auto
   show ?thesis
   proof (cases "\<forall>m'<m. \<not> P m'")
     case True
     then show ?thesis 
       using \<open>P m\<close>
       by auto
   next
     case False
     then show ?thesis
     proof (induct m)
       case 0
       then show ?case
         by auto
     next
       case (Suc m')
       then show ?case
         by (cases "\<not> (\<forall>m'a<m'. \<not> P m'a)") auto
     qed
   qed
 qed
 
 (* -------------------------------------------------------------------------- *)
 (* MoreFun *)
 (* -------------------------------------------------------------------------- *)
 
 lemma finite_fun_args:
   assumes "finite A" "\<forall> a \<in> A. finite (B a)"
   shows "finite {f. (\<forall> a. if a \<in> A then f a \<in> B a else f a = f0 a)}" (is "finite (?F A)")
   using assms
 proof (induct) 
   case empty
   have "?F {} = {\<lambda> x. f0 x}"
     by auto
   then show ?case
     by auto
 next
   case (insert a A')
   then have "finite (?F A')"
     by auto
   let ?f = "\<lambda> f. {f'. (\<forall> a'. if a = a' then f' a \<in> B a else f' a' = f a')}"
   have "\<forall> f \<in> ?F A'. finite (?f f)"
   proof
     fix f
     assume "f \<in> ?F A'"
     then have "?f f = (\<lambda> b. f (a := b)) ` B a"
       by (force split: if_splits)
     then show "finite (?f f)"
       using \<open>\<forall>a\<in>insert a A'. finite (B a)\<close>
       by auto
   qed
   then have "finite (\<Union> (?f ` (?F A')))"
     using \<open>finite (?F A')\<close>
     by auto
   moreover
   have "?F (insert a A') = \<Union> (?f ` (?F A'))"
   proof
     show "?F (insert a A') \<subseteq> \<Union> (?f ` (?F A'))"
     proof
       fix f
       assume "f \<in> ?F (insert a A')"
       then have "f \<in> ?f (f (a := f0 a))" "f (a := f0 a) \<in> ?F A'"
         using \<open>a \<notin> A'\<close>
         by auto
       then show "f \<in> \<Union> (?f ` (?F A'))"
         by blast
     qed
   next
     show "\<Union> (?f ` (?F A')) \<subseteq> ?F (insert a A')"
     proof
       fix f
       assume "f \<in> \<Union> (?f ` (?F A'))"
       then obtain f0 where "f0 \<in> ?F A'" "f \<in> ?f f0"
         by auto
       then show "f \<in> ?F (insert a A')"
         using \<open>a \<notin> A'\<close>
         by (force split: if_splits)
     qed
   qed
   ultimately
   show ?case
     by simp
 qed
 
 (* -------------------------------------------------------------------------- *)
 (* MoreMapping *)
 (* -------------------------------------------------------------------------- *)
 
 lemma foldl_mapping_update:
   assumes "X \<in> set l" "distinct (map f l)"
   shows "Mapping.lookup (foldl (\<lambda>m a. Mapping.update (f a) (g a) m) i l) (f X) = Some (g X)"
   using assms
 proof(induct l rule:rev_induct)
   case Nil
   then show ?case
     by simp
 next
   case (snoc h t)
   show ?case
   proof (cases "f h = f X")
     case True
     then show ?thesis using snoc by (auto simp: lookup_update)
   next
     case False
     show ?thesis by (simp add: lookup_update' False, rule snoc, insert False snoc, auto)
   qed
 qed
 
 end