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.List_Permutation" "HOL-Library.Permutations"
+  imports "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)"
+lemma rel_mset_via_perm: "rel_mset rel (mset xs) (mset ys) \<longleftrightarrow> (\<exists>zs. mset xs = mset 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
+  note list_all2_reorder_right_invariance[OF zsws ws[symmetric], unfolded zs]
+  then show ?case by (auto dest: sym)
 next
   case 2
-  from this[folded mset_eq_perm] show ?case by force
+  from this 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/Berlekamp_Zassenhaus/Unique_Factorization.thy b/thys/Berlekamp_Zassenhaus/Unique_Factorization.thy
--- a/thys/Berlekamp_Zassenhaus/Unique_Factorization.thy
+++ b/thys/Berlekamp_Zassenhaus/Unique_Factorization.thy
@@ -1,970 +1,971 @@
 theory Unique_Factorization
   imports
     Polynomial_Interpolation.Ring_Hom_Poly
     Polynomial_Factorization.Polynomial_Divisibility
     "HOL-Library.Permutations" 
     "HOL-Computational_Algebra.Euclidean_Algorithm"
     Containers.Containers_Auxiliary (* only for a lemma *)
     Missing_Multiset2
     "HOL-Algebra.Divisibility"
 begin
 
 hide_const(open)
   Divisibility.prime
   Divisibility.irreducible
 
 hide_fact(open)
   Divisibility.irreducible_def
   Divisibility.irreducibleI
   Divisibility.irreducibleD
   Divisibility.irreducibleE
 
 hide_const (open) Rings.coprime
 
 lemma irreducible_uminus [simp]:
   fixes a::"'a::idom"
   shows "irreducible (-a) \<longleftrightarrow> irreducible a"
   using irreducible_mult_unit_left[of "-1::'a"] by auto
 
 context comm_monoid_mult begin
 
   definition coprime :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
     where coprime_def': "coprime p q \<equiv> \<forall>r. r dvd p \<longrightarrow> r dvd q \<longrightarrow> r dvd 1"
 
   lemma coprimeI:
     assumes "\<And>r. r dvd p \<Longrightarrow> r dvd q \<Longrightarrow> r dvd 1"
     shows "coprime p q" using assms by (auto simp: coprime_def')
 
   lemma coprimeE:
     assumes "coprime p q"
         and "(\<And>r. r dvd p \<Longrightarrow> r dvd q \<Longrightarrow> r dvd 1) \<Longrightarrow> thesis"
     shows thesis using assms by (auto simp: coprime_def')
 
   lemma coprime_commute [ac_simps]:
     "coprime p q \<longleftrightarrow> coprime q p"
     by (auto simp add: coprime_def')
 
   lemma not_coprime_iff_common_factor:
     "\<not> coprime p q \<longleftrightarrow> (\<exists>r. r dvd p \<and> r dvd q \<and> \<not> r dvd 1)"
     by (auto simp add: coprime_def')
 
 end
 
 lemma (in algebraic_semidom) coprime_iff_coprime [simp, code]:
   "coprime = Rings.coprime"
   by (simp add: fun_eq_iff coprime_def coprime_def')
 
 lemma (in comm_semiring_1) coprime_0 [simp]:
   "coprime p 0 \<longleftrightarrow> p dvd 1" "coprime 0 p \<longleftrightarrow> p dvd 1"
   by (auto intro: coprimeI elim: coprimeE dest: dvd_trans)
 
 (**** until here ****)
 
 
 (* TODO: move or...? *)
 lemma dvd_rewrites: "dvd.dvd ((*)) = (dvd)" by (unfold dvd.dvd_def dvd_def, rule)
 
 
 subsection \<open>Interfacing UFD properties\<close>
 hide_const (open) Divisibility.irreducible
 
 context comm_monoid_mult_isom begin
   lemma coprime_hom[simp]: "coprime (hom x) y' \<longleftrightarrow> coprime x (Hilbert_Choice.inv hom y')"
   proof-
     show ?thesis by (unfold coprime_def', fold ball_UNIV, subst surj[symmetric], simp)
   qed
   lemma coprime_inv_hom[simp]: "coprime (Hilbert_Choice.inv hom x') y \<longleftrightarrow> coprime x' (hom y)"
   proof-
     interpret inv: comm_monoid_mult_isom "Hilbert_Choice.inv hom"..
     show ?thesis by simp
   qed
 end
 
 subsubsection \<open>Original part\<close>
 
 lemma dvd_dvd_imp_smult:
   fixes p q :: "'a :: idom poly"
   assumes pq: "p dvd q" and qp: "q dvd p" shows "\<exists>c. p = smult c q"
 proof (cases "p = 0")
   case True then show ?thesis by auto
 next
   case False
   from qp obtain r where r: "p = q * r" by (elim dvdE, auto)
   with False qp have r0: "r \<noteq> 0" and q0: "q \<noteq> 0" by auto
   with divides_degree[OF pq] divides_degree[OF qp] False
   have "degree p = degree q" by auto
   with r degree_mult_eq[OF q0 r0] have "degree r = 0" by auto
   from degree_0_id[OF this] obtain c where "r = [:c:]" by metis
   from r[unfolded this] show ?thesis by auto
 qed
 
 lemma dvd_const:
   assumes pq: "(p::'a::semidom poly) dvd q" and q0: "q \<noteq> 0" and degq: "degree q = 0"
   shows "degree p = 0"
 proof-
   from dvdE[OF pq] obtain r where *: "q = p * r".
   with q0 have "p \<noteq> 0" "r \<noteq> 0" by auto
   from degree_mult_eq[OF this] degq * show "degree p = 0" by auto
 qed
 
 context Rings.dvd begin
   abbreviation ddvd (infix "ddvd" 40) where "x ddvd y \<equiv> x dvd y \<and> y dvd x"
   lemma ddvd_sym[sym]: "x ddvd y \<Longrightarrow> y ddvd x" by auto
 end
 
 context comm_monoid_mult begin
   lemma ddvd_trans[trans]: "x ddvd y \<Longrightarrow> y ddvd z \<Longrightarrow> x ddvd z" using dvd_trans by auto
   lemma ddvd_transp: "transp (ddvd)" by (intro transpI, fact ddvd_trans)
 end
 
 context comm_semiring_1 begin
 
 definition mset_factors where "mset_factors F p \<equiv>
   F \<noteq> {#} \<and> (\<forall>f. f \<in># F \<longrightarrow> irreducible f) \<and> p = prod_mset F"
 
 lemma mset_factorsI[intro!]:
   assumes "\<And>f. f \<in># F \<Longrightarrow> irreducible f" and "F \<noteq> {#}" and "prod_mset F = p"
   shows "mset_factors F p"
   unfolding mset_factors_def using assms by auto
 
 lemma mset_factorsD:
   assumes "mset_factors F p"
   shows "f \<in># F \<Longrightarrow> irreducible f" and "F \<noteq> {#}" and "prod_mset F = p"
   using assms[unfolded mset_factors_def] by auto
 
 lemma mset_factorsE[elim]:
   assumes "mset_factors F p"
       and "(\<And>f. f \<in># F \<Longrightarrow> irreducible f) \<Longrightarrow> F \<noteq> {#} \<Longrightarrow> prod_mset F = p \<Longrightarrow> thesis"
   shows thesis
   using assms[unfolded mset_factors_def] by auto
 
 lemma mset_factors_imp_not_is_unit:
   assumes "mset_factors F p"
   shows "\<not> p dvd 1"
 proof(cases F)
   case empty with assms show ?thesis by auto
 next
   case (add f F)
   with assms have "\<not> f dvd 1" "p = f * prod_mset F" by (auto intro!: irreducible_not_unit)
   then show ?thesis by auto
 qed
 
 definition primitive_poly where "primitive_poly f \<equiv> \<forall>d. (\<forall>i. d dvd coeff f i) \<longrightarrow> d dvd 1"
 
 end
 
 lemma(in semidom) mset_factors_imp_nonzero:
   assumes "mset_factors F p"
   shows "p \<noteq> 0"
 proof
   assume "p = 0"
   moreover from assms have "prod_mset F = p" by auto
   ultimately obtain f where "f \<in># F" "f = 0" by auto
   with assms show False by auto
 qed
 
 class ufd = idom +
   assumes mset_factors_exist: "\<And>x. x \<noteq> 0 \<Longrightarrow> \<not> x dvd 1 \<Longrightarrow> \<exists>F. mset_factors F x"
     and mset_factors_unique: "\<And>x F G. mset_factors F x \<Longrightarrow> mset_factors G x \<Longrightarrow> rel_mset (ddvd) F G"
 
 subsubsection \<open>Connecting to HOL/Divisibility\<close>
 
 context comm_semiring_1 begin
 
   abbreviation "mk_monoid \<equiv> \<lparr>carrier = UNIV - {0}, mult = (*), one = 1\<rparr>"
 
   lemma carrier_0[simp]: "x \<in> carrier mk_monoid \<longleftrightarrow> x \<noteq> 0" by auto
 
   lemmas mk_monoid_simps = carrier_0 monoid.simps
 
   abbreviation irred where "irred \<equiv> Divisibility.irreducible mk_monoid"
   abbreviation factor where "factor \<equiv> Divisibility.factor mk_monoid"
   abbreviation factors where "factors \<equiv> Divisibility.factors mk_monoid"
   abbreviation properfactor where "properfactor \<equiv> Divisibility.properfactor mk_monoid"
 
   lemma factors: "factors fs y \<longleftrightarrow> prod_list fs = y \<and> Ball (set fs) irred"
   proof -
     have "prod_list fs = foldr (*) fs 1" by (induct fs, auto)
     thus ?thesis unfolding factors_def by auto
   qed
 
   lemma factor: "factor x y \<longleftrightarrow> (\<exists>z. z \<noteq> 0 \<and> x * z = y)" unfolding factor_def by auto
 
   lemma properfactor_nz:
     shows "(y :: 'a) \<noteq> 0 \<Longrightarrow> properfactor x y \<longleftrightarrow> x dvd y \<and> \<not> y dvd x"
     by (auto simp: properfactor_def factor_def dvd_def)
 
   lemma mem_Units[simp]: "y \<in> Units mk_monoid \<longleftrightarrow> y dvd 1"
     unfolding dvd_def Units_def by (auto simp: ac_simps)
 
 end
 
 context idom begin
   lemma irred_0[simp]: "irred (0::'a)" by (unfold Divisibility.irreducible_def, auto simp: factor properfactor_def)
   lemma factor_idom[simp]: "factor (x::'a) y \<longleftrightarrow> (if y = 0 then x = 0 else x dvd y)"
     by (cases "y = 0"; auto intro: exI[of _ 1] elim: dvdE simp: factor)
 
   lemma associated_connect[simp]: "(\<sim>\<^bsub>mk_monoid\<^esub>) = (ddvd)" by (intro ext, unfold associated_def, auto)
 
   lemma essentially_equal_connect[simp]:
     "essentially_equal mk_monoid fs gs \<longleftrightarrow> rel_mset (ddvd) (mset fs) (mset gs)"
-    by (auto simp: essentially_equal_def rel_mset_via_perm)
+    by (auto simp: essentially_equal_def rel_mset_via_perm perm_iff_eq_mset)
+    
 
   lemma irred_idom_nz:
     assumes x0: "(x::'a) \<noteq> 0"
     shows "irred x \<longleftrightarrow> irreducible x"
     using x0 by (auto simp: irreducible_altdef Divisibility.irreducible_def properfactor_nz)
 
 
   lemma dvd_dvd_imp_unit_mult:
     assumes xy: "x dvd y" and yx: "y dvd x"
     shows "\<exists>z. z dvd 1 \<and> y = x * z"
   proof(cases "x = 0")
     case True with xy show ?thesis by (auto intro: exI[of _ 1])
   next
     case x0: False
     from xy obtain z where z: "y = x * z" by (elim dvdE, auto)
     from yx obtain w where w: "x = y * w" by (elim dvdE, auto)
     from z w have "x * (z * w) = x" by (auto simp: ac_simps)
     then have "z * w = 1" using x0 by auto
     with z show ?thesis by (auto intro: exI[of _ z])
   qed
 
   lemma irred_inner_nz:
     assumes x0: "x \<noteq> 0"
     shows "(\<forall>b. b dvd x \<longrightarrow> \<not> x dvd b \<longrightarrow> b dvd 1) \<longleftrightarrow> (\<forall>a b. x = a * b \<longrightarrow> a dvd 1 \<or> b dvd 1)" (is "?l \<longleftrightarrow> ?r")
   proof (intro iffI allI impI)
     assume l: ?l
     fix a b
     assume xab: "x = a * b"
     then have ax: "a dvd x" and bx: "b dvd x" by auto
     { assume a1: "\<not> a dvd 1"
       with l ax have xa: "x dvd a" by auto
       from dvd_dvd_imp_unit_mult[OF ax xa] obtain z where z1: "z dvd 1" and xaz: "x = a * z" by auto
       from xab x0 have "a \<noteq> 0" by auto
       with xab xaz have "b = z" by auto
       with z1 have "b dvd 1" by auto
     }
     then show "a dvd 1 \<or> b dvd 1" by auto
   next
     assume r: ?r
     fix b assume bx: "b dvd x" and xb: "\<not> x dvd b"
     then obtain a where xab: "x = a * b" by (elim dvdE, auto simp: ac_simps)
     with r consider "a dvd 1" | "b dvd 1" by auto
     then show "b dvd 1"
     proof(cases)
       case 2 then show ?thesis by auto
     next
       case 1
       then obtain c where ac1: "a * c = 1" by (elim dvdE, auto)
       from xab have "x * c = b * (a * c)" by (auto simp: ac_simps)
       with ac1 have "x * c = b" by auto
       then have "x dvd b" by auto
       with xb show ?thesis by auto
     qed
   qed
 
   lemma irred_idom[simp]: "irred x \<longleftrightarrow> x = 0 \<or> irreducible x"
   by (cases "x = 0"; simp add: irred_idom_nz irred_inner_nz irreducible_def)
 
   lemma assumes "x \<noteq> 0" and "factors fs x" and "f \<in> set fs" shows "f \<noteq> 0"
     using assms by (auto simp: factors)
 
   lemma factors_as_mset_factors:
     assumes x0: "x \<noteq> 0" and x1: "x \<noteq> 1"
     shows "factors fs x \<longleftrightarrow> mset_factors (mset fs) x" using assms
     by (auto simp: factors prod_mset_prod_list)
 
 
 end
 
 context ufd begin
   interpretation comm_monoid_cancel: comm_monoid_cancel "mk_monoid::'a monoid"
     apply (unfold_locales)
     apply simp_all
     using mult_left_cancel
     apply (auto simp: ac_simps)
     done
   lemma factors_exist:
     assumes "a \<noteq> 0"
     and "\<not> a dvd 1"
     shows "\<exists>fs. set fs \<subseteq> UNIV - {0} \<and> factors fs a"
   proof-
     from mset_factors_exist[OF assms]
     obtain F where "mset_factors F a" by auto
     also from ex_mset obtain fs where "F = mset fs" by metis
     finally have fs: "mset_factors (mset fs) a".
     then have "factors fs a" using assms by (subst factors_as_mset_factors, auto)
     moreover have "set fs \<subseteq> UNIV - {0}" using fs by (auto elim!: mset_factorsE)
     ultimately show ?thesis by auto
   qed
 
   lemma factors_unique:
     assumes fs: "factors fs a"
        and gs: "factors gs a"
        and a0: "a \<noteq> 0"
        and a1: "\<not> a dvd 1"
     shows "rel_mset (ddvd) (mset fs) (mset gs)"
   proof-
     from a1 have "a \<noteq> 1" by auto
     with a0 fs gs have "mset_factors (mset fs) a" "mset_factors (mset gs) a" by (unfold factors_as_mset_factors)
     from mset_factors_unique[OF this] show ?thesis.
   qed
 
   lemma factorial_monoid: "factorial_monoid (mk_monoid :: 'a monoid)"
     by (unfold_locales; auto simp add: factors_exist factors_unique)
 
 end
 
 lemma (in idom) factorial_monoid_imp_ufd:
   assumes "factorial_monoid (mk_monoid :: 'a monoid)"
   shows "class.ufd ((*) :: 'a \<Rightarrow> _) 1 (+) 0 (-) uminus"
 proof (unfold_locales)
   interpret factorial_monoid "mk_monoid :: 'a monoid" by (fact assms)
   {
     fix x assume x: "x \<noteq> 0" "\<not> x dvd 1"
     note * = factors_exist[simplified, OF this]
     with x show "\<exists>F. mset_factors F x" by (subst(asm) factors_as_mset_factors, auto)
   }
   fix x F G assume FG: "mset_factors F x" "mset_factors G x"
   with mset_factors_imp_not_is_unit have x1: "\<not> x dvd 1" by auto
   from FG(1) have x0: "x \<noteq> 0" by (rule mset_factors_imp_nonzero)
   obtain fs gs where fsgs: "F = mset fs" "G = mset gs" using ex_mset by metis
   note FG = FG[unfolded this]
   then have 0: "0 \<notin> set fs" "0 \<notin> set gs" by (auto elim!: mset_factorsE)
   from x1 have "x \<noteq> 1" by auto
   note FG[folded factors_as_mset_factors[OF x0 this]]
   from factors_unique[OF this, simplified, OF x0 x1, folded fsgs] 0
   show "rel_mset (ddvd) F G" by auto
 qed
 
 
 
 
 subsection \<open>Preservation of Irreducibility\<close>
 
 
 locale comm_semiring_1_hom = comm_monoid_mult_hom hom + zero_hom hom
   for hom :: "'a :: comm_semiring_1 \<Rightarrow> 'b :: comm_semiring_1"
 
 locale irreducibility_hom = comm_semiring_1_hom +
   assumes irreducible_imp_irreducible_hom: "irreducible a \<Longrightarrow> irreducible (hom a)"
 begin
   lemma hom_mset_factors:
     assumes F: "mset_factors F p"
     shows "mset_factors (image_mset hom F) (hom p)"
   proof (unfold mset_factors_def, intro conjI allI impI)
     from F show "hom p = prod_mset (image_mset hom F)" "image_mset hom F \<noteq> {#}" by (auto simp: hom_distribs)
     fix f' assume "f' \<in># image_mset hom F"
     then obtain f where f: "f \<in># F" and f'f: "f' = hom f" by auto
     with F irreducible_imp_irreducible_hom show "irreducible f'" unfolding f'f by auto
   qed
 end
 
 locale unit_preserving_hom = comm_semiring_1_hom +
   assumes is_unit_hom_if: "\<And>x. hom x dvd 1 \<Longrightarrow> x dvd 1"
 begin
   lemma is_unit_hom_iff[simp]: "hom x dvd 1 \<longleftrightarrow> x dvd 1" using is_unit_hom_if hom_dvd by force
 
   lemma irreducible_hom_imp_irreducible:
     assumes irr: "irreducible (hom a)" shows "irreducible a"
   proof (intro irreducibleI)
     from irr show "a \<noteq> 0" by auto
     from irr show "\<not> a dvd 1" by (auto dest: irreducible_not_unit)
     fix b c assume "a = b * c"
     then have "hom a = hom b * hom c" by (simp add: hom_distribs)
     with irr have "hom b dvd 1 \<or> hom c dvd 1" by (auto dest: irreducibleD)
     then show "b dvd 1 \<or> c dvd 1" by simp
   qed
 end
 
 locale factor_preserving_hom = unit_preserving_hom + irreducibility_hom
 begin
   lemma irreducible_hom[simp]: "irreducible (hom a) \<longleftrightarrow> irreducible a"
     using irreducible_hom_imp_irreducible irreducible_imp_irreducible_hom by metis
 end
 
 lemma factor_preserving_hom_comp:
   assumes f: "factor_preserving_hom f" and g: "factor_preserving_hom g"
   shows "factor_preserving_hom (f o g)"
 proof-
   interpret f: factor_preserving_hom f by (rule f)
   interpret g: factor_preserving_hom g by (rule g)
   show ?thesis by (unfold_locales, auto simp: hom_distribs)
 qed
 
 context comm_semiring_isom begin
   sublocale unit_preserving_hom by (unfold_locales, auto)
   sublocale factor_preserving_hom
   proof (standard)
     fix a :: 'a
     assume "irreducible a"
     note a = this[unfolded irreducible_def]
     show "irreducible (hom a)"
     proof (rule ccontr)
       assume "\<not> irreducible (hom a)"
       from this[unfolded Factorial_Ring.irreducible_def,simplified] a
       obtain hb hc where eq: "hom a = hb * hc" and nu: "\<not> hb dvd 1" "\<not> hc dvd 1" by auto
       from bij obtain b where hb: "hb = hom b" by (elim bij_pointE)
       from bij obtain c where hc: "hc = hom c" by (elim bij_pointE)
       from eq[unfolded hb hc, folded hom_mult] have "a = b * c" by auto
       with nu hb hc have "a = b * c" "\<not> b dvd 1" "\<not> c dvd 1" by auto
       with a show False by auto
     qed
   qed
 end
 
 
 subsubsection\<open>Back to divisibility\<close>
 
 lemma(in comm_semiring_1) mset_factors_mult:
   assumes F: "mset_factors F a"
       and G: "mset_factors G b"
   shows "mset_factors (F+G) (a*b)"
 proof(intro mset_factorsI)
   fix f assume "f \<in># F + G"
   then consider "f \<in># F" | "f \<in># G" by auto
   then show "irreducible f" by(cases, insert F G, auto)
 qed (insert F G, auto)
 
 lemma(in ufd) dvd_imp_subset_factors:
   assumes ab: "a dvd b"
       and F: "mset_factors F a"
       and G: "mset_factors G b"
   shows "\<exists>G'. G' \<subseteq># G \<and> rel_mset (ddvd) F G'"
 proof-
   from F G have a0: "a \<noteq> 0" and b0: "b \<noteq> 0" by (simp_all add: mset_factors_imp_nonzero)
   from ab obtain c where c: "b = a * c" by (elim dvdE, auto)
   with b0 have c0: "c \<noteq> 0" by auto
   show ?thesis
   proof(cases "c dvd 1")
     case True
     show ?thesis
       proof(cases F)
         case empty with F show ?thesis by auto
       next
         case (add f F')
           with F
           have a: "f * prod_mset F' = a"
            and F': "\<And>f. f \<in># F' \<Longrightarrow> irreducible f"
            and irrf: "irreducible f" by auto
           from irrf have f0: "f \<noteq> 0" and f1: "\<not>f dvd 1" by (auto dest: irreducible_not_unit)
           from a c have "(f * c) * prod_mset F' = b" by (auto simp: ac_simps)
           moreover {
             have "irreducible (f * c)" using True irrf by (subst irreducible_mult_unit_right)
             with F' irrf have "\<And>f'. f' \<in># F' + {#f * c#} \<Longrightarrow> irreducible f'" by auto
           }
           ultimately have "mset_factors (F' + {#f * c#}) b" by (intro mset_factorsI, auto)
           from mset_factors_unique[OF this G]
           have F'G: "rel_mset (ddvd) (F' + {#f * c#}) G".
           from True add have FF': "rel_mset (ddvd) F (F' + {#f * c#})"
             by (auto simp add: multiset.rel_refl intro!: rel_mset_Plus)
           have "rel_mset (ddvd) F G"
             apply(rule transpD[OF multiset.rel_transp[OF transpI] FF' F'G])
             using ddvd_trans.
           then show ?thesis by auto
       qed
   next
     case False
       from mset_factors_exist[OF c0 this] obtain H where H: "mset_factors H c" by auto
       from c mset_factors_mult[OF F H] have "mset_factors (F + H) b" by auto
       note mset_factors_unique[OF this G]
       from rel_mset_split[OF this] obtain G1 G2
         where "G = G1 + G2" "rel_mset (ddvd) F G1" "rel_mset (ddvd) H G2" by auto
       then show ?thesis by (intro exI[of _ "G1"], auto)
   qed
 qed
 
 lemma(in idom) irreducible_factor_singleton:
   assumes a: "irreducible a"
   shows "mset_factors F a \<longleftrightarrow> F = {#a#}"
 proof(cases F)
   case empty with mset_factorsD show ?thesis by auto
 next
   case (add f F')
   show ?thesis
   proof
     assume F: "mset_factors F a"
     from add mset_factorsD[OF F] have *: "a = f * prod_mset F'" by auto
     then have fa: "f dvd a" by auto
     from * a have f0: "f \<noteq> 0" by auto
     from add have "f \<in># F" by auto
     with F have f: "irreducible f" by auto
     from add have "F' \<subseteq># F" by auto
     then have unitemp: "prod_mset F' dvd 1 \<Longrightarrow> F' = {#}"
     proof(induct F')
       case empty then show ?case by auto
     next
       case (add f F')
         from add have "f \<in># F" by (simp add: mset_subset_eq_insertD)
         with F irreducible_not_unit have "\<not> f dvd 1" by auto
         then have "\<not> (prod_mset F' * f) dvd 1" by simp
         with add show ?case by auto
     qed
     show "F = {#a#}"
     proof(cases "a dvd f")
       case True
         then obtain r where "f = a * r" by (elim dvdE, auto)
         with * have "f = (r * prod_mset F') * f" by (auto simp: ac_simps)
         with f0 have "r * prod_mset F' = 1" by auto
         then have "prod_mset F' dvd 1" by (metis dvd_triv_right)
         with unitemp * add show ?thesis by auto
     next
       case False with fa a f show ?thesis by (auto simp: irreducible_altdef)
     qed
   qed (insert a, auto)
 qed
 
 
 lemma(in ufd) irreducible_dvd_imp_factor:
   assumes ab: "a dvd b"
       and a: "irreducible a"
       and G: "mset_factors G b"
   shows "\<exists>g \<in># G. a ddvd g"
 proof-
   from a have "mset_factors {#a#} a" by auto
   from dvd_imp_subset_factors[OF ab this G]
   obtain G' where G'G: "G' \<subseteq># G" and rel: "rel_mset (ddvd) {#a#} G'" by auto
   with rel_mset_size size_1_singleton_mset size_single
   obtain g where gG': "G' = {#g#}" by fastforce
   from rel[unfolded this rel_mset_def]
   have "a ddvd g" by auto
   with gG' G'G show ?thesis by auto
 qed
 
 lemma(in idom) prod_mset_remove_units:
   "prod_mset F ddvd prod_mset {# f \<in># F. \<not>f dvd 1 #}"
 proof(induct F)
   case (add f F) then show ?case by (cases "f = 0", auto)
 qed auto
 
 lemma(in comm_semiring_1) mset_factors_imp_dvd:
   assumes "mset_factors F x" and "f \<in># F" shows "f dvd x"
   using assms by (simp add: dvd_prod_mset mset_factors_def)
 
 lemma(in ufd) prime_elem_iff_irreducible[iff]:
   "prime_elem x \<longleftrightarrow> irreducible x"
 proof (intro iffI, fact prime_elem_imp_irreducible, rule prime_elemI)
   assume r: "irreducible x"
   then show x0: "x \<noteq> 0" and x1: "\<not> x dvd 1" by (auto dest: irreducible_not_unit)
   from irreducible_factor_singleton[OF r]
   have *: "mset_factors {#x#} x" by auto
   fix a b
   assume "x dvd a * b"
   then obtain c where abxc: "a * b = x * c" by (elim dvdE, auto)
   show "x dvd a \<or> x dvd b"
   proof(cases "c = 0 \<or> a = 0 \<or> b = 0")
     case True with abxc show ?thesis by auto
   next
     case False
     then have a0: "a \<noteq> 0" and b0: "b \<noteq> 0" and c0: "c \<noteq> 0" by auto
     from x0 c0 have xc0: "x * c \<noteq> 0" by auto
     from x1 have xc1: "\<not> x * c dvd 1" by auto
     show ?thesis
     proof (cases "a dvd 1 \<or> b dvd 1")
       case False
       then have a1: "\<not> a dvd 1" and b1: "\<not> b dvd 1" by auto
       from mset_factors_exist[OF a0 a1]
       obtain F where Fa: "mset_factors F a" by auto
       then have F0: "F \<noteq> {#}" by auto
       from mset_factors_exist[OF b0 b1]
       obtain G where Gb: "mset_factors G b" by auto
       then have G0: "G \<noteq> {#}" by auto
       from mset_factors_mult[OF Fa Gb]
       have FGxc: "mset_factors (F + G) (x * c)" by (simp add: abxc)
       show ?thesis
       proof (cases "c dvd 1")
         case True
         from r irreducible_mult_unit_right[OF this] have "irreducible (x*c)" by simp
         note irreducible_factor_singleton[OF this] FGxc
         with F0 G0 have False by (cases F; cases G; auto)
         then show ?thesis by auto
       next
         case False
         from mset_factors_exist[OF c0 this] obtain H where "mset_factors H c" by auto
         with * have xHxc: "mset_factors (add_mset x H) (x * c)" by force
         note rel = mset_factors_unique[OF this FGxc]
         obtain hs where "mset hs = H" using ex_mset by auto
         then have "mset (x#hs) = add_mset x H" by auto
         from rel_mset_free[OF rel this]
         obtain jjs where jjsGH: "mset jjs = F + G" and rel: "list_all2 (ddvd) (x # hs) jjs" by auto
         then obtain j js where jjs: "jjs = j # js" by (cases jjs, auto)
         with rel have xj: "x ddvd j" by auto
         from jjs jjsGH have j: "j \<in> set_mset (F + G)" by (intro union_single_eq_member, auto)
         from j consider "j \<in># F" | "j \<in># G" by auto
         then show ?thesis
         proof(cases)
           case 1
           with Fa have "j dvd a" by (auto intro: mset_factors_imp_dvd)
           with xj dvd_trans have "x dvd a" by auto
           then show ?thesis by auto
         next
           case 2
           with Gb have "j dvd b" by (auto intro: mset_factors_imp_dvd)
           with xj dvd_trans have "x dvd b" by auto
           then show ?thesis by auto
         qed
       qed
     next
       case True
       then consider "a dvd 1" | "b dvd 1" by auto
       then show ?thesis
       proof(cases)
         case 1
         then obtain d where ad: "a * d = 1" by (elim dvdE, auto)
         from abxc have "x * (c * d) = a * b * d" by (auto simp: ac_simps)
         also have "... = a * d * b" by (auto simp: ac_simps)
         finally have "x dvd b" by (intro dvdI, auto simp: ad)
         then show ?thesis by auto
       next
         case 2
         then obtain d where bd: "b * d = 1" by (elim dvdE, auto)
         from abxc have "x * (c * d) = a * b * d" by (auto simp: ac_simps)
         also have "... = (b * d) * a" by (auto simp: ac_simps)
         finally have "x dvd a" by (intro dvdI, auto simp:bd)
         then show ?thesis by auto
       qed
     qed
   qed
 qed
 
 subsection\<open>Results for GCDs etc.\<close>
 
 lemma prod_list_remove1: "(x :: 'b :: comm_monoid_mult) \<in> set xs \<Longrightarrow> prod_list (remove1 x xs) * x = prod_list xs"
   by (induct xs, auto simp: ac_simps)
 
 (* Isabelle 2015-style and generalized gcd-class without normalization and factors *)
 class comm_monoid_gcd = gcd + comm_semiring_1 +
   assumes gcd_dvd1[iff]: "gcd a b dvd a"
       and gcd_dvd2[iff]: "gcd a b dvd b"
       and gcd_greatest: "c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> c dvd gcd a b"
 begin
 
   lemma gcd_0_0[simp]: "gcd 0 0 = 0"
     using gcd_greatest[OF dvd_0_right dvd_0_right, of 0] by auto
 
   lemma gcd_zero_iff[simp]: "gcd a b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
   proof
     assume "gcd a b = 0"
     from gcd_dvd1[of a b, unfolded this] gcd_dvd2[of a b, unfolded this]
     show "a = 0 \<and> b = 0" by auto
   qed auto
 
   lemma gcd_zero_iff'[simp]: "0 = gcd a b \<longleftrightarrow> a = 0 \<and> b = 0"
     using gcd_zero_iff by metis
 
   lemma dvd_gcd_0_iff[simp]:
     shows "x dvd gcd 0 a \<longleftrightarrow> x dvd a" (is ?g1)
       and "x dvd gcd a 0 \<longleftrightarrow> x dvd a" (is ?g2)
   proof-
     have "a dvd gcd a 0" "a dvd gcd 0 a" by (auto intro: gcd_greatest)
     with dvd_refl show ?g1 ?g2 by (auto dest: dvd_trans)
   qed
 
   lemma gcd_dvd_1[simp]: "gcd a b dvd 1 \<longleftrightarrow> coprime a b"
     using dvd_trans[OF gcd_greatest[of _ a b], of _ 1]
     by (cases "a = 0 \<and> b = 0") (auto intro!: coprimeI elim: coprimeE)
 
   lemma dvd_imp_gcd_dvd_gcd: "b dvd c \<Longrightarrow> gcd a b dvd gcd a c"
     by (meson gcd_dvd1 gcd_dvd2 gcd_greatest dvd_trans)
 
   definition listgcd :: "'a list \<Rightarrow> 'a" where
     "listgcd xs = foldr gcd xs 0"
 
   lemma listgcd_simps[simp]: "listgcd [] = 0" "listgcd (x # xs) = gcd x (listgcd xs)"
     by (auto simp: listgcd_def)
 
   lemma listgcd: "x \<in> set xs \<Longrightarrow> listgcd xs dvd x" 
   proof (induct xs)
     case (Cons y ys)
     show ?case
     proof (cases "x = y")
       case False
       with Cons have dvd: "listgcd ys dvd x" by auto
       thus ?thesis unfolding listgcd_simps using dvd_trans by blast
     next
       case True
       thus ?thesis unfolding listgcd_simps using dvd_trans by blast
     qed
   qed simp
 
   lemma listgcd_greatest: "(\<And> x. x \<in> set xs \<Longrightarrow> y dvd x) \<Longrightarrow> y dvd listgcd xs"
     by (induct xs arbitrary:y, auto intro: gcd_greatest)
 
 end
 
 
 context Rings.dvd begin
 
   definition "is_gcd x a b \<equiv> x dvd a \<and> x dvd b \<and> (\<forall>y. y dvd a \<longrightarrow> y dvd b \<longrightarrow> y dvd x)"
 
   definition "some_gcd a b \<equiv> SOME x. is_gcd x a b"
 
   lemma is_gcdI[intro!]:
     assumes "x dvd a" "x dvd b" "\<And>y. y dvd a \<Longrightarrow> y dvd b \<Longrightarrow> y dvd x"
     shows "is_gcd x a b" by (insert assms, auto simp: is_gcd_def)
 
   lemma is_gcdE[elim!]:
     assumes "is_gcd x a b"
         and "x dvd a \<Longrightarrow> x dvd b \<Longrightarrow> (\<And>y. y dvd a \<Longrightarrow> y dvd b \<Longrightarrow> y dvd x) \<Longrightarrow> thesis"
     shows thesis by (insert assms, auto simp: is_gcd_def)
 
   lemma is_gcd_some_gcdI:
     assumes "\<exists>x. is_gcd x a b" shows "is_gcd (some_gcd a b) a b"
     by (unfold some_gcd_def, rule someI_ex[OF assms])
 
 end
 
 context comm_semiring_1 begin
 
   lemma some_gcd_0[intro!]: "is_gcd (some_gcd a 0) a 0" "is_gcd (some_gcd 0 b) 0 b"
     by (auto intro!: is_gcd_some_gcdI intro: exI[of _ a] exI[of _ b])
 
   lemma some_gcd_0_dvd[intro!]:
     "some_gcd a 0 dvd a" "some_gcd 0 b dvd b" using some_gcd_0 by auto
 
   lemma dvd_some_gcd_0[intro!]:
     "a dvd some_gcd a 0" "b dvd some_gcd 0 b" using some_gcd_0[of a] some_gcd_0[of b] by auto
 
 end
 
 context idom begin
 
   lemma is_gcd_connect:
     assumes "a \<noteq> 0" "b \<noteq> 0" shows "isgcd mk_monoid x a b \<longleftrightarrow> is_gcd x a b"
     using assms by (force simp: isgcd_def)
 
   lemma some_gcd_connect:
     assumes "a \<noteq> 0" and "b \<noteq> 0" shows "somegcd mk_monoid a b = some_gcd a b"
     using assms by (auto intro!: arg_cong[of _ _ Eps] simp: is_gcd_connect some_gcd_def somegcd_def)
 end
 
 context comm_monoid_gcd
 begin
   lemma is_gcd_gcd: "is_gcd (gcd a b) a b" using gcd_greatest by auto
   lemma is_gcd_some_gcd: "is_gcd (some_gcd a b) a b" by (insert is_gcd_gcd, auto intro!: is_gcd_some_gcdI)
   lemma gcd_dvd_some_gcd: "gcd a b dvd some_gcd a b" using is_gcd_some_gcd by auto
   lemma some_gcd_dvd_gcd: "some_gcd a b dvd gcd a b" using is_gcd_some_gcd by (auto intro: gcd_greatest)
   lemma some_gcd_ddvd_gcd: "some_gcd a b ddvd gcd a b" by (auto intro: gcd_dvd_some_gcd some_gcd_dvd_gcd)
   lemma some_gcd_dvd: "some_gcd a b dvd d \<longleftrightarrow> gcd a b dvd d" "d dvd some_gcd a b \<longleftrightarrow> d dvd gcd a b"
     using some_gcd_ddvd_gcd[of a b] by (auto dest:dvd_trans)
 
 end
 
 class idom_gcd = comm_monoid_gcd + idom
 begin
 
   interpretation raw: comm_monoid_cancel "mk_monoid :: 'a monoid"
     by (unfold_locales, auto intro: mult_commute mult_assoc)
 
   interpretation raw: gcd_condition_monoid "mk_monoid :: 'a monoid"
     by (unfold_locales, auto simp: is_gcd_connect intro!: exI[of _ "gcd _ _"] dest: gcd_greatest)
 
   lemma gcd_mult_ddvd:
     "d * gcd a b ddvd gcd (d * a) (d * b)"
   proof (cases "d = 0")
     case True then show ?thesis by auto
   next
     case d0: False
     show ?thesis
     proof (cases "a = 0 \<or> b = 0")
       case False
       note some_gcd_ddvd_gcd[of a b]
       with d0 have "d * gcd a b ddvd d * some_gcd a b" by auto
       also have "d * some_gcd a b ddvd some_gcd (d * a) (d * b)"
         using False d0 raw.gcd_mult by (simp add: some_gcd_connect)
       also note some_gcd_ddvd_gcd
       finally show ?thesis.
     next
       case True
       with d0 show ?thesis
         apply (elim disjE)
          apply (rule ddvd_trans[of _ "d * b"]; force)
          apply (rule ddvd_trans[of _ "d * a"]; force)
         done
     qed
   qed
 
   lemma gcd_greatest_mult: assumes cad: "c dvd a * d" and cbd: "c dvd b * d"
     shows "c dvd gcd a b * d"
   proof-
     from gcd_greatest[OF assms] have c: "c dvd gcd (d * a) (d * b)" by (auto simp: ac_simps)
     note gcd_mult_ddvd[of d a b]
     then have "gcd (d * a) (d * b) dvd gcd a b * d" by (auto simp: ac_simps)
     from dvd_trans[OF c this] show ?thesis .
   qed
 
   lemma listgcd_greatest_mult: "(\<And> x :: 'a. x \<in> set xs \<Longrightarrow> y dvd x * z) \<Longrightarrow> y dvd listgcd xs * z"
   proof (induct xs)
     case (Cons x xs)
     from Cons have "y dvd x * z" "y dvd listgcd xs * z" by auto
     thus ?case unfolding listgcd_simps by (rule gcd_greatest_mult)
   qed (simp)
 
   lemma dvd_factor_mult_gcd:
     assumes dvd: "k dvd p * q" "k dvd p * r"
       and q0: "q \<noteq> 0" and r0: "r \<noteq> 0"
     shows "k dvd p * gcd q r" 
   proof -
     from dvd gcd_greatest[of k "p * q" "p * r"]
     have "k dvd gcd (p * q) (p * r)" by simp
     also from gcd_mult_ddvd[of p q r]
     have "... dvd (p * gcd q r)" by auto
     finally show ?thesis .
   qed
 
   lemma coprime_mult_cross_dvd:
     assumes coprime: "coprime p q" and eq: "p' * p = q' * q"
     shows "p dvd q'" (is ?g1) and "q dvd p'" (is ?g2)
   proof (atomize(full), cases "p = 0 \<or> q = 0")
     case True
     then show "?g1 \<and> ?g2"
     proof
       assume p0: "p = 0" with coprime have "q dvd 1" by auto
       with eq p0 show ?thesis by auto
     next
       assume q0: "q = 0" with coprime have "p dvd 1" by auto
       with eq q0 show ?thesis by auto
     qed
   next
     case False
     {
       fix p q r p' q' :: 'a
       assume cop: "coprime p q" and eq: "p' * p = q' * q" and p: "p \<noteq> 0" and q: "q \<noteq> 0"
          and r: "r dvd p" "r dvd q"
       let ?gcd = "gcd q p"
       from eq have "p' * p dvd q' * q" by auto
       hence d1: "p dvd q' * q" by (rule dvd_mult_right)
       have d2: "p dvd q' * p" by auto
       from dvd_factor_mult_gcd[OF d1 d2 q p] have 1: "p dvd q' * ?gcd" .
       from q p have 2: "?gcd dvd q" by auto
       from q p have 3: "?gcd dvd p" by auto
       from cop[unfolded coprime_def', rule_format, OF 3 2] have "?gcd dvd 1" .
       from 1 dvd_mult_unit_iff[OF this] have "p dvd q'" by auto
     } note main = this
     from main[OF coprime eq,of 1] False coprime coprime_commute main[OF _ eq[symmetric], of 1]
     show "?g1 \<and> ?g2" by auto
   qed
 
 end
 
 subclass (in ring_gcd) idom_gcd by (unfold_locales, auto)
 
 lemma coprime_rewrites: "comm_monoid_mult.coprime ((*)) 1 = coprime"
   apply (intro ext)
   apply (subst comm_monoid_mult.coprime_def')
   apply (unfold_locales)
   apply (unfold dvd_rewrites)
   apply (fold coprime_def') ..
 
 (* TODO: incorporate into the default class hierarchy *)
 locale gcd_condition =
   fixes ty :: "'a :: idom itself"
   assumes gcd_exists: "\<And>a b :: 'a. \<exists>x. is_gcd x a b"
 begin
   sublocale idom_gcd "(*)" "1 :: 'a" "(+)" 0 "(-)" uminus some_gcd 
     rewrites "dvd.dvd ((*)) = (dvd)"
         and "comm_monoid_mult.coprime ((*) ) 1 = Unique_Factorization.coprime"
   proof-
     have "is_gcd (some_gcd a b) a b" for a b :: 'a by (intro is_gcd_some_gcdI gcd_exists)
     from this[unfolded is_gcd_def]
     show "class.idom_gcd (*) (1 :: 'a) (+) 0 (-) uminus some_gcd" by (unfold_locales, auto simp: dvd_rewrites)
   qed (simp_all add: dvd_rewrites coprime_rewrites)
 end
 
 instance semiring_gcd \<subseteq> comm_monoid_gcd by (intro_classes, auto)
 
 lemma listgcd_connect: "listgcd = gcd_list"
 proof (intro ext)
   fix xs :: "'a list"
   show "listgcd xs = gcd_list xs" by(induct xs, auto)
 qed
 
 interpretation some_gcd: gcd_condition "TYPE('a::ufd)"
 proof(unfold_locales, intro exI)
   interpret factorial_monoid "mk_monoid :: 'a monoid" by (fact factorial_monoid)
   note d = dvd.dvd_def some_gcd_def carrier_0
   fix a b :: 'a
   show "is_gcd (some_gcd a b) a b"
   proof (cases "a = 0 \<or> b = 0")
     case True
     thus ?thesis using some_gcd_0 by auto
   next
     case False
     with gcdof_exists[of a b]
     show ?thesis by (auto intro!: is_gcd_some_gcdI simp add: is_gcd_connect some_gcd_connect)
   qed
 qed
 
 lemma some_gcd_listgcd_dvd_listgcd: "some_gcd.listgcd xs dvd listgcd xs"
   by (induct xs, auto simp:some_gcd_dvd intro:dvd_imp_gcd_dvd_gcd)
 
 lemma listgcd_dvd_some_gcd_listgcd: "listgcd xs dvd some_gcd.listgcd xs"
   by (induct xs, auto simp:some_gcd_dvd intro:dvd_imp_gcd_dvd_gcd)
 
 context factorial_ring_gcd begin
 
 text \<open>Do not declare the following as subclass, to avoid conflict in
   \<open>field \<subseteq> gcd_condition\<close> vs. \<open>factorial_ring_gcd \<subseteq> gcd_condition\<close>.
 \<close>
 sublocale as_ufd: ufd
 proof(unfold_locales, goal_cases)
   case (1 x)
   from prime_factorization_exists[OF \<open>x \<noteq> 0\<close>]
   obtain F where f: "\<And>f. f \<in># F \<Longrightarrow> prime_elem f" 
              and Fx: "normalize (prod_mset F) = normalize x" by auto
   from associatedE2[OF Fx] obtain u where u: "is_unit u" "x = u * prod_mset F"
     by blast
   from \<open>\<not> is_unit x\<close> Fx have "F \<noteq> {#}" by auto
   then obtain g G where F: "F = add_mset g G" by (cases F, auto)
   then have "g \<in># F" by auto
   with f[OF this]prime_elem_iff_irreducible
     irreducible_mult_unit_left[OF unit_factor_is_unit[OF \<open>x \<noteq> 0\<close>]]
   have g: "irreducible (u * g)" using u(1)
     by (subst irreducible_mult_unit_left) simp_all
   show ?case
   proof (intro exI conjI mset_factorsI)
     show "prod_mset (add_mset (u * g) G) = x"
       using \<open>x \<noteq> 0\<close> by (simp add: F ac_simps u)
     fix f assume "f \<in># add_mset (u * g) G"
     with f[unfolded F] g prime_elem_iff_irreducible
     show "irreducible f" by auto
   qed auto
 next
   case (2 x F G)
   note transpD[OF multiset.rel_transp[OF ddvd_transp],trans]
   obtain fs where F: "F = mset fs" by (metis ex_mset)
   have "list_all2 (ddvd) fs (map normalize fs)" by (intro list_all2_all_nthI, auto)
   then have FH: "rel_mset (ddvd) F (image_mset normalize F)" by (unfold rel_mset_def F, force)
   also
   have FG: "image_mset normalize F = image_mset normalize G"
   proof (intro prime_factorization_unique'')
     from 2 have xF: "x = prod_mset F" and xG: "x = prod_mset G" by auto
     from xF have "normalize x = normalize (prod_mset (image_mset normalize F))"
       by (simp add: normalize_prod_mset_normalize)
     with xG have nFG: "\<dots> = normalize (prod_mset (image_mset normalize G))"
       by (simp_all add: normalize_prod_mset_normalize)
     then show "normalize (\<Prod>i\<in>#image_mset normalize F. i) =
                normalize (\<Prod>i\<in>#image_mset normalize G. i)" by auto
   next
     from 2 prime_elem_iff_irreducible have "f \<in># F \<Longrightarrow> prime_elem f" "g \<in># G \<Longrightarrow> prime_elem g" for f g
      by (auto intro: prime_elemI)
     then show " Multiset.Ball (image_mset normalize F) prime"
       "Multiset.Ball (image_mset normalize G) prime" by auto
   qed
   also
     obtain gs where G: "G = mset gs" by (metis ex_mset)
     have "list_all2 ((ddvd)\<inverse>\<inverse>) gs (map normalize gs)" by (intro list_all2_all_nthI, auto)
     then have "rel_mset (ddvd) (image_mset normalize G) G"
       by (subst multiset.rel_flip[symmetric], unfold rel_mset_def G, force)
   finally show ?case.
 qed
 
 end
 
 instance int :: ufd by (intro class.ufd.of_class.intro as_ufd.ufd_axioms)
 instance int :: idom_gcd by (intro_classes, auto)
 
 instance field \<subseteq> ufd by (intro_classes, auto simp: dvd_field_iff)
 
 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,182 @@
 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.List_Permutation"
+  "HOL-Library.Multiset"
 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
+    have "mset (remdups xs) = mset (remdups ys)" using assms(3)
+      using set_eq_iff_mset_remdups_eq by blast 
+    then have "mset xs = mset ys" using assms(1, 2) by (simp add: distinct_remdups_id)
+    have "fold ((XOR) \<circ> hc) xs = fold ((XOR) \<circ> hc) ys"
+      apply (rule fold_multiset_equiv)
+       apply (simp_all add: fun_eq_iff ac_simps)
+      using \<open>mset xs = mset ys\<close> .
+    then show ?thesis unfolding list_hash_def by simp
   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/Chandy_Lamport/Co_Snapshot.thy b/thys/Chandy_Lamport/Co_Snapshot.thy
--- a/thys/Chandy_Lamport/Co_Snapshot.thy
+++ b/thys/Chandy_Lamport/Co_Snapshot.thy
@@ -1,334 +1,334 @@
 theory Co_Snapshot
   imports
     Snapshot
     Ordered_Resolution_Prover.Lazy_List_Chain
 begin
 
 section \<open>Extension to infinite traces\<close>
 
 text \<open>The computation locale assumes that there already exists a known
 final configuration $c'$ to the given initial $c$ and trace $t$. However,
 we can show that the snapshot algorithm must terminate correctly even if
 the underlying computation itself does not terminate. We relax
 the trace relation to allow for a potentially infinite number of ``intermediate'' events, and
 show that the algorithm's correctness still holds when imposing the same constraints
 as in the computation locale.
 
 We use a preexisting theory of lazy list chains by Schlichtkrull, Blanchette,
 Traytel and Waldmann~\cite{Ordered_Resolution_Prover-AFP} to construct infinite traces.\<close>
 
 primrec ltake where
   "ltake 0 t = []"
 | "ltake (Suc i) t = (case t of LNil \<Rightarrow> [] | LCons x t' \<Rightarrow> x # ltake i t')"
 
 primrec ldrop where
   "ldrop 0 t = t"
 | "ldrop (Suc i) t = (case t of LNil \<Rightarrow> LNil | LCons x t' \<Rightarrow> ldrop i t')"
 
 lemma ltake_LNil[simp]: "ltake i LNil = []"
   by (induct i) auto
 
 lemma ltake_LCons: "0 < i \<Longrightarrow> ltake i (LCons x t) = x # ltake (i - 1) t"
   by (induct i) auto
 
 lemma take_ltake: "i \<le> j \<Longrightarrow> take i (ltake j xs) = ltake i xs"
   by (induct j arbitrary: i xs) (auto simp: le_Suc_eq take_Cons' ltake_LCons split: llist.splits if_splits)
 
 lemma nth_ltake [simp]: "i < min n (llength xs) \<Longrightarrow> (ltake n xs) ! i = lnth xs i"
   by (induct n arbitrary: i xs)
     (auto simp: nth_Cons' gr0_conv_Suc eSuc_enat[symmetric] split: llist.splits)
 
 lemma length_ltake[simp]: "length (ltake i xs) = (case llength xs of \<infinity> \<Rightarrow> i | enat m \<Rightarrow> min i m)"
   by (induct i arbitrary: xs)
     (auto simp: zero_enat_def[symmetric] eSuc_enat split: llist.splits enat.splits)
 
 lemma ltake_prepend:
   "ltake i (prepend xs t) = (if i \<le> length xs then take i xs else xs @ ltake (i - length xs) t)"
 proof (induct i arbitrary: xs t)
   case 0
   then show ?case 
     by (cases xs) auto
 next
   case (Suc i)
   then show ?case
     by (cases xs) auto
 qed
 
 lemma prepend_ltake_ldrop_id: "prepend (ltake i t) (ldrop i t) = t"
   by (induct i arbitrary: t) (auto split: llist.splits)
 
 context distributed_system
 begin
 
 coinductive cotrace where
     cotr_init: "cotrace c LNil"
   | cotr_step: "\<lbrakk> c \<turnstile> ev \<mapsto> c'; cotrace c' t \<rbrakk> \<Longrightarrow> cotrace c (LCons ev t)"
 
 lemma cotrace_trace: "cotrace c t \<Longrightarrow> \<exists>!c'. trace c (ltake i t) c'"
 proof (induct i arbitrary: c t)
   case (Suc i)
   then show ?case
   proof (cases t)
     case (LCons ev t')
     with Suc(2) obtain c' where "c \<turnstile> ev \<mapsto> c'" "cotrace c' t'"
       by (auto elim: cotrace.cases)
     with Suc(1)[OF \<open>cotrace c' t'\<close>] show ?thesis
       by (auto simp: LCons elim: trace.intros(2) elim: trace.cases trace_and_start_determines_end)
   qed (auto intro: trace.intros elim: trace.cases)
 qed (auto simp: zero_enat_def[symmetric] intro: trace.intros elim: trace.cases)
 
 lemma cotrace_trace': "cotrace c t \<Longrightarrow> \<exists>c'. trace c (ltake i t) c'"
   by (metis cotrace_trace)
 
 definition cos where "cos c t i = s c (ltake i t) i"
 
 lemma cotrace_trace_cos: "cotrace c t \<Longrightarrow> trace c (ltake i t) (cos c t i)"
   unfolding cos_def s_def
   by (subst take_ltake, auto dest!: cotrace_trace[of _ _ i] elim!: theI')
 
 lemma s_0[simp]: "s c t 0 = c"
   unfolding s_def
   by (auto intro!: the_equality[where P = "trace c []"] trace.intros elim: trace.cases)
 
 lemma s_chop: "i \<le> length t \<Longrightarrow> s c t i = s c (take i t) i"
   unfolding s_def
   by auto
 
 lemma cotrace_prepend: "trace c t c' \<Longrightarrow> cotrace c' u \<Longrightarrow> cotrace c (prepend t u)"
   by (induct c t c' rule: trace.induct) (auto intro: cotrace.intros)
 
 lemma s_Cons: "\<exists>c''. trace c' xs c'' \<Longrightarrow> c \<turnstile> ev \<mapsto> c' \<Longrightarrow> s c (ev # xs) (Suc i) = s c' xs i"
   by (smt exists_trace_for_any_i take_Suc_Cons tr_step trace_and_start_determines_end)
 
 lemma cotrace_ldrop: "cotrace c t \<Longrightarrow> i \<le> llength t \<Longrightarrow> cotrace (cos c t i) (ldrop i t)"
 proof (induct i arbitrary: c t)
   case (Suc i)
   then show ?case
   proof (cases t)
     case (LCons ev t')
     with Suc(2) obtain c' where "c \<turnstile> ev \<mapsto> c'" "cotrace c' t'"
       by (auto elim: cotrace.cases)
     with Suc(1)[OF \<open>cotrace c' t'\<close>] Suc(3) show ?thesis
       by (auto simp: LCons cos_def eSuc_enat[symmetric] s_chop[symmetric] s_Cons[OF cotrace_trace'])
   qed (auto intro: cotrace.intros)
 qed (auto simp: zero_enat_def[symmetric] cos_def intro: cotrace.intros)
 
 end
 
 locale cocomputation = distributed_system +
   fixes
     init :: "('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. \<not> has_snapshotted init p" and
     no_initial_channel_snapshot:
       "\<forall>i. channel_snapshot init i = ([], NotStarted)" and
 
     valid: "\<exists>t. cotrace init t" and
     l1: "\<forall>t i cid. cotrace init t
                  \<and> Marker \<in> set (msgs (cos init t i) cid)
       \<longrightarrow> (\<exists>j \<le> llength t. j \<ge> i \<and> Marker \<notin> set (msgs (cos init t j) cid))" and
     l2: "\<forall>t p. cotrace init t
       \<longrightarrow> (\<exists>i \<le> llength t. has_snapshotted (cos init t i) p)"
 begin
 
 abbreviation coS where "coS \<equiv> cos init"
 
 definition "some_snapshot t p = (SOME i. has_snapshotted (coS t i) p \<and> i \<le> llength t)"
 
 lemma has_snapshotted: 
   "cotrace init t \<Longrightarrow> has_snapshotted (coS t (some_snapshot t p)) p \<and> some_snapshot t p \<le> llength t"
   unfolding some_snapshot_def by (rule someI_ex) (auto dest!: l2[rule_format])
 
 lemma cotrace_cos: "cotrace init t \<Longrightarrow> j < llength t \<Longrightarrow> 
   (coS t j) \<turnstile> lnth t j \<mapsto> (coS t (Suc j))"
   apply (drule cotrace_trace_cos[of _ _ "Suc j"])
   apply (drule step_Suc[rotated, of _ _ _ "j"])
    apply (auto split: enat.splits llist.splits) []
   apply (auto simp: s_chop[of j "_ # ltake j _"] cos_def nth_Cons' ltake_LCons lnth_LCons'
     take_Cons' take_ltake
     split: llist.splits enat.splits if_splits elim: order.strict_trans2[rotated])
   apply (subst (asm) nth_ltake)
    apply (auto elim!: order.strict_trans2[rotated]) []
   apply (subst (asm) s_chop[of j "_ # ltake j _"])
    apply (auto simp: take_Cons' take_ltake split: enat.splits)
   done
 
 lemma snapshot_stable:
   "cotrace init t \<Longrightarrow> i \<le> j \<Longrightarrow> has_snapshotted (coS t i) p \<Longrightarrow> has_snapshotted (coS t j) p"
   apply (drule cotrace_trace_cos[of _ _ j])
   unfolding cos_def
   by (metis exists_trace_for_any_i_j order_refl s_def snapshot_stable take_ltake)
 
 lemma no_markers_if_all_snapshotted:
   "cotrace init t \<Longrightarrow> i \<le> j \<Longrightarrow> \<forall>p. has_snapshotted (coS t i) p \<Longrightarrow>
       Marker \<notin> set (msgs (coS t i) c) \<Longrightarrow> Marker \<notin> set (msgs (coS t j) c)"  
   apply (drule cotrace_trace_cos[of _ _ j])
   unfolding cos_def
   by (metis exists_trace_for_any_i_j no_markers_if_all_snapshotted order_refl s_def take_ltake)
 
 lemma cotrace_all_have_snapshotted:
   assumes "cotrace init t"
   shows "\<exists>i \<le> llength t. \<forall>p. has_snapshotted (coS t i) p"
 proof -
   let ?i = "Max (range (some_snapshot t))"
   show ?thesis
     using has_snapshotted[OF assms] snapshot_stable[OF assms, of "some_snapshot t _" ?i _]
     apply (intro exI[of _ ?i])
     apply (auto simp: finite_processes)
      apply (cases "llength t"; auto simp: )
      apply (subst Max_le_iff)
        apply (auto simp: finite_processes)
     apply blast
     done
 qed
 
 lemma no_messages_if_no_channel:
   assumes "cotrace init t"
   shows "channel cid = None \<Longrightarrow> msgs (coS t i) cid = []"
   using no_messages_introduced_if_no_channel[OF assms[THEN cotrace_trace_cos, of i] no_msgs_if_no_channel, of cid i]
   by (auto simp: cos_def)
 
 lemma cotrace_all_have_snapshotted_and_no_markers:
   assumes "cotrace init t"
   shows "\<exists>i \<le> llength t. (\<forall>p. has_snapshotted (coS t i) p) \<and> 
                          (\<forall>c. Marker \<notin> set (msgs (coS t i) c))"
 proof -
   from cotrace_all_have_snapshotted[OF assms] obtain j :: nat where
     j: "j \<le> llength t" "\<forall>p. has_snapshotted (coS t j) p" by blast
   from j(2) have *: "has_snapshotted (coS t k) p" if "k \<ge> j" for k p
       using snapshot_stable[OF assms, of j k p] that by auto
   define C where "C = {c. Marker \<in> set (msgs (coS t j) c)}"
   have "finite C"
     using no_messages_if_no_channel[OF assms, of _ j] unfolding C_def
     by (intro finite_subset[OF _ finite_channels]) fastforce
   define pick where "pick = (\<lambda>c. SOME k. k \<le> llength t \<and> k \<ge> j \<and> Marker \<notin> set (msgs (coS t k) c))"
   { fix c
     assume "c \<in> C"
     then have "\<exists>k \<le> llength t. k \<ge> j \<and> Marker \<notin> set (msgs (coS t k) c)"
       using l1[rule_format, of t j c] assms unfolding C_def by blast
     then have "pick c \<le> llength t \<and> pick c \<ge> j \<and> Marker \<notin> set (msgs (coS t (pick c)) c)"
       unfolding pick_def
       by (rule someI_ex)
   } note pick = conjunct1[OF this] conjunct1[OF conjunct2[OF this]] conjunct2[OF conjunct2[OF this]]
   show ?thesis
   proof (cases "C = {}")
     case True
     with j show ?thesis
       by (auto intro!: exI[of _ j] simp: C_def)
   next
     define m where "m = Max (pick ` C)"
     case False
     with \<open>finite C\<close> have m: "m \<in> pick ` C" "\<forall>x \<in> pick ` C. m \<ge> x"
       unfolding m_def by auto
     then have "j \<le> m" using pick(2) by auto
     from *[OF \<open>j \<le> m\<close>] have "Marker \<notin> set (msgs (coS t m) c)" for c
     proof (cases "c \<in> C")
       case True
       then show ?thesis
         using no_markers_if_all_snapshotted[OF assms, of "pick c" m c] pick[of c] m *
         by auto
     next
       case False
       then show ?thesis
         using no_markers_if_all_snapshotted[OF assms \<open>j \<le> m\<close> j(2), of c]
         by (auto simp: C_def)
     qed
     with *[OF \<open>j \<le> m\<close>] m pick show ?thesis by auto
   qed
 qed
 
 context
   fixes t
   assumes cotrace: "cotrace init t"
 begin
 
 definition "final_i \<equiv>
   (SOME i. i \<le> llength t \<and> (\<forall>p. has_snapshotted (coS t i) p) \<and> (\<forall>c. Marker \<notin> set (msgs (coS t i) c)))"
 
 definition final where
   "final = coS t final_i"
 
 lemma final_i: "final_i \<le> llength t" "(\<forall>p. has_snapshotted (coS t final_i) p)" "(\<forall>c. Marker \<notin> set (msgs (coS t final_i) c))"
   unfolding final_i_def
   by (rule someI2_ex[OF cotrace_all_have_snapshotted_and_no_markers[OF cotrace]]; auto intro: cotrace_trace_cos[OF cotrace])+
 
 lemma final: "\<exists>t. trace init t final" "(\<forall>p. has_snapshotted final p)" "(\<forall>c. Marker \<notin> set (msgs final c))"
   unfolding final_def
   by (rule cotrace_trace_cos[OF cotrace] final_i exI)+
 
 interpretation computation channel trans send recv init final
   apply standard
             apply (rule finite_channels)
            apply (rule strongly_connected_raw)
           apply (rule at_least_two_processes)
          apply (rule finite_processes)
         apply (rule no_initial_Marker)
        apply (rule no_msgs_if_no_channel)
       apply (rule no_initial_process_snapshot)
      apply (rule no_initial_channel_snapshot)
     apply (rule final(1))
    apply (intro allI impI)
   subgoal for t i cid
     apply (rule exI[of _ "length t"])
     apply (metis exists_trace_for_any_i final(3) le_cases take_all trace_and_start_determines_end)
     done
   apply (intro allI impI)
   subgoal for t p
     apply (rule exI[of _ "length t"])
     apply (metis exists_trace_for_any_i final(2) order_refl take_all trace_and_start_determines_end)
     done
   done
 
 definition coperm where
-  "coperm l r = (\<exists>xs ys z. perm xs ys \<and> l = prepend xs z \<and> r = prepend ys z)"
+  "coperm l r = (\<exists>xs ys z. mset xs = mset ys \<and> l = prepend xs z \<and> r = prepend ys z)"
 
-lemma copermIL: "perm ys xs \<Longrightarrow> t = prepend xs z \<Longrightarrow> coperm (prepend ys z) t"
+lemma copermIL: "mset ys = mset xs \<Longrightarrow> t = prepend xs z \<Longrightarrow> coperm (prepend ys z) t"
   unfolding coperm_def by auto
 
 lemma snapshot_algorithm_is_cocorrect:
   "\<exists>t' i. cotrace init t' \<and> coperm t' t \<and> state_equal_to_snapshot (coS t' i) final \<and> i \<le> final_i"
 proof -
   define prefix where "prefix = ltake final_i t"
   define suffix where "suffix = ldrop final_i t"
   have [simp]: "prepend prefix suffix = t"
     unfolding prefix_def suffix_def prepend_ltake_ldrop_id ..
   have [simp]: "cotrace final suffix"
     unfolding suffix_def final_def
     by (auto simp: cotrace final_i(1) intro!: cotrace_ldrop)
   from cotrace_trace_cos[OF cotrace] have "trace init prefix final"
     unfolding final_def prefix_def by blast
   with snapshot_algorithm_is_correct obtain prefix' i where
-    "trace init prefix' final" "perm prefix' prefix" "state_equal_to_snapshot (S prefix' i) final"
+    "trace init prefix' final" "mset prefix' = mset prefix" "state_equal_to_snapshot (S prefix' i) final"
     "i \<le> length prefix'"
     by blast
-  moreover from \<open>perm prefix' prefix\<close> \<open>i \<le> length prefix'\<close> have "i \<le> final_i"
-    by (auto dest!: perm_length simp: prefix_def split: enat.splits)
+  moreover from \<open>mset prefix' = mset prefix\<close> \<open>i \<le> length prefix'\<close> have "i \<le> final_i"
+    by (auto dest!: mset_eq_length simp: prefix_def split: enat.splits)
   ultimately show ?thesis
     by (intro exI[of _ "prepend prefix' suffix"] exI[of _ i])
       (auto simp: cos_def ltake_prepend s_chop[symmetric] intro!: cotrace_prepend elim!: copermIL)
 qed
 
 end
 
 print_statement snapshot_algorithm_is_cocorrect
 
 end
 
 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,5271 @@
 section \<open>The Chandy--Lamport algorithm\<close>
 
 theory Snapshot
   imports
     "HOL-Library.Sublist"
-    "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
+    "\<exists>t'. mset t' = mset 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 "mset (swap_events i j t) = mset 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
+  ultimately show ?case using Suc.hyps by metis 
 qed
 
 theorem snapshot_algorithm_is_correct:
   assumes
     "trace init t final"
   shows
-    "\<exists>t' i. trace init t' final \<and> perm t' t
+    "\<exists>t' i. trace init t' final \<and> mset t' = mset t
           \<and> state_equal_to_snapshot (S t' i) final \<and> i \<le> length t'"
 proof -
-  obtain t' where "perm t' t" and
+  obtain t' where "mset t' = mset 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> trace init t' final \<and> mset t' = mset 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> trace init t' final \<and> mset t' = mset 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)
+    by auto (metis (mono_tags, lifting) case_prod_conv tfl_some)
   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.List_Permutation"
+    "HOL-Library.Multiset"
 
 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"
+    "mset (swap_events i j t) = mset 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))"
+  have "mset (take i t) = mset (take i t)" by simp
+  moreover have "mset (drop (j+1) t) = mset (drop (j+1) t)" by simp
+  moreover have "mset ([t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t))) = mset (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
+    then show ?thesis by fastforce
   qed
-  ultimately show ?thesis using swap reg 
-    by (metis append.assoc perm_append1 perm_append2)
+  ultimately show ?thesis using swap reg
+    by simp (metis mset_append union_mset_add_mset_left union_mset_add_mset_right)
 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/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.List_Permutation"
+imports "HOL-Library.Permutations"
 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]"
+  shows "mset js = mset [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]"
+  with set_eq show "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 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]"
+  assumes A1: "mset js = mset [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)
+  from A1 have A1': \<open>set js = {..<k + 1}\<close>
+    by (metis atLeast_upt mset_eq_setD)
   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 perm_distinct_iff [where xs="xs @ ys"] by auto
+  from A1 and A3 have "distinct (xs @ ys)"
+    using distinct_upt mset_eq_imp_distinct_iff by blast 
+
   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 perm_set_eq by blast
+      hence "i \<in> set [0..<k + 1]"
+        using A1' by (auto simp add: less_Suc_eq)
       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]"
+  assumes A1: "mset js = mset [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 perm_distinct_iff and List.distinct_upt by blast
+    using A1 distinct_upt mset_eq_imp_distinct_iff 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 perm_set_eq by blast
+    using A1 mset_eq_setD 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
+  from assms and js_is_a_permutation have "mset js = mset[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,73 @@
 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.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/Selection_Heap_Sort/RemoveMax.thy b/thys/Selection_Heap_Sort/RemoveMax.thy
--- a/thys/Selection_Heap_Sort/RemoveMax.thy
+++ b/thys/Selection_Heap_Sort/RemoveMax.thy
@@ -1,270 +1,268 @@
 (*  Title:      Sort.thy
     Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)
 
 section \<open>Defining data structure and \\
           key function remove\_max\<close>
 
 theory RemoveMax
 imports Sort
 begin
 
 subsection \<open>Describing data structure\<close>
 
 text\<open>
 We have already said that we are going to formalize heap and selection
 sort and to show connections between these two sorts.  However, one
 can immediately notice that selection sort is using list and heap sort
 is using heap during its work. It would be very difficult to show
 equivalency between these two sorts if it is continued straightforward
 and independently proved that they satisfy conditions of locale
 \verb|Sort|. They work with different objects. Much better thing to do
 is to stay on the abstract level and to add the new locale, one that
 describes characteristics of both list and heap. 
 \<close>
 
 locale Collection = 
   fixes empty :: "'b"
   \<comment> \<open>-- Represents empty element of the object (for example, for list it is $[]$)\<close>
   fixes is_empty :: "'b \<Rightarrow> bool"
   \<comment> \<open>-- Function that checks weather the object is empty or not\<close>
   fixes of_list :: "'a list \<Rightarrow> 'b"
   \<comment> \<open>-- Function transforms given list to desired object (for example, 
     for heap sort, function {\em of\_list} transforms list to heap)\<close>
   fixes multiset :: "'b \<Rightarrow> 'a multiset" 
   \<comment> \<open>-- Function makes a multiset from the given object. A multiset is a collection without order.\<close>
   assumes is_empty_inj: "is_empty e \<Longrightarrow> e = empty" 
   \<comment> \<open>-- It must be assured that the empty element is {\em empty}\<close>
   assumes is_empty_empty: "is_empty empty"
   \<comment> \<open>-- Must be satisfied that function {\em is\_empty} returns true for element {\em empty}\<close>
   assumes multiset_empty: "multiset empty = {#}"
   \<comment> \<open>-- Multiset of an empty object is empty multiset.\<close>
   assumes multiset_of_list: "multiset (of_list i) = mset i"
   \<comment> \<open>-- Multiset of an object gained by
   applying function {\em of\_list} must be the same as the multiset of
   the list. This, practically, means that function {\em of\_list} does
   not delete or change elements of the starting list.\<close>
 begin
   lemma is_empty_as_list: "is_empty e \<Longrightarrow> multiset e = {#}"
     using is_empty_inj multiset_empty
     by auto
 
   definition set :: "'b \<Rightarrow> 'a set" where
      [simp]: "set l = set_mset (multiset l)"
 end
 
 subsection \<open>Function remove\_max\<close>
 
 text\<open>
 We wanted to emphasize that algorithms are same. Due to
 the complexity of the implementation it usually happens that simple
 properties are omitted, such as the connection between these two
 sorting algorithms. This is a key feature that should be presented to
 students in order to understand these algorithms. It is not unknown
 that students usually prefer selection sort for its simplicity whereas
 avoid heap sort for its complexity. However, if we can present them as
 the algorithms that are same they may hesitate less in using the heap
 sort. This is why the refinement is important. Using this technique we
 were able to notice these characteristics. Separate verification would
 not bring anything new. Being on the abstract level does not only
 simplify the verifications, but also helps us to notice and to show
 students important features. Even further, we can prove them formally
 and completely justify our observation.
 \<close>
 
 locale RemoveMax = Collection empty is_empty of_list  multiset for 
   empty :: "'b" and 
   is_empty :: "'b \<Rightarrow> bool" and 
   of_list :: "'a::linorder list \<Rightarrow> 'b" and 
   multiset :: "'b \<Rightarrow> 'a::linorder multiset" + 
   fixes remove_max :: "'b \<Rightarrow> 'a \<times> 'b"
   \<comment> \<open>--- Function that removes maximum element from the object of type $'b$. 
       It returns maximum element and the object without that maximum element.\<close>
   fixes inv :: "'b \<Rightarrow> bool"
   \<comment> \<open>--- It checks weather the object is in required condition.
       For example, if we expect to work with heap it checks weather the object 
       is heap. This is called {\em invariant condition}\<close>
   assumes of_list_inv: "inv (of_list x)"
   \<comment> \<open>--- This condition assures that function {\em of\_list}
       made a object with desired property.\<close>
   assumes remove_max_max: 
      "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> m = Max (set l)"
   \<comment> \<open>--- First parameter of the return value of the 
       function {\em remove\_max} is the maximum element\<close>
   assumes remove_max_multiset: 
      "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> 
       add_mset m (multiset l') = multiset l"
   \<comment> \<open>--- Condition for multiset, ensures that nothing new is added or nothing 
       is lost after applying {\em remove\_max} function.\<close>
   assumes remove_max_inv: 
      "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> inv l'"
   \<comment> \<open>--- Ensures that invariant condition is true after removing maximum element. 
       Invariant condition must be true in each step of sorting algorithm, for example
       if we are sorting using heap than in each iteration we must have heap and function
       {\em remove\_max} must not change that.\<close>
 begin
 
 lemma remove_max_multiset_size: 
   "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> 
                size (multiset l) > size (multiset l')"
 using remove_max_multiset[of l m l']
 by (metis mset_subset_size multi_psub_of_add_self)
 
 lemma remove_max_set: 
   "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> 
                                  set l' \<union> {m} = set l"
 using remove_max_multiset[of l m l']
 by (metis Un_insert_right local.set_def set_mset_add_mset_insert sup_bot_right)
 
 text\<open>As it is said before
 in each iteration invariant condition must be satisfied, so the {\em
   inv l} is always true, e.g. before and after execution of any
 function. This is also the reason why sort function must be defined as
 partial. This function parameters stay the same in each step of
 iteration -- list stays list, and heap stays heap. As we said before,
 in Isabelle/HOL we can only define total function, but there is a
 mechanism that enables total function to appear as partial one:\<close>
 
 partial_function (tailrec) ssort' where 
   "ssort' l sl = 
       (if is_empty l then 
           sl
        else 
           let 
             (m, l') = remove_max l 
           in
             ssort' l' (m # sl))"
 declare ssort'.simps[code] 
 definition ssort :: "'a list \<Rightarrow> 'a list" where 
   "ssort l = ssort' (of_list l) []"
 
 inductive ssort'_dom where
    step: "\<lbrakk>\<And>m l'. \<lbrakk>\<not> is_empty l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> 
                   ssort'_dom (l', m # sl)\<rbrakk> \<Longrightarrow> ssort'_dom (l, sl)"
 lemma ssort'_termination:
   assumes "inv (fst p)"
   shows "ssort'_dom p"
 using assms
 proof (induct p rule: wf_induct[of "measure (\<lambda>(l, sl). size (multiset l))"])
   let ?r = "measure (\<lambda>(l, sl). size (multiset l))"
   fix p :: "'b \<times> 'a list"
   assume "inv (fst p)" and *: 
          "\<forall>y. (y, p) \<in> ?r \<longrightarrow> inv (fst y) \<longrightarrow> ssort'_dom y"
   obtain l sl where "p = (l, sl)"
     by (cases p) auto
   show "ssort'_dom p"
   proof (subst \<open>p = (l, sl)\<close>, rule ssort'_dom.step)
     fix m l'
     assume "\<not> is_empty l" "(m, l') = remove_max l"
     show "ssort'_dom (l', m#sl)"
     proof (rule *[rule_format])
       show "((l', m#sl), p) \<in> ?r" "inv (fst (l', m#sl))"
         using \<open>p = (l, sl)\<close> \<open>inv (fst p)\<close> \<open>\<not> is_empty l\<close> 
         using \<open>(m, l') = remove_max l\<close>
         using remove_max_inv[of l m l']
         using remove_max_multiset_size[of l m l']
         by auto
     qed
   qed
 qed simp
 
 lemma ssort'Induct:
   assumes "inv l" "P l sl"
    "\<And> l sl m l'. 
     \<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l; P l sl\<rbrakk> \<Longrightarrow> P l' (m # sl)"
   shows "P empty (ssort' l sl)"
 proof-
   from \<open>inv l\<close> have "ssort'_dom (l, sl)"
     using ssort'_termination
     by auto
   thus ?thesis
     using assms
   proof (induct "(l, sl)" arbitrary: l sl rule: ssort'_dom.induct)
     case (step l sl)
     show ?case
     proof (cases "is_empty l")
       case True
       thus ?thesis
         using step(4) step(5) ssort'.simps[of l sl] is_empty_inj[of l]
         by simp
     next
       case False
       let ?p = "remove_max l" 
       let ?m = "fst ?p" and ?l' = "snd ?p"
       show ?thesis
         using False step(2)[of ?m ?l'] step(3) 
         using step(4) step(5)[of l ?m ?l' sl] step(5)
         using remove_max_inv[of l ?m ?l'] 
         using ssort'.simps[of l sl]
         by (cases ?p) auto
     qed
   qed
 qed
 
 lemma mset_ssort':
   assumes "inv l"
   shows "mset (ssort' l sl) = multiset l + mset sl"
 using assms
 proof-
     have "multiset empty + mset (ssort' l sl) = multiset l + mset sl"
       using assms
     proof (rule ssort'Induct)
       fix l1 sl1 m l'
       assume "\<not> is_empty l1" 
              "inv l1" 
              "(m, l') = remove_max l1" 
              "multiset l1 + mset sl1 = multiset l + mset sl"
       thus "multiset l' + mset (m # sl1) = multiset l + mset sl"
         using remove_max_multiset[of l1 m l']
         by (metis union_mset_add_mset_left union_mset_add_mset_right mset.simps(2))
     qed simp
     thus ?thesis
       using multiset_empty
       by simp
 qed
 
 lemma sorted_ssort':
   assumes "inv l" "sorted sl \<and> (\<forall> x \<in> set l. (\<forall> y \<in> List.set sl. x \<le> y))"
   shows "sorted (ssort' l sl)"
 using assms
 proof-
   have "sorted (ssort' l sl) \<and> 
         (\<forall> x \<in> set empty. (\<forall> y \<in> List.set (ssort' l sl). x \<le> y))"
     using assms
   proof (rule ssort'Induct)
     fix l sl m l'
     assume "\<not> is_empty l" 
            "inv l" 
            "(m, l') = remove_max l" 
            "sorted sl \<and> (\<forall>x\<in>set l. \<forall>y\<in>List.set sl. x \<le> y)"
     thus "sorted (m # sl) \<and> (\<forall>x\<in>set l'. \<forall>y\<in>List.set (m # sl). x \<le> y)"
       using remove_max_set[of l m l'] remove_max_max[of l m l']
       by (auto intro: Max_ge)
   qed
   thus ?thesis
     by simp
 qed
 
 lemma sorted_ssort: "sorted (ssort i)"
 unfolding ssort_def
 using sorted_ssort'[of "of_list i" "[]"] of_list_inv
 by auto
 
-lemma permutation_ssort: "ssort l <~~> l"
-proof (subst mset_eq_perm[symmetric])
-  show "mset (ssort l) = mset l"
-    unfolding ssort_def
-    using mset_ssort'[of "of_list l" "[]"]
-    using multiset_of_list of_list_inv
-    by simp
-qed
+lemma permutation_ssort: "mset (ssort l) = mset l"
+  unfolding ssort_def
+  using mset_ssort'[of "of_list l" "[]"]
+  using multiset_of_list of_list_inv
+  by simp
+
 end
 
 text\<open>Using assumptions given in the definitions of the locales {\em
   Collection} and {\em RemoveMax} for the functions {\em multiset},
 {\em is\_empty}, {\em of\_list} and {\em remove\_max} it is no
 difficulty to show:\<close>
 
 sublocale RemoveMax < Sort ssort
 by (unfold_locales) (auto simp add: sorted_ssort permutation_ssort)
 
 end
diff --git a/thys/Selection_Heap_Sort/SelectionSort_Functional.thy b/thys/Selection_Heap_Sort/SelectionSort_Functional.thy
--- a/thys/Selection_Heap_Sort/SelectionSort_Functional.thy
+++ b/thys/Selection_Heap_Sort/SelectionSort_Functional.thy
@@ -1,108 +1,106 @@
 (*  Title:      Sort.thy
     Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)
 
 section \<open>Verification of functional Selection Sort\<close>
 
 theory SelectionSort_Functional
 imports RemoveMax
 begin
 
 subsection \<open>Defining data structure\<close>
 
 text\<open>Selection sort works with list and that is the reason why {\em
   Collection} should be interpreted as list.\<close>
 
 interpretation Collection "[]" "\<lambda> l. l = []" id mset
 by (unfold_locales, auto)
 
 subsection \<open>Defining function remove\_max\<close>
 
 text\<open>The following is definition of {\em remove\_max} function. 
 The idea is very well known -- assume that the maximum element is the
 first one and then compare with each element of the list. Function
 {\em f} is one step in iteration, it compares current maximum {\em m}
 with one element {\em x}, if it is bigger then {\em m} stays current
 maximum and {\em x} is added in the resulting list, otherwise {\em x}
 is current maximum and {\em m} is added in the resulting
 list.
 \<close>
 
 fun f where "f (m, l) x = (if x \<ge> m then (x, m#l) else (m, x#l))"
 
 definition remove_max where
   "remove_max l = foldl f (hd l, []) (tl l)"
 
 lemma max_Max_commute: 
   "finite A \<Longrightarrow> max (Max (insert m A)) x = max m (Max (insert x A))"
   apply (cases "A = {}", simp)  
   by (metis Max_insert max.commute max.left_commute)
 
 text\<open>The function really returned the
 maximum value.\<close>
 
 lemma remove_max_max_lemma:
   shows "fst (foldl f (m, t) l) =  Max (set (m # l))"
 proof (induct l arbitrary: m t rule: rev_induct)
   case (snoc x xs)
   let ?a = "foldl f (m, t) xs"
   let ?m' = "fst ?a" and ?t' = "snd ?a"
   have "fst (foldl f (m, t) (xs @ [x])) = max ?m' x"
     by (cases ?a) (auto simp add: max_def)
   thus ?case
     using snoc
     by (simp add: max_Max_commute)
 qed simp
 
 lemma remove_max_max:
   assumes "l \<noteq> []" "(m, l') = remove_max l"
   shows "m = Max (set l)"
 using assms
 unfolding remove_max_def
 using remove_max_max_lemma[of "hd l" "[]" "tl l"]
 using fst_conv[of m l']
 by simp
 
 text\<open>Nothing new is added in the list and noting is deleted
 from the list except the maximum element.\<close>
 
 lemma remove_max_mset_lemma:
   assumes "(m, l') = foldl f (m', t') l"
   shows "mset (m # l') = mset (m' # t' @ l)"
 using assms
 proof (induct l arbitrary: l' m m' t' rule: rev_induct)
   case (snoc x xs)
   let ?a = "foldl f (m', t') xs"
   let ?m' = "fst ?a" and ?t' = "snd ?a"
   have "mset (?m' # ?t') = mset (m' # t' @ xs)"
     using snoc(1)[of ?m' ?t' m' t']
     by simp
   thus ?case
     using snoc(2)
     apply (cases "?a")
     by (auto split: if_split_asm) 
 qed simp
 
 lemma remove_max_mset:
   assumes "l \<noteq> []" "(m, l') = remove_max l" 
   shows "add_mset m (mset l') = mset l"
 using assms
 unfolding remove_max_def
 using remove_max_mset_lemma[of m l' "hd l" "[]" "tl l"]
 by auto
 
 definition ssf_ssort' where
   [simp, code del]: "ssf_ssort' = RemoveMax.ssort' (\<lambda> l. l = []) remove_max"
 definition ssf_ssort where 
   [simp, code del]: "ssf_ssort = RemoveMax.ssort (\<lambda> l. l = []) id remove_max"
 
 interpretation SSRemoveMax: 
   RemoveMax "[]" "\<lambda> l. l = []" id mset remove_max "\<lambda> _. True" 
   rewrites
  "RemoveMax.ssort' (\<lambda> l. l = []) remove_max = ssf_ssort'" and
  "RemoveMax.ssort (\<lambda> l. l = []) id remove_max = ssf_ssort"
 using remove_max_max
 by (unfold_locales, auto simp add: remove_max_mset)
 
-
-  
 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.List_Permutation"
+  "HOL-Library.Multiset"
 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"
+  assumes permutation: "mset (sort l) = mset 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,221 @@
 (*
     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.List_Permutation"
+imports "../Vcg" "../HeapList" "HOL-Library.Multiset"
 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>
+        mset Ps = mset 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>
+                 mset Ps = mset 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>
+               mset Ps = mset (\<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
+  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 (metis insertCI set_mset_add_mset_insert set_mset_mset)
+   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 (metis insertCI set_mset_add_mset_insert set_mset_mset)
+  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 (metis IntI empty_iff set_mset_mset)
+  apply (rule_tac x="p#sortedPsa" in exI)
+  apply (rule conjI)
+   apply (metis List_cons List_updateI Null_notin_List fun_upd_same insert_iff set_mset_add_mset_insert set_mset_mset)
+  apply (rule conjI)
+   apply (metis disjoint_iff mset_eq_setD set_ConsD)
+  apply clarsimp
+  apply (rule conjI)
+   apply (metis less_or_eq_imp_le mset_eq_setD)
+  apply (rule conjI)
+   apply (metis leD less_le_trans mset_eq_setD nat_le_linear)
+  apply clarsimp
+  apply (erule_tac x=x in allE)+
+  apply (metis Un_iff insert_iff list.set(2) mset.simps(2) mset_append set_append set_mset_mset)
+  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.Multiset"
     "HOL-Library.RBT_Mapping"
-    "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"
+  shows "mset t1 = mset t2"
 proof-
   {
     fix t1 t2
     assume "lvars t1 = lvars t2" "rvars t1 = rvars t2"
       "\<triangle> t1" "\<And> v::'a::lrv valuation. v \<Turnstile>\<^sub>t t1 \<longleftrightarrow> v \<Turnstile>\<^sub>t t2"
     have "set t1 \<subseteq> set t2"
     proof (safe)
       fix a b
       assume "(a, b) \<in> set t1"
       then have "a \<in> lvars t1"
         unfolding lvars_def
         by force
       then have "a \<in> lvars t2"
         using \<open>lvars t1 = lvars t2\<close>
         by simp
       then obtain b' where "(a, b') \<in> set t2"
         unfolding lvars_def
         by force
       have "\<forall>v::'a valuation. \<exists>v'. (\<forall>x\<in>vars (b - b'). v' x = v x) \<and> (b - b') \<lbrace> v' \<rbrace> = 0"
       proof
         fix v::"'a valuation"
         obtain v' where "v' \<Turnstile>\<^sub>t t1" "\<forall> x \<in> rvars t1. v x = v' x"
           using recalc_tableau_lvars[of t1] \<open>\<triangle> t1\<close>
           by auto
         have "v' \<Turnstile>\<^sub>t t2"
           using \<open>v' \<Turnstile>\<^sub>t t1\<close> \<open>\<And> v. v \<Turnstile>\<^sub>t t1 \<longleftrightarrow> v \<Turnstile>\<^sub>t t2\<close>
           by simp
         have "b \<lbrace>v'\<rbrace> = b' \<lbrace>v'\<rbrace>"
           using \<open>(a, b) \<in> set t1\<close> \<open>v' \<Turnstile>\<^sub>t t1\<close>
           using \<open>(a, b') \<in> set t2\<close> \<open>v' \<Turnstile>\<^sub>t t2\<close>
           unfolding satisfies_tableau_def satisfies_eq_def
           by force
         then have "(b - b') \<lbrace>v'\<rbrace> = 0"
           using valuate_minus[of b b' v']
           by auto
         moreover
         have "vars b \<subseteq> rvars t1" "vars b' \<subseteq> rvars t1"
           using \<open>(a, b) \<in> set t1\<close> \<open>(a, b') \<in> set t2\<close> \<open>rvars t1 = rvars t2\<close>
           unfolding rvars_def
           by force+
         then have "vars (b - b') \<subseteq> rvars t1"
           using vars_minus[of b b']
           by blast
         then have "\<forall>x\<in>vars (b - b'). v' x = v x"
           using \<open>\<forall> x \<in> rvars t1. v x = v' x\<close>
           by auto
         ultimately
         show "\<exists>v'. (\<forall>x\<in>vars (b - b'). v' x = v x) \<and> (b - b') \<lbrace> v' \<rbrace> = 0"
           by auto
       qed
       then have "b = b'"
         using all_val[of "b - b'"]
         by simp
       then show "(a, b) \<in> set t2"
         using \<open>(a, b') \<in> set t2\<close>
         by simp
     qed
   }
   note * = this
   have "set t1 = set t2"
     using *[of t1 t2] *[of t2 t1]
     using assms
     by auto
   moreover
   have "distinct t1" "distinct t2"
     using \<open>\<triangle> t1\<close> \<open>\<triangle> t2\<close>
     unfolding normalized_tableau_def
     by (auto simp add: distinct_map)
   ultimately
   show ?thesis
-    by (auto simp add: set_eq_iff_mset_eq_distinct mset_eq_perm)
+    by (auto simp add: set_eq_iff_mset_eq_distinct)
 qed
 
 
 text\<open>Elementary atoms are represented by the type \<open>'a atom\<close>
 and semantics for atoms and sets of atoms is denoted by \<open>\<Turnstile>\<^sub>a\<close> and
 \<open>\<Turnstile>\<^sub>a\<^sub>s\<close> and given by:
 \<close>
 
 datatype 'a atom  = Leq var 'a    |    Geq var 'a
 
 primrec atom_var::"'a atom \<Rightarrow> var" where
   "atom_var (Leq var a) = var"
 | "atom_var (Geq var a) = var"
 
 primrec atom_const::"'a atom \<Rightarrow> 'a" where
   "atom_const (Leq var a) = a"
 | "atom_const (Geq var a) = a"
 
 primrec satisfies_atom :: "'a::linorder valuation \<Rightarrow> 'a atom \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a" 100) where
   "v \<Turnstile>\<^sub>a Leq x c \<longleftrightarrow> v x \<le> c"    |    "v \<Turnstile>\<^sub>a Geq x c \<longleftrightarrow> v x \<ge> c"
 
 definition satisfies_atom_set :: "'a::linorder valuation \<Rightarrow> 'a atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>a\<^sub>s as \<equiv> \<forall> a \<in> as. v \<Turnstile>\<^sub>a a"
 
 definition satisfies_atom' :: "'a::linorder valuation \<Rightarrow> 'a atom \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a\<^sub>e" 100) where
   "v \<Turnstile>\<^sub>a\<^sub>e a \<longleftrightarrow> v (atom_var a) = atom_const a"
 
 lemma satisfies_atom'_stronger: "v \<Turnstile>\<^sub>a\<^sub>e a \<Longrightarrow> v \<Turnstile>\<^sub>a a" by (cases a, auto simp: satisfies_atom'_def)
 
 abbreviation satisfies_atom_set' :: "'a::linorder valuation \<Rightarrow> 'a atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>a\<^sub>e\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>a\<^sub>e\<^sub>s as \<equiv> \<forall> a \<in> as. v \<Turnstile>\<^sub>a\<^sub>e a"
 
 lemma satisfies_atom_set'_stronger: "v \<Turnstile>\<^sub>a\<^sub>e\<^sub>s as \<Longrightarrow> v \<Turnstile>\<^sub>a\<^sub>s as" 
   using satisfies_atom'_stronger unfolding satisfies_atom_set_def by auto
 
 text \<open>There is also the indexed variant of an atom\<close>
 
 type_synonym ('i,'a) i_atom = "'i \<times> 'a atom"
 
 fun i_satisfies_atom_set :: "'i set \<times> 'a::linorder valuation \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>a\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>a\<^sub>s restrict_to I as"
 
 fun i_satisfies_atom_set' :: "'i set \<times> 'a::linorder valuation \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>a\<^sub>e\<^sub>s restrict_to I as"
 
 lemma i_satisfies_atom_set'_stronger: "Iv \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as \<Longrightarrow> Iv \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as" 
   using satisfies_atom_set'_stronger[of _ "snd Iv"] by (cases Iv, auto)
 
 lemma satisifies_atom_restrict_to_Cons: "v \<Turnstile>\<^sub>a\<^sub>s restrict_to I (set as) \<Longrightarrow> (i \<in> I \<Longrightarrow> v \<Turnstile>\<^sub>a a)
   \<Longrightarrow> v \<Turnstile>\<^sub>a\<^sub>s restrict_to I (set ((i,a) # as))"
   unfolding satisfies_atom_set_def by auto
 
 lemma satisfies_tableau_Cons: "v \<Turnstile>\<^sub>t t \<Longrightarrow> v \<Turnstile>\<^sub>e e \<Longrightarrow> v \<Turnstile>\<^sub>t (e # t)"
   unfolding satisfies_tableau_def by auto
 
 definition distinct_indices_atoms :: "('i,'a) i_atom set \<Rightarrow> bool" where
   "distinct_indices_atoms as = (\<forall> i a b. (i,a) \<in> as \<longrightarrow> (i,b) \<in> as \<longrightarrow> atom_var a = atom_var b \<and> atom_const a = atom_const b)" 
 
 text\<open>
 The specification of the preprocessing function is given by:\<close>
 locale Preprocess = fixes preprocess::"('i,'a::lrv) i_ns_constraint list \<Rightarrow> tableau\<times> ('i,'a) i_atom list
   \<times> ((var,'a) mapping \<Rightarrow> (var,'a) mapping) \<times> 'i list"
   assumes
     \<comment> \<open>The returned tableau is always normalized.\<close>
     preprocess_tableau_normalized: "preprocess cs = (t,as,trans_v,U) \<Longrightarrow> \<triangle> t" and
 
 \<comment> \<open>Tableau and atoms are equisatisfiable with starting non-strict constraints.\<close>
 i_preprocess_sat: "\<And> v. preprocess cs = (t,as,trans_v,U) \<Longrightarrow> I \<inter> set U = {} \<Longrightarrow> (I,\<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<Longrightarrow> (I,\<langle>trans_v v\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" and
 
 preprocess_unsat: "preprocess cs = (t, as,trans_v,U) \<Longrightarrow> (I,v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs \<Longrightarrow> \<exists> v'. (I,v') \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as \<and> v' \<Turnstile>\<^sub>t t" and
 
 \<comment> \<open>distinct indices on ns-constraints ensures distinct indices in atoms\<close>
 preprocess_distinct: "preprocess cs = (t, as,trans_v, U) \<Longrightarrow> distinct_indices_ns (set cs) \<Longrightarrow> distinct_indices_atoms (set as)" and
 
 \<comment> \<open>unsat indices\<close>
 preprocess_unsat_indices: "preprocess cs = (t, as,trans_v, U) \<Longrightarrow> i \<in> set U \<Longrightarrow> \<not> (\<exists> v. ({i},v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs)" and
 
 \<comment> \<open>preprocessing cannot introduce new indices\<close>
 preprocess_index: "preprocess cs = (t,as,trans_v, U) \<Longrightarrow> fst ` set as \<union> set U \<subseteq> fst ` set cs"
 begin
 lemma preprocess_sat: "preprocess cs = (t,as,trans_v,U) \<Longrightarrow> U = [] \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s flat (set as) \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<Longrightarrow> \<langle>trans_v v\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set cs)"
   using i_preprocess_sat[of cs t as trans_v U UNIV v] by auto
 
 end
 
 definition minimal_unsat_core_tabl_atoms :: "'i set \<Rightarrow> tableau \<Rightarrow> ('i,'a::lrv) i_atom set \<Rightarrow> bool" where
   "minimal_unsat_core_tabl_atoms I t as = ( I \<subseteq> fst ` as \<and> (\<not> (\<exists> v. v \<Turnstile>\<^sub>t t \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as)) \<and>
        (distinct_indices_atoms as \<longrightarrow> (\<forall> J \<subset> I. \<exists> v. v \<Turnstile>\<^sub>t t \<and> (J,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as)))" 
 
 lemma minimal_unsat_core_tabl_atomsD: assumes "minimal_unsat_core_tabl_atoms I t as"
   shows "I \<subseteq> fst ` as" 
     "\<not> (\<exists> v. v \<Turnstile>\<^sub>t t \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as)" 
     "distinct_indices_atoms as \<Longrightarrow> J \<subset> I \<Longrightarrow> \<exists> v. v \<Turnstile>\<^sub>t t \<and> (J,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" 
   using assms unfolding minimal_unsat_core_tabl_atoms_def by auto
 
 locale AssertAll =
   fixes assert_all :: "tableau \<Rightarrow> ('i,'a::lrv) i_atom list \<Rightarrow> 'i list + (var, 'a)mapping"
   assumes assert_all_sat:  "\<triangle> t \<Longrightarrow> assert_all t as = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s flat (set as)"
   assumes assert_all_unsat:  "\<triangle> t \<Longrightarrow> assert_all t as = Unsat I \<Longrightarrow> minimal_unsat_core_tabl_atoms (set I) t (set as)"
 
 
 text\<open>Once the preprocessing is done and tableau and atoms are
 obtained, their satisfiability is checked by the
 \<open>assert_all\<close> function. Its precondition is that the starting
 tableau is normalized, and its specification is analogue to the one for the
 \<open>solve\<close> function. If \<open>preprocess\<close> and \<open>assert_all\<close>
 are available, the  \<open>solve_exec_ns\<close> can be defined, and it
 can easily be shown that this definition satisfies the specification.\<close>
 
 locale Solve_exec_ns' = Preprocess preprocess + AssertAll assert_all for
   preprocess:: "('i,'a::lrv) i_ns_constraint list \<Rightarrow> tableau \<times> ('i,'a) i_atom list \<times> ((var,'a)mapping \<Rightarrow> (var,'a)mapping) \<times> 'i list" and
   assert_all :: "tableau \<Rightarrow> ('i,'a::lrv) i_atom list \<Rightarrow> 'i list + (var, 'a) mapping"
 begin
 definition solve_exec_ns where
 
 "solve_exec_ns s \<equiv>
     case preprocess s of (t,as,trans_v,ui) \<Rightarrow>
       (case ui of i # _ \<Rightarrow> Inl [i] | _ \<Rightarrow>
       (case assert_all t as of Inl I \<Rightarrow> Inl I | Inr v \<Rightarrow> Inr (trans_v v))) "
 end
 
 context Preprocess
 begin
 
 lemma preprocess_unsat_index: assumes prep: "preprocess cs = (t,as,trans_v,ui)" 
   and i: "i \<in> set ui" 
 shows "minimal_unsat_core_ns {i} (set cs)"
 proof -
   from preprocess_index[OF prep] have "set ui \<subseteq> fst ` set cs" by auto
   with i have i': "i \<in> fst ` set cs" by auto
   from preprocess_unsat_indices[OF prep i]
   show ?thesis unfolding minimal_unsat_core_ns_def using i' by auto
 qed
 
 lemma preprocess_minimal_unsat_core: assumes prep: "preprocess cs = (t,as,trans_v,ui)"
     and unsat: "minimal_unsat_core_tabl_atoms I t (set as)" 
     and inter: "I \<inter> set ui = {}" 
   shows "minimal_unsat_core_ns I (set cs)" 
 proof -
   from preprocess_tableau_normalized[OF prep]
   have t: "\<triangle> t" .
   from preprocess_index[OF prep] have index: "fst ` set as \<union> set ui \<subseteq> fst ` set cs" by auto
   from minimal_unsat_core_tabl_atomsD(1,2)[OF unsat] preprocess_unsat[OF prep, of I]
   have 1: "I \<subseteq> fst ` set as" "\<not> (\<exists> v. (I, v) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs)" by force+
   show "minimal_unsat_core_ns I (set cs)" unfolding minimal_unsat_core_ns_def
   proof (intro conjI impI allI 1(2))
     show "I \<subseteq> fst ` set cs" using 1 index by auto
     fix J
     assume "distinct_indices_ns (set cs)" "J \<subset> I" 
     with preprocess_distinct[OF prep]
     have "distinct_indices_atoms (set as)" "J \<subset> I" by auto
     from minimal_unsat_core_tabl_atomsD(3)[OF unsat this]
     obtain v where model: "v \<Turnstile>\<^sub>t t" "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s set as" by auto
     from i_satisfies_atom_set'_stronger[OF model(2)] 
     have model': "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" . 
     define w where "w = Mapping.Mapping (\<lambda> x. Some (v x))"
     have "v = \<langle>w\<rangle>" unfolding w_def map2fun_def
       by (intro ext, transfer, auto)
     with model model' have "\<langle>w\<rangle> \<Turnstile>\<^sub>t t" "(J, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" by auto
     from i_preprocess_sat[OF prep _ this(2,1)] \<open>J \<subset> I\<close> inter
     have "(J, \<langle>trans_v w\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" by auto
     then show "\<exists> w. (J, w) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set cs" by auto
   qed
 qed
 end
 
 sublocale Solve_exec_ns' < Solve_exec_ns solve_exec_ns
 proof
   fix cs
   obtain t as trans_v ui where prep: "preprocess cs = (t,as,trans_v,ui)" by (cases "preprocess cs")
   from preprocess_tableau_normalized[OF prep]
   have t: "\<triangle> t" .
   from preprocess_index[OF prep] have index: "fst ` set as \<union> set ui \<subseteq> fst ` set cs" by auto
   note solve = solve_exec_ns_def[of cs, unfolded prep split]
   {
     fix v
     assume "solve_exec_ns cs = Sat v"
     from this[unfolded solve] t assert_all_sat[OF t] preprocess_sat[OF prep]
     show " \<langle>v\<rangle> \<Turnstile>\<^sub>n\<^sub>s\<^sub>s flat (set cs)" by (auto split: sum.splits list.splits)
   }
   {
     fix I
     assume res: "solve_exec_ns cs = Unsat I"
     show "minimal_unsat_core_ns (set I) (set cs)" 
     proof (cases ui)
       case (Cons i uis)
       hence I: "I = [i]" using res[unfolded solve] by auto
       from preprocess_unsat_index[OF prep, of i] I Cons index show ?thesis by auto
     next
       case Nil
       from res[unfolded solve Nil] have assert: "assert_all t as = Unsat I"
         by (auto split: sum.splits)
       from assert_all_unsat[OF t assert]
       have "minimal_unsat_core_tabl_atoms (set I) t (set as)" .
       from preprocess_minimal_unsat_core[OF prep this] Nil
       show "minimal_unsat_core_ns (set I) (set cs)" by simp
     qed
   }
 qed
 
 subsection\<open>Incrementally Asserting Atoms\<close>
 
 text\<open>The function @{term assert_all} can be implemented by
 iteratively asserting one by one atom from the given list of atoms.
 \<close>
 
 type_synonym 'a bounds = "var \<rightharpoonup> 'a"
 
 text\<open>Asserted atoms will be stored in a form of \emph{bounds} for a
 given variable. Bounds are of the form \<open>l\<^sub>i \<le> x\<^sub>i \<le> u\<^sub>i\<close>, where
 \<open>l\<^sub>i\<close> and \<open>u\<^sub>i\<close> and are either scalars or $\pm
 \infty$. Each time a new atom is asserted, a bound for the
 corresponding variable is updated (checking for conflict with the
 previous bounds). Since bounds for a variable can be either finite or
 $\pm \infty$, they are represented by (partial) maps from variables to
 values (\<open>'a bounds = var \<rightharpoonup> 'a\<close>). Upper and lower bounds are
 represented separately. Infinite bounds map to @{term None} and this
 is reflected in the semantics:
 
 \begin{small}
 \<open>c \<ge>\<^sub>u\<^sub>b b \<longleftrightarrow> case b of None \<Rightarrow> False | Some b' \<Rightarrow> c \<ge> b'\<close>
 
 \<open>c \<le>\<^sub>u\<^sub>b b \<longleftrightarrow> case b of None \<Rightarrow> True | Some b' \<Rightarrow> c \<le> b'\<close>
 \end{small}
 
 \noindent Strict comparisons, and comparisons with lower bounds are performed similarly.
 \<close>
 
 abbreviation (input) le where
   "le lt x y \<equiv> lt x y \<or> x = y"
 definition geub ("\<unrhd>\<^sub>u\<^sub>b") where
   "\<unrhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> le lt b' c"
 definition gtub ("\<rhd>\<^sub>u\<^sub>b") where
   "\<rhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> lt b' c"
 definition leub ("\<unlhd>\<^sub>u\<^sub>b") where
   "\<unlhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> le lt c b'"
 definition ltub ("\<lhd>\<^sub>u\<^sub>b") where
   "\<lhd>\<^sub>u\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> lt c b'"
 definition lelb ("\<unlhd>\<^sub>l\<^sub>b") where
   "\<unlhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> le lt c b'"
 definition ltlb ("\<lhd>\<^sub>l\<^sub>b") where
   "\<lhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> False | Some b' \<Rightarrow> lt c b'"
 definition gelb ("\<unrhd>\<^sub>l\<^sub>b") where
   "\<unrhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> le lt b' c"
 definition gtlb ("\<rhd>\<^sub>l\<^sub>b") where
   "\<rhd>\<^sub>l\<^sub>b lt c b \<equiv> case b of None \<Rightarrow> True | Some b' \<Rightarrow> lt b' c"
 
 
 definition ge_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<ge>\<^sub>u\<^sub>b" 100) where
   "c \<ge>\<^sub>u\<^sub>b b = \<unrhd>\<^sub>u\<^sub>b (<) c b"
 definition gt_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl ">\<^sub>u\<^sub>b" 100) where
   "c >\<^sub>u\<^sub>b b = \<rhd>\<^sub>u\<^sub>b (<) c b"
 definition le_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<le>\<^sub>u\<^sub>b" 100) where
   "c \<le>\<^sub>u\<^sub>b b = \<unlhd>\<^sub>u\<^sub>b (<) c b"
 definition lt_ubound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "<\<^sub>u\<^sub>b" 100) where
   "c <\<^sub>u\<^sub>b b = \<lhd>\<^sub>u\<^sub>b (<) c b"
 definition le_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<le>\<^sub>l\<^sub>b" 100) where
   "c \<le>\<^sub>l\<^sub>b b = \<unlhd>\<^sub>l\<^sub>b (<) c b"
 definition lt_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "<\<^sub>l\<^sub>b" 100) where
   "c <\<^sub>l\<^sub>b b = \<lhd>\<^sub>l\<^sub>b (<) c b"
 definition ge_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl "\<ge>\<^sub>l\<^sub>b" 100) where
   "c \<ge>\<^sub>l\<^sub>b b = \<unrhd>\<^sub>l\<^sub>b (<) c b"
 definition gt_lbound :: "'a::linorder \<Rightarrow> 'a option \<Rightarrow> bool" (infixl ">\<^sub>l\<^sub>b" 100) where
   "c >\<^sub>l\<^sub>b b = \<rhd>\<^sub>l\<^sub>b (<) c b"
 
 
 lemmas bound_compare'_defs =
   geub_def gtub_def leub_def ltub_def
   gelb_def gtlb_def lelb_def ltlb_def
 
 lemmas bound_compare''_defs =
   ge_ubound_def gt_ubound_def le_ubound_def lt_ubound_def
   le_lbound_def lt_lbound_def ge_lbound_def gt_lbound_def
 
 lemmas bound_compare_defs = bound_compare'_defs bound_compare''_defs
 
 
 lemma opposite_dir [simp]:
   "\<unlhd>\<^sub>l\<^sub>b (>) a b = \<unrhd>\<^sub>u\<^sub>b (<) a b"
   "\<unlhd>\<^sub>u\<^sub>b (>) a b = \<unrhd>\<^sub>l\<^sub>b (<) a b"
   "\<unrhd>\<^sub>l\<^sub>b (>) a b = \<unlhd>\<^sub>u\<^sub>b (<) a b"
   "\<unrhd>\<^sub>u\<^sub>b (>) a b = \<unlhd>\<^sub>l\<^sub>b (<) a b"
   "\<lhd>\<^sub>l\<^sub>b (>) a b = \<rhd>\<^sub>u\<^sub>b (<) a b"
   "\<lhd>\<^sub>u\<^sub>b (>) a b = \<rhd>\<^sub>l\<^sub>b (<) a b"
   "\<rhd>\<^sub>l\<^sub>b (>) a b = \<lhd>\<^sub>u\<^sub>b (<) a b"
   "\<rhd>\<^sub>u\<^sub>b (>) a b = \<lhd>\<^sub>l\<^sub>b (<) a b"
   by (case_tac[!] b) (auto simp add: bound_compare'_defs)
 
 
 (* Auxiliary lemmas about bound comparison *)
 
 lemma [simp]: "\<not> c \<ge>\<^sub>u\<^sub>b None " "\<not> c \<le>\<^sub>l\<^sub>b None"
   by (auto simp add: bound_compare_defs)
 
 lemma neg_bounds_compare:
   "(\<not> (c \<ge>\<^sub>u\<^sub>b b)) \<Longrightarrow> c <\<^sub>u\<^sub>b b" "(\<not> (c \<le>\<^sub>u\<^sub>b b)) \<Longrightarrow> c >\<^sub>u\<^sub>b b"
   "(\<not> (c >\<^sub>u\<^sub>b b)) \<Longrightarrow> c \<le>\<^sub>u\<^sub>b b" "(\<not> (c <\<^sub>u\<^sub>b b)) \<Longrightarrow> c \<ge>\<^sub>u\<^sub>b b"
   "(\<not> (c \<le>\<^sub>l\<^sub>b b)) \<Longrightarrow> c >\<^sub>l\<^sub>b b" "(\<not> (c \<ge>\<^sub>l\<^sub>b b)) \<Longrightarrow> c <\<^sub>l\<^sub>b b"
   "(\<not> (c <\<^sub>l\<^sub>b b)) \<Longrightarrow> c \<ge>\<^sub>l\<^sub>b b" "(\<not> (c >\<^sub>l\<^sub>b b)) \<Longrightarrow> c \<le>\<^sub>l\<^sub>b b"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma bounds_compare_contradictory [simp]:
   "\<lbrakk>c \<ge>\<^sub>u\<^sub>b b; c <\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c \<le>\<^sub>u\<^sub>b b; c >\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   "\<lbrakk>c >\<^sub>u\<^sub>b b; c \<le>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c <\<^sub>u\<^sub>b b; c \<ge>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   "\<lbrakk>c \<le>\<^sub>l\<^sub>b b; c >\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c \<ge>\<^sub>l\<^sub>b b; c <\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   "\<lbrakk>c <\<^sub>l\<^sub>b b; c \<ge>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False" "\<lbrakk>c >\<^sub>l\<^sub>b b; c \<le>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> False"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma compare_strict_nonstrict:
   "x <\<^sub>u\<^sub>b b \<Longrightarrow> x \<le>\<^sub>u\<^sub>b b"
   "x >\<^sub>u\<^sub>b b \<Longrightarrow> x \<ge>\<^sub>u\<^sub>b b"
   "x <\<^sub>l\<^sub>b b \<Longrightarrow> x \<le>\<^sub>l\<^sub>b b"
   "x >\<^sub>l\<^sub>b b \<Longrightarrow> x \<ge>\<^sub>l\<^sub>b b"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma [simp]:
   "\<lbrakk> x \<le> c; c <\<^sub>u\<^sub>b b \<rbrakk> \<Longrightarrow> x <\<^sub>u\<^sub>b b"
   "\<lbrakk> x < c; c \<le>\<^sub>u\<^sub>b b \<rbrakk> \<Longrightarrow> x <\<^sub>u\<^sub>b b"
   "\<lbrakk> x \<le> c; c \<le>\<^sub>u\<^sub>b b \<rbrakk> \<Longrightarrow> x \<le>\<^sub>u\<^sub>b b"
   "\<lbrakk> x \<ge> c; c >\<^sub>l\<^sub>b b \<rbrakk> \<Longrightarrow> x >\<^sub>l\<^sub>b b"
   "\<lbrakk> x > c; c \<ge>\<^sub>l\<^sub>b b \<rbrakk> \<Longrightarrow> x >\<^sub>l\<^sub>b b"
   "\<lbrakk> x \<ge> c; c \<ge>\<^sub>l\<^sub>b b \<rbrakk> \<Longrightarrow> x \<ge>\<^sub>l\<^sub>b b"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma bounds_lg [simp]:
   "\<lbrakk> c >\<^sub>u\<^sub>b b; x \<le>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> x < c"
   "\<lbrakk> c \<ge>\<^sub>u\<^sub>b b; x <\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> x < c"
   "\<lbrakk> c \<ge>\<^sub>u\<^sub>b b; x \<le>\<^sub>u\<^sub>b b\<rbrakk> \<Longrightarrow> x \<le> c"
   "\<lbrakk> c <\<^sub>l\<^sub>b b; x \<ge>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> x > c"
   "\<lbrakk> c \<le>\<^sub>l\<^sub>b b; x >\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> x > c"
   "\<lbrakk> c \<le>\<^sub>l\<^sub>b b; x \<ge>\<^sub>l\<^sub>b b\<rbrakk> \<Longrightarrow> x \<ge> c"
   by (case_tac[!] b) (auto simp add: bound_compare_defs)
 
 lemma bounds_compare_Some [simp]:
   "x \<le>\<^sub>u\<^sub>b Some c \<longleftrightarrow> x \<le> c" "x \<ge>\<^sub>u\<^sub>b Some c \<longleftrightarrow> x \<ge> c"
   "x <\<^sub>u\<^sub>b Some c \<longleftrightarrow> x < c" "x >\<^sub>u\<^sub>b Some c \<longleftrightarrow> x > c"
   "x \<ge>\<^sub>l\<^sub>b Some c \<longleftrightarrow> x \<ge> c" "x \<le>\<^sub>l\<^sub>b Some c \<longleftrightarrow> x \<le> c"
   "x >\<^sub>l\<^sub>b Some c \<longleftrightarrow> x > c" "x <\<^sub>l\<^sub>b Some c \<longleftrightarrow> x < c"
   by (auto simp add: bound_compare_defs)
 
 fun in_bounds where
   "in_bounds x v (lb, ub) = (v x \<ge>\<^sub>l\<^sub>b lb x \<and> v x \<le>\<^sub>u\<^sub>b ub x)"
 
 fun satisfies_bounds :: "'a::linorder valuation \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>b" 100) where
   "v \<Turnstile>\<^sub>b b \<longleftrightarrow> (\<forall> x. in_bounds x v b)"
 declare satisfies_bounds.simps [simp del]
 
 
 lemma satisfies_bounds_iff:
   "v \<Turnstile>\<^sub>b (lb, ub) \<longleftrightarrow> (\<forall> x. v x \<ge>\<^sub>l\<^sub>b lb x \<and> v x \<le>\<^sub>u\<^sub>b ub x)"
   by (auto simp add: satisfies_bounds.simps)
 
 lemma not_in_bounds:
   "\<not> (in_bounds x v (lb, ub)) = (v x <\<^sub>l\<^sub>b lb x \<or> v x >\<^sub>u\<^sub>b ub x)"
   using bounds_compare_contradictory(7)
   using bounds_compare_contradictory(2)
   using neg_bounds_compare(7)[of "v x" "lb x"]
   using neg_bounds_compare(2)[of "v x" "ub x"]
   by auto
 
 fun atoms_equiv_bounds :: "'a::linorder atom set \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> bool" (infixl "\<doteq>" 100) where
   "as \<doteq> (lb, ub) \<longleftrightarrow> (\<forall> v. v \<Turnstile>\<^sub>a\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>b (lb, ub))"
 declare atoms_equiv_bounds.simps [simp del]
 
 lemma atoms_equiv_bounds_simps:
   "as \<doteq> (lb, ub) \<equiv> \<forall> v. v \<Turnstile>\<^sub>a\<^sub>s as \<longleftrightarrow> v \<Turnstile>\<^sub>b (lb, ub)"
   by (simp add: atoms_equiv_bounds.simps)
 
 text\<open>A valuation satisfies bounds iff the value of each variable
 respects both its lower and upper bound, i.e, @{thm
 satisfies_bounds_iff[no_vars]}. Asserted atoms are precisely encoded
 by the current bounds in a state (denoted by \<open>\<doteq>\<close>) if every
 valuation satisfies them iff it satisfies the bounds, i.e.,
 @{thm atoms_equiv_bounds_simps[no_vars, iff]}.\<close>
 
 text\<open>The procedure also keeps track of a valuation that is a
 candidate solution. Whenever a new atom is asserted, it is checked
 whether the valuation is still satisfying. If not, the procedure tries
 to fix that by changing it and changing the tableau if necessary (but
 so that it remains equivalent to the initial tableau).\<close>
 
 text\<open>Therefore, the state of the procedure stores the tableau
 (denoted by \<open>\<T>\<close>), lower and upper bounds (denoted by \<open>\<B>\<^sub>l\<close> and \<open>\<B>\<^sub>u\<close>, and ordered pair of lower and upper bounds
 denoted by \<open>\<B>\<close>), candidate solution (denoted by \<open>\<V>\<close>)
 and a flag (denoted by \<open>\<U>\<close>) indicating if unsatisfiability has
 been detected so far:\<close>
 
 text\<open>Since we also need to now about the indices of atoms, actually,
   the bounds are also indexed, and in addition to the flag for unsatisfiability,
   we also store an optional unsat core.\<close>
 
 type_synonym 'i bound_index = "var \<Rightarrow> 'i"
 
 type_synonym ('i,'a) bounds_index = "(var, ('i \<times> 'a))mapping"
 
 datatype ('i,'a) state = State
   (\<T>: "tableau")
   (\<B>\<^sub>i\<^sub>l: "('i,'a) bounds_index")
   (\<B>\<^sub>i\<^sub>u: "('i,'a) bounds_index")
   (\<V>: "(var, 'a) mapping")
   (\<U>: bool)
   (\<U>\<^sub>c: "'i list option")
 
 definition indexl :: "('i,'a) state \<Rightarrow> 'i bound_index" ("\<I>\<^sub>l") where
   "\<I>\<^sub>l s = (fst o the) o look (\<B>\<^sub>i\<^sub>l s)"
 
 definition boundsl :: "('i,'a) state \<Rightarrow> 'a bounds" ("\<B>\<^sub>l") where
   "\<B>\<^sub>l s = map_option snd o look (\<B>\<^sub>i\<^sub>l s)"
 
 definition indexu :: "('i,'a) state \<Rightarrow> 'i bound_index" ("\<I>\<^sub>u") where
   "\<I>\<^sub>u s = (fst o the) o look (\<B>\<^sub>i\<^sub>u s)"
 
 definition boundsu :: "('i,'a) state \<Rightarrow> 'a bounds" ("\<B>\<^sub>u") where
   "\<B>\<^sub>u s = map_option snd o look (\<B>\<^sub>i\<^sub>u s)"
 
 abbreviation BoundsIndicesMap ("\<B>\<^sub>i") where  "\<B>\<^sub>i s \<equiv> (\<B>\<^sub>i\<^sub>l s, \<B>\<^sub>i\<^sub>u s)"
 abbreviation Bounds :: "('i,'a) state \<Rightarrow> 'a bounds \<times> 'a bounds" ("\<B>") where  "\<B> s \<equiv> (\<B>\<^sub>l s, \<B>\<^sub>u s)"
 abbreviation Indices :: "('i,'a) state \<Rightarrow> 'i bound_index \<times> 'i bound_index" ("\<I>") where  "\<I> s \<equiv> (\<I>\<^sub>l s, \<I>\<^sub>u s)"
 abbreviation BoundsIndices :: "('i,'a) state \<Rightarrow> ('a bounds \<times> 'a bounds) \<times> ('i bound_index \<times> 'i bound_index)" ("\<B>\<I>")
   where  "\<B>\<I> s \<equiv> (\<B> s, \<I> s)"
 
 fun satisfies_bounds_index :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('a bounds \<times> 'a bounds) \<times>
   ('i bound_index \<times> 'i bound_index) \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>b" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>b ((BL,BU),(IL,IU)) \<longleftrightarrow> (
      (\<forall> x c. BL x = Some c \<longrightarrow> IL x \<in> I \<longrightarrow> v x \<ge> c)
    \<and> (\<forall> x c. BU x = Some c \<longrightarrow> IU x \<in> I \<longrightarrow> v x \<le> c))"
 declare satisfies_bounds_index.simps[simp del]
 
 fun satisfies_bounds_index' :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('a bounds \<times> 'a bounds) \<times>
   ('i bound_index \<times> 'i bound_index) \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>b\<^sub>e" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e ((BL,BU),(IL,IU)) \<longleftrightarrow> (
      (\<forall> x c. BL x = Some c \<longrightarrow> IL x \<in> I \<longrightarrow> v x = c)
    \<and> (\<forall> x c. BU x = Some c \<longrightarrow> IU x \<in> I \<longrightarrow> v x = c))"
 declare satisfies_bounds_index'.simps[simp del]
 
 fun atoms_imply_bounds_index :: "('i,'a::lrv) i_atom set \<Rightarrow> ('a bounds \<times> 'a bounds) \<times> ('i bound_index \<times> 'i bound_index)
   \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i" 100) where
   "as \<Turnstile>\<^sub>i bi \<longleftrightarrow> (\<forall> I v. (I,v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as \<longrightarrow> (I,v) \<Turnstile>\<^sub>i\<^sub>b bi)"
 declare atoms_imply_bounds_index.simps[simp del]
 
 lemma i_satisfies_atom_set_mono: "as \<subseteq> as' \<Longrightarrow> v \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as' \<Longrightarrow> v \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as"
   by (cases v, auto simp: satisfies_atom_set_def)
 
 lemma atoms_imply_bounds_index_mono: "as \<subseteq> as' \<Longrightarrow> as \<Turnstile>\<^sub>i bi \<Longrightarrow> as' \<Turnstile>\<^sub>i bi"
   unfolding atoms_imply_bounds_index.simps using i_satisfies_atom_set_mono by blast
 
 definition satisfies_state :: "'a::lrv valuation \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>s" 100) where
   "v \<Turnstile>\<^sub>s s \<equiv> v \<Turnstile>\<^sub>b \<B> s \<and> v \<Turnstile>\<^sub>t \<T> s"
 
 definition curr_val_satisfies_state :: "('i,'a::lrv) state \<Rightarrow> bool" ("\<Turnstile>") where
   "\<Turnstile> s \<equiv> \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>s s"
 
 fun satisfies_state_index :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>s" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>s s \<longleftrightarrow> (v \<Turnstile>\<^sub>t \<T> s \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>b \<B>\<I> s)"
 declare satisfies_state_index.simps[simp del]
 
 fun satisfies_state_index' :: "'i set \<times> 'a::lrv valuation \<Rightarrow> ('i,'a) state \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>i\<^sub>s\<^sub>e" 100) where
   "(I,v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s \<longleftrightarrow> (v \<Turnstile>\<^sub>t \<T> s \<and> (I,v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e \<B>\<I> s)"
 declare satisfies_state_index'.simps[simp del]
 
 definition indices_state :: "('i,'a)state \<Rightarrow> 'i set" where
   "indices_state s = { i. \<exists> x b. look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b)}"
 
 text \<open>distinctness requires that for each index $i$, there is at most one variable $x$ and bound
   $b$ such that $x \leq b$ or $x \geq b$ or both are enforced.\<close>
 definition distinct_indices_state :: "('i,'a)state \<Rightarrow> bool" where
   "distinct_indices_state s = (\<forall> i x b x' b'. 
     ((look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b)) \<longrightarrow>
     (look (\<B>\<^sub>i\<^sub>l s) x' = Some (i,b') \<or> look (\<B>\<^sub>i\<^sub>u s) x' = Some (i,b')) \<longrightarrow>
     (x = x' \<and> b = b')))" 
 
 lemma distinct_indices_stateD: assumes "distinct_indices_state s"
   shows "look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b) \<Longrightarrow> look (\<B>\<^sub>i\<^sub>l s) x' = Some (i,b') \<or> look (\<B>\<^sub>i\<^sub>u s) x' = Some (i,b')
     \<Longrightarrow> x = x' \<and> b = b'" 
   using assms unfolding distinct_indices_state_def by blast+
 
 definition unsat_state_core :: "('i,'a::lrv) state \<Rightarrow> bool" where
   "unsat_state_core s = (set (the (\<U>\<^sub>c s)) \<subseteq> indices_state s \<and> (\<not> (\<exists> v. (set (the (\<U>\<^sub>c s)),v) \<Turnstile>\<^sub>i\<^sub>s s)))"
 
 definition subsets_sat_core :: "('i,'a::lrv) state \<Rightarrow> bool" where
   "subsets_sat_core s = ((\<forall> I. I \<subset> set (the (\<U>\<^sub>c s)) \<longrightarrow> (\<exists> v. (I,v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s)))" 
 
 definition minimal_unsat_state_core :: "('i,'a::lrv) state \<Rightarrow> bool" where
   "minimal_unsat_state_core s = (unsat_state_core s \<and> (distinct_indices_state s \<longrightarrow> subsets_sat_core s))" 
 
 lemma minimal_unsat_core_tabl_atoms_mono: assumes sub: "as \<subseteq> bs" 
   and unsat: "minimal_unsat_core_tabl_atoms I t as" 
 shows "minimal_unsat_core_tabl_atoms I t bs" 
   unfolding minimal_unsat_core_tabl_atoms_def
 proof (intro conjI impI allI)
   note min = unsat[unfolded minimal_unsat_core_tabl_atoms_def]
   from min have I: "I \<subseteq> fst ` as" by blast
   with sub show "I \<subseteq> fst ` bs" by blast
   from min have "(\<nexists>v. v \<Turnstile>\<^sub>t t \<and> (I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as)" by blast
   with i_satisfies_atom_set_mono[OF sub]
   show "(\<nexists>v. v \<Turnstile>\<^sub>t t \<and> (I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s bs)" by blast
   fix J
   assume J: "J \<subset> I" and dist_bs: "distinct_indices_atoms bs" 
   hence dist: "distinct_indices_atoms as" 
     using sub unfolding distinct_indices_atoms_def by blast
   from min dist J obtain v where v: "v \<Turnstile>\<^sub>t t" "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" by blast
   have "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s bs"
     unfolding i_satisfies_atom_set'.simps
   proof (intro ballI)
     fix a
     assume "a \<in> snd ` (bs \<inter> J \<times> UNIV)" 
     then obtain i where ia: "(i,a) \<in> bs" and i: "i \<in> J" 
       by force
     with J have "i \<in> I" by auto 
     with I obtain b where ib: "(i,b) \<in> as" by force
     with sub have ib': "(i,b) \<in> bs" by auto
     from dist_bs[unfolded distinct_indices_atoms_def, rule_format, OF ia ib']
     have id: "atom_var a = atom_var b" "atom_const a = atom_const b" by auto
     from v(2)[unfolded i_satisfies_atom_set'.simps] i ib 
     have "v \<Turnstile>\<^sub>a\<^sub>e b" by force
     thus "v \<Turnstile>\<^sub>a\<^sub>e a" using id unfolding satisfies_atom'_def by auto
   qed
   with v show "\<exists>v. v \<Turnstile>\<^sub>t t \<and> (J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s bs" by blast
 qed
 
 lemma state_satisfies_index: assumes "v \<Turnstile>\<^sub>s s"
   shows "(I,v) \<Turnstile>\<^sub>i\<^sub>s s"
   unfolding satisfies_state_index.simps satisfies_bounds_index.simps
 proof (intro conjI impI allI)
   fix x c
   from assms[unfolded satisfies_state_def satisfies_bounds.simps, simplified]
   have "v \<Turnstile>\<^sub>t \<T> s" and bnd: "v x \<ge>\<^sub>l\<^sub>b \<B>\<^sub>l s x" "v x \<le>\<^sub>u\<^sub>b \<B>\<^sub>u s x" by auto
   show "v \<Turnstile>\<^sub>t \<T> s" by fact
   show "\<B>\<^sub>l s x = Some c \<Longrightarrow> \<I>\<^sub>l s x \<in> I \<Longrightarrow> c \<le> v x"
     using bnd(1) by auto
   show "\<B>\<^sub>u s x = Some c \<Longrightarrow> \<I>\<^sub>u s x \<in> I \<Longrightarrow> v x \<le> c"
     using bnd(2) by auto
 qed
 
 lemma unsat_state_core_unsat: "unsat_state_core s \<Longrightarrow> \<not> (\<exists> v. v \<Turnstile>\<^sub>s s)"
   unfolding unsat_state_core_def using state_satisfies_index by blast
 
 definition tableau_valuated ("\<nabla>") where
   "\<nabla> s \<equiv> \<forall> x \<in> tvars (\<T> s). Mapping.lookup (\<V> s) x \<noteq> None"
 
 definition index_valid where
   "index_valid as (s :: ('i,'a) state) = (\<forall> x b i.
       (look (\<B>\<^sub>i\<^sub>l s) x = Some (i,b) \<longrightarrow> ((i, Geq x b) \<in> as))
     \<and> (look (\<B>\<^sub>i\<^sub>u s) x = Some (i,b) \<longrightarrow> ((i, Leq x b) \<in> as)))"
 
 lemma index_valid_indices_state: "index_valid as s \<Longrightarrow> indices_state s \<subseteq> fst ` as"
   unfolding index_valid_def indices_state_def by force
 
 lemma index_valid_mono: "as \<subseteq> bs \<Longrightarrow> index_valid as s \<Longrightarrow> index_valid bs s"
   unfolding index_valid_def by blast
 
 lemma index_valid_distinct_indices: assumes "index_valid as s" 
   and "distinct_indices_atoms as" 
 shows "distinct_indices_state s" 
   unfolding distinct_indices_state_def
 proof (intro allI impI, goal_cases)
   case (1 i x b y c)
   note valid = assms(1)[unfolded index_valid_def, rule_format]
   from 1(1) valid[of x i b] have "(i, Geq x b) \<in> as \<or> (i, Leq x b) \<in> as" by auto
   then obtain a where a: "(i,a) \<in> as" "atom_var a = x" "atom_const a = b" by auto
   from 1(2) valid[of y i c] have y: "(i, Geq y c) \<in> as \<or> (i, Leq y c) \<in> as" by auto
   then obtain a' where a': "(i,a') \<in> as" "atom_var a' = y" "atom_const a' = c" by auto
   from assms(2)[unfolded distinct_indices_atoms_def, rule_format, OF a(1) a'(1)]
   show ?case using a a' by auto
 qed
 
 text\<open>To be a solution of the initial problem, a valuation should
 satisfy the initial tableau and list of atoms. Since tableau is
 changed only by equivalency preserving transformations and asserted
 atoms are encoded in the bounds, a valuation is a solution if it
 satisfies both the tableau and the bounds in the final state (when all
 atoms have been asserted). So, a valuation \<open>v\<close> satisfies a state
 \<open>s\<close> (denoted by \<open>\<Turnstile>\<^sub>s\<close>) if it satisfies the tableau and
 the bounds, i.e., @{thm satisfies_state_def [no_vars]}. Since \<open>\<V>\<close> should be a candidate solution, it should satisfy the state
 (unless the \<open>\<U>\<close> flag is raised). This is denoted by \<open>\<Turnstile> s\<close>
 and defined by @{thm curr_val_satisfies_state_def[no_vars]}. \<open>\<nabla>
 s\<close> will denote that all variables of \<open>\<T> s\<close> are explicitly
 valuated in \<open>\<V> s\<close>.\<close>
 
 definition update\<B>\<I> where
   [simp]: "update\<B>\<I> field_update i x c s = field_update (upd x (i,c)) s"
 
 fun \<B>\<^sub>i\<^sub>u_update where
   "\<B>\<^sub>i\<^sub>u_update up (State T BIL BIU V U UC) = State T BIL (up BIU) V U UC"
 
 fun \<B>\<^sub>i\<^sub>l_update where
   "\<B>\<^sub>i\<^sub>l_update up (State T BIL BIU V U UC) = State T (up BIL) BIU V U UC"
 
 fun \<V>_update where
   "\<V>_update V (State T BIL BIU V_old U UC) = State T BIL BIU V U UC"
 
 fun \<T>_update where
   "\<T>_update T (State T_old BIL BIU V U UC) = State T BIL BIU V U UC"
 
 lemma update_simps[simp]:
   "\<B>\<^sub>i\<^sub>u (\<B>\<^sub>i\<^sub>u_update up s) = up (\<B>\<^sub>i\<^sub>u s)"
   "\<B>\<^sub>i\<^sub>l (\<B>\<^sub>i\<^sub>u_update up s) = \<B>\<^sub>i\<^sub>l s"
   "\<T> (\<B>\<^sub>i\<^sub>u_update up s) = \<T> s"
   "\<V> (\<B>\<^sub>i\<^sub>u_update up s) = \<V> s"
   "\<U> (\<B>\<^sub>i\<^sub>u_update up s) = \<U> s"
   "\<U>\<^sub>c (\<B>\<^sub>i\<^sub>u_update up s) = \<U>\<^sub>c s"
   "\<B>\<^sub>i\<^sub>l (\<B>\<^sub>i\<^sub>l_update up s) = up (\<B>\<^sub>i\<^sub>l s)"
   "\<B>\<^sub>i\<^sub>u (\<B>\<^sub>i\<^sub>l_update up s) = \<B>\<^sub>i\<^sub>u s"
   "\<T> (\<B>\<^sub>i\<^sub>l_update up s) = \<T> s"
   "\<V> (\<B>\<^sub>i\<^sub>l_update up s) = \<V> s"
   "\<U> (\<B>\<^sub>i\<^sub>l_update up s) = \<U> s"
   "\<U>\<^sub>c (\<B>\<^sub>i\<^sub>l_update up s) = \<U>\<^sub>c s"
   "\<V> (\<V>_update V s) = V"
   "\<B>\<^sub>i\<^sub>l (\<V>_update V s) = \<B>\<^sub>i\<^sub>l s"
   "\<B>\<^sub>i\<^sub>u (\<V>_update V s) = \<B>\<^sub>i\<^sub>u s"
   "\<T> (\<V>_update V s) = \<T> s"
   "\<U> (\<V>_update V s) = \<U> s"
   "\<U>\<^sub>c (\<V>_update V s) = \<U>\<^sub>c s"
   "\<T> (\<T>_update T s) = T"
   "\<B>\<^sub>i\<^sub>l (\<T>_update T s) = \<B>\<^sub>i\<^sub>l s"
   "\<B>\<^sub>i\<^sub>u (\<T>_update T s) = \<B>\<^sub>i\<^sub>u s"
   "\<V> (\<T>_update T s) = \<V> s"
   "\<U> (\<T>_update T s) = \<U> s"
   "\<U>\<^sub>c (\<T>_update T s) = \<U>\<^sub>c s"
   by (atomize(full), cases s, auto)
 
 declare
   \<B>\<^sub>i\<^sub>u_update.simps[simp del]
   \<B>\<^sub>i\<^sub>l_update.simps[simp del]
 
 fun set_unsat :: "'i list \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "set_unsat I (State T BIL BIU V U UC) = State T BIL BIU V True (Some (remdups I))"
 
 lemma set_unsat_simps[simp]: "\<B>\<^sub>i\<^sub>l (set_unsat I s) = \<B>\<^sub>i\<^sub>l s"
   "\<B>\<^sub>i\<^sub>u (set_unsat I s) = \<B>\<^sub>i\<^sub>u s"
   "\<T> (set_unsat I s) = \<T> s"
   "\<V> (set_unsat I s) = \<V> s"
   "\<U> (set_unsat I s) = True"
   "\<U>\<^sub>c (set_unsat I s) = Some (remdups I)"
   by (atomize(full), cases s, auto)
 
 datatype ('i,'a) Direction = Direction
   (lt: "'a::linorder \<Rightarrow> 'a \<Rightarrow> bool")
   (LBI: "('i,'a) state \<Rightarrow> ('i,'a) bounds_index")
   (UBI: "('i,'a) state \<Rightarrow> ('i,'a) bounds_index")
   (LB: "('i,'a) state \<Rightarrow> 'a bounds")
   (UB: "('i,'a) state \<Rightarrow> 'a bounds")
   (LI: "('i,'a) state \<Rightarrow> 'i bound_index")
   (UI: "('i,'a) state \<Rightarrow> 'i bound_index")
   (UBI_upd: "(('i,'a) bounds_index \<Rightarrow> ('i,'a) bounds_index) \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state")
   (LE: "var \<Rightarrow> 'a \<Rightarrow> 'a atom")
   (GE: "var \<Rightarrow> 'a \<Rightarrow> 'a atom")
   (le_rat: "rat \<Rightarrow> rat \<Rightarrow> bool")
 
 definition Positive where
   [simp]: "Positive \<equiv> Direction (<) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<I>\<^sub>l \<I>\<^sub>u \<B>\<^sub>i\<^sub>u_update Leq Geq (\<le>)"
 
 definition Negative where
   [simp]: "Negative \<equiv> Direction (>) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<I>\<^sub>u \<I>\<^sub>l \<B>\<^sub>i\<^sub>l_update Geq Leq (\<ge>)"
 
 
 text\<open>Assuming that the \<open>\<U>\<close> flag and the current valuation
 \<open>\<V>\<close> in the final state determine the solution of a problem, the
 \<open>assert_all\<close> function can be reduced to the \<open>assert_all_state\<close>
 function that operates on the states:
 @{text[display] "assert_all t as \<equiv> let s = assert_all_state t as in
    if (\<U> s) then (False, None) else (True, Some (\<V> s))" }
 \<close>
 text\<open>Specification for the \<open>assert_all_state\<close> can be directly
 obtained from the specification of \<open>assert_all\<close>, and it describes
 the connection between the valuation in the final state and the
 initial tableau and atoms. However, we will make an additional
 refinement step and give stronger assumptions about the \<open>assert_all_state\<close> function that describes the connection between
 the initial tableau and atoms with the tableau and bounds in the final
 state.\<close>
 
 locale AssertAllState = fixes assert_all_state::"tableau \<Rightarrow> ('i,'a::lrv) i_atom list \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>The final and the initial tableau are equivalent.\<close>
     assert_all_state_tableau_equiv: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> (v::'a valuation) \<Turnstile>\<^sub>t t \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s'" and
 
 \<comment> \<open>If @{term \<U>} is not raised, then the valuation in the
 final state satisfies its tableau and its bounds (that are, in this
 case, equivalent to the set of all asserted bounds).\<close>
 assert_all_state_sat: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<not> \<U> s' \<Longrightarrow> \<Turnstile> s'" and
 
 assert_all_state_sat_atoms_equiv_bounds: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<not> \<U> s' \<Longrightarrow> flat (set as) \<doteq> \<B> s'" and
 
 \<comment> \<open>If @{term \<U>} is raised, then there is no valuation
    satisfying the tableau and the bounds in the final state (that are,
    in this case, equivalent to a subset of asserted atoms).\<close>
 assert_all_state_unsat: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<U> s' \<Longrightarrow> minimal_unsat_state_core s'"  and
 
 assert_all_state_unsat_atoms_equiv_bounds: "\<triangle> t \<Longrightarrow> assert_all_state t as = s' \<Longrightarrow> \<U> s' \<Longrightarrow> set as \<Turnstile>\<^sub>i \<B>\<I> s'" and
 
 \<comment> \<open>The set of indices is taken from the constraints\<close>
 assert_all_state_indices: "\<triangle> t \<Longrightarrow> assert_all_state t as = s \<Longrightarrow> indices_state s \<subseteq> fst ` set as" and
 
 assert_all_index_valid: "\<triangle> t \<Longrightarrow> assert_all_state t as = s \<Longrightarrow> index_valid (set as) s"
 begin
 definition assert_all where
   "assert_all t as \<equiv> let s = assert_all_state t as in
      if (\<U> s) then Unsat (the (\<U>\<^sub>c s)) else Sat (\<V> s)"
 end
 
 text\<open>The \<open>assert_all_state\<close> function can be implemented by first
 applying the \<open>init\<close> function that creates an initial state based
 on the starting tableau, and then by iteratively applying the \<open>assert\<close> function for each atom in the starting atoms list.\<close>
 
 text\<open>
 \begin{small}
   \<open>assert_loop as s \<equiv> foldl (\<lambda> s' a. if (\<U> s') then s' else assert a s') s as\<close>
 
   \<open>assert_all_state t as \<equiv> assert_loop ats (init t)\<close>
 \end{small}
 \<close>
 
 
 locale Init' =
   fixes init :: "tableau \<Rightarrow> ('i,'a::lrv) state"
   assumes init'_tableau_normalized: "\<triangle> t \<Longrightarrow> \<triangle> (\<T> (init t))"
   assumes init'_tableau_equiv: "\<triangle> t \<Longrightarrow> (v::'a valuation) \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> (init t)"
   assumes init'_sat: "\<triangle> t \<Longrightarrow> \<not> \<U> (init t) \<longrightarrow> \<Turnstile> (init t)"
   assumes init'_unsat: "\<triangle> t \<Longrightarrow> \<U> (init t) \<longrightarrow> minimal_unsat_state_core (init t)"
   assumes init'_atoms_equiv_bounds: "\<triangle> t \<Longrightarrow> {} \<doteq> \<B> (init t)"
   assumes init'_atoms_imply_bounds_index: "\<triangle> t \<Longrightarrow> {} \<Turnstile>\<^sub>i \<B>\<I> (init t)"
 
 
 text\<open>Specification for \<open>init\<close> can be obtained from the
 specification of \<open>asser_all_state\<close> since all its assumptions
 must also hold for \<open>init\<close> (when the list of atoms is
 empty). Also, since \<open>init\<close> is the first step in the \<open>assert_all_state\<close> implementation, the precondition for \<open>init\<close>
 the same as for the \<open>assert_all_state\<close>. However,
 unsatisfiability is never going to be detected during initialization
 and @{term \<U>} flag is never going to be raised. Also, the tableau in
 the initial state can just be initialized with the starting
 tableau. The condition @{term "{} \<doteq> \<B> (init t)"} is equivalent to
 asking that initial bounds are empty. Therefore, specification for
 \<open>init\<close> can be refined to:\<close>
 
 locale Init = fixes init::"tableau \<Rightarrow> ('i,'a::lrv) state"
   assumes
     \<comment> \<open>Tableau in the initial state for @{text t} is @{text t}:\<close> init_tableau_id: "\<T> (init t) = t" and
 
 \<comment> \<open>Since unsatisfiability is not detected, @{text \<U>}
      flag must not be set:\<close> init_unsat_flag: "\<not> \<U> (init t)" and
 
 \<comment> \<open>The current valuation must satisfy the tableau:\<close> init_satisfies_tableau: "\<langle>\<V> (init t)\<rangle> \<Turnstile>\<^sub>t t" and
 
 \<comment> \<open>In an inital state no atoms are yet asserted so the bounds
      must be empty:\<close>
 init_bounds: "\<B>\<^sub>i\<^sub>l (init t) = Mapping.empty"   "\<B>\<^sub>i\<^sub>u (init t) = Mapping.empty"  and
 
 \<comment> \<open>All tableau vars are valuated:\<close> init_tableau_valuated: "\<nabla> (init t)"
 
 begin
 
 
 lemma init_satisfies_bounds:
   "\<langle>\<V> (init t)\<rangle> \<Turnstile>\<^sub>b \<B> (init t)"
   using init_bounds
   unfolding satisfies_bounds.simps in_bounds.simps bound_compare_defs
   by (auto simp: boundsl_def boundsu_def)
 
 lemma init_satisfies:
   "\<Turnstile> (init t)"
   using init_satisfies_tableau init_satisfies_bounds init_tableau_id
   unfolding curr_val_satisfies_state_def satisfies_state_def
   by simp
 
 lemma init_atoms_equiv_bounds:
   "{} \<doteq> \<B> (init t)"
   using init_bounds
   unfolding atoms_equiv_bounds.simps satisfies_bounds.simps in_bounds.simps satisfies_atom_set_def
   unfolding bound_compare_defs
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma init_atoms_imply_bounds_index:
   "{} \<Turnstile>\<^sub>i \<B>\<I> (init t)"
   using init_bounds
   unfolding atoms_imply_bounds_index.simps satisfies_bounds_index.simps in_bounds.simps
     i_satisfies_atom_set.simps satisfies_atom_set_def
   unfolding bound_compare_defs
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 
 lemma init_tableau_normalized:
   "\<triangle> t \<Longrightarrow> \<triangle> (\<T> (init t))"
   using init_tableau_id
   by simp
 
 lemma init_index_valid: "index_valid as (init t)"
   using init_bounds unfolding index_valid_def by auto
 
 lemma init_indices: "indices_state (init t) = {}"
   unfolding indices_state_def init_bounds by auto
 end
 
 
 sublocale Init < Init' init
   using init_tableau_id init_satisfies init_unsat_flag init_atoms_equiv_bounds init_atoms_imply_bounds_index
   by unfold_locales auto
 
 
 
 abbreviation vars_list where
   "vars_list t \<equiv> remdups (map lhs t @ (concat (map (Abstract_Linear_Poly.vars_list \<circ> rhs) t)))"
 
 lemma "tvars t = set (vars_list t)"
   by (auto simp add: set_vars_list lvars_def rvars_def)
 
 
 text\<open>\smallskip The \<open>assert\<close> function asserts a single
 atom. Since the \<open>init\<close> function does not raise the \<open>\<U>\<close>
 flag, from the definition of \<open>assert_loop\<close>, it is clear that the
 flag is not raised when the \<open>assert\<close> function is
 called. Moreover, the assumptions about the \<open>assert_all_state\<close>
 imply that the loop invariant must be that if the \<open>\<U>\<close> flag is
 not raised, then the current valuation must satisfy the state (i.e.,
 \<open>\<Turnstile> s\<close>). The \<open>assert\<close> function will be more easily
 implemented if it is always applied to a state with a normalized and
 valuated tableau, so we make this another loop invariant. Therefore,
 the precondition for the \<open>assert a s\<close> function call is that
 \<open>\<not> \<U> s\<close>, \<open>\<Turnstile> s\<close>, \<open>\<triangle> (\<T> s)\<close> and \<open>\<nabla> s\<close>
 hold. The specification for \<open>assert\<close> directly follows from the
 specification of \<open>assert_all_state\<close> (except that it is
 additionally required that bounds reflect asserted atoms also when
 unsatisfiability is detected, and that it is required that \<open>assert\<close> keeps the tableau normalized and valuated).\<close>
 
 locale Assert = fixes assert::"('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>Tableau remains equivalent to the previous one and normalized and valuated.\<close>
     assert_tableau: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> let s' = assert a s in
      ((v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') \<and> \<nabla> s'" and
 
 \<comment> \<open>If the @{term \<U>} flag is not raised, then the current
    valuation is updated so that it satisfies the current tableau and
    the current bounds.\<close>
 assert_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<not> \<U> (assert a s) \<Longrightarrow> \<Turnstile> (assert a s)" and
 
 \<comment> \<open>The set of asserted atoms remains equivalent to the bounds
     in the state.\<close>
 assert_atoms_equiv_bounds: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert a s)" and
 
 \<comment> \<open>There is a subset of asserted atoms which remains index-equivalent to the bounds
     in the state.\<close>
 assert_atoms_imply_bounds_index: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> ats \<Turnstile>\<^sub>i \<B>\<I> s \<Longrightarrow>
   insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert a s)" and
 
 \<comment> \<open>If the @{term \<U>} flag is raised, then there is no valuation
    that satisfies both the current tableau and the current bounds.\<close>
 assert_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s; index_valid ats s\<rbrakk> \<Longrightarrow> \<U> (assert a s) \<Longrightarrow>  minimal_unsat_state_core (assert a s)" and
 
 assert_index_valid: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> index_valid ats s \<Longrightarrow> index_valid (insert a ats) (assert a s)"
 
 begin
 lemma assert_tableau_equiv: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> (v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (assert a s)"
   using assert_tableau
   by (simp add: Let_def)
 
 lemma assert_tableau_normalized: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<triangle> (\<T> (assert a s))"
   using assert_tableau
   by (simp add: Let_def)
 
 lemma assert_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (assert a s)"
   using assert_tableau
   by (simp add: Let_def)
 end
 
 
 
 locale AssertAllState' = Init init + Assert assert for
   init :: "tableau \<Rightarrow> ('i,'a::lrv) state" and assert :: "('i,'a) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
 begin
 
 definition assert_loop where
   "assert_loop as s \<equiv> foldl (\<lambda> s' a. if (\<U> s') then s' else assert a s') s as"
 
 definition assert_all_state where [simp]:
   "assert_all_state t as \<equiv> assert_loop as (init t)"
 
 
 lemma AssertAllState'_precond:
   "\<triangle> t \<Longrightarrow> \<triangle> (\<T> (assert_all_state t as))
     \<and> (\<nabla> (assert_all_state t as))
     \<and> (\<not> \<U> (assert_all_state t as) \<longrightarrow> \<Turnstile> (assert_all_state t as))"
   unfolding assert_all_state_def assert_loop_def
   using init_satisfies init_tableau_normalized init_index_valid
   using assert_sat assert_tableau_normalized init_tableau_valuated assert_tableau_valuated
   by (induct as rule: rev_induct) auto
 
 lemma AssertAllState'Induct:
   assumes
     "\<triangle> t"
     "P {} (init t)"
     "\<And> as bs t. as \<subseteq> bs \<Longrightarrow> P as t \<Longrightarrow> P bs t"
     "\<And> s a as. \<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s; P as s; index_valid as s\<rbrakk> \<Longrightarrow> P (insert a as) (assert a s)"
   shows "P (set as) (assert_all_state t as)"
 proof -
   have "P (set as) (assert_all_state t as) \<and> index_valid (set as) (assert_all_state t as)"
   proof (induct as rule: rev_induct)
     case Nil
     then show ?case
       unfolding assert_all_state_def assert_loop_def
       using assms(2) init_index_valid by auto
   next
     case (snoc a as')
     let ?f = "\<lambda>s' a. if \<U> s' then s' else assert a s'"
     let ?s = "foldl ?f (init t) as'"
     show ?case
     proof (cases "\<U> ?s")
       case True
       from snoc index_valid_mono[of _ "set (a # as')" "(assert_all_state t as')"]
       have index: "index_valid (set (a # as')) (assert_all_state t as')"
         by auto
       from snoc assms(3)[of "set as'" "set (a # as')"]
       have P: "P (set (a # as')) (assert_all_state t as')" by auto
       show ?thesis
         using True P index
         unfolding assert_all_state_def assert_loop_def
         by simp
     next
       case False
       then show ?thesis
         using snoc
         using assms(1) assms(4)
         using AssertAllState'_precond assert_index_valid
         unfolding assert_all_state_def assert_loop_def
         by auto
     qed
   qed
   then show ?thesis ..
 qed
 
 lemma AssertAllState_index_valid: "\<triangle> t \<Longrightarrow> index_valid (set as) (assert_all_state t as)"
   by (rule AssertAllState'Induct, auto intro: assert_index_valid init_index_valid index_valid_mono)
 
 lemma AssertAllState'_sat_atoms_equiv_bounds:
   "\<triangle> t \<Longrightarrow> \<not> \<U> (assert_all_state t as) \<Longrightarrow> flat (set as) \<doteq> \<B> (assert_all_state t as)"
   using AssertAllState'_precond
   using init_atoms_equiv_bounds assert_atoms_equiv_bounds
   unfolding assert_all_state_def assert_loop_def
   by (induct as rule: rev_induct) auto
 
 lemma AssertAllState'_unsat_atoms_implies_bounds:
   assumes "\<triangle> t"
   shows "set as \<Turnstile>\<^sub>i \<B>\<I> (assert_all_state t as)"
 proof (induct as rule: rev_induct)
   case Nil
   then show ?case
     using assms init_atoms_imply_bounds_index
     unfolding assert_all_state_def assert_loop_def
     by simp
 next
   case (snoc a as')
   let ?s = "assert_all_state t as'"
   show ?case
   proof (cases "\<U> ?s")
     case True
     then show ?thesis
       using snoc atoms_imply_bounds_index_mono[of "set as'" "set (as' @ [a])"]
       unfolding assert_all_state_def assert_loop_def
       by auto
   next
     case False
     then have id: "assert_all_state t (as' @ [a]) = assert a ?s"
       unfolding assert_all_state_def assert_loop_def by simp
     from snoc have as': "set as' \<Turnstile>\<^sub>i \<B>\<I> ?s" by auto
     from AssertAllState'_precond[of t as'] assms False
     have "\<Turnstile> ?s" "\<triangle> (\<T> ?s)" "\<nabla> ?s" by auto
     from assert_atoms_imply_bounds_index[OF False this as', of a]
     show ?thesis unfolding id by auto
   qed
 qed
 
 end
 
 text\<open>Under these assumptions, it can easily be shown (mainly by
 induction) that the previously shown implementation of \<open>assert_all_state\<close> satisfies its specification.\<close>
 
 sublocale AssertAllState' < AssertAllState assert_all_state
 proof
   fix v::"'a valuation" and t as s'
   assume *: "\<triangle> t" and id: "assert_all_state t as = s'"
   note idsym = id[symmetric]
 
   show "v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> s'" unfolding idsym
     using  init_tableau_id[of t] assert_tableau_equiv[of _ v]
     by (induct rule: AssertAllState'Induct) (auto simp add: * )
 
   show "\<not> \<U> s' \<Longrightarrow> \<Turnstile> s'" unfolding idsym
     using AssertAllState'_precond by (simp add: * )
 
   show "\<not> \<U> s' \<Longrightarrow> flat (set as) \<doteq> \<B> s'"
     unfolding idsym
     using *
     by (rule AssertAllState'_sat_atoms_equiv_bounds)
 
   show "\<U> s' \<Longrightarrow> set as \<Turnstile>\<^sub>i \<B>\<I> s'"
     using * unfolding idsym
     by (rule AssertAllState'_unsat_atoms_implies_bounds)
 
   show "\<U> s' \<Longrightarrow> minimal_unsat_state_core s'"
     using init_unsat_flag assert_unsat assert_index_valid unfolding idsym
     by (induct rule: AssertAllState'Induct) (auto simp add: * )
 
   show "indices_state s' \<subseteq> fst ` set as" unfolding idsym using *
     by (intro index_valid_indices_state, induct rule: AssertAllState'Induct,
         auto simp: init_index_valid index_valid_mono assert_index_valid)
 
   show "index_valid (set as) s'" using "*" AssertAllState_index_valid idsym by blast
 qed
 
 
 subsection\<open>Asserting Single Atoms\<close>
 
 text\<open>The @{term assert} function is split in two phases. First,
 @{term assert_bound} updates the bounds and checks only for conflicts
 cheap to detect. Next, \<open>check\<close> performs the full simplex
 algorithm. The \<open>assert\<close> function can be implemented as \<open>assert a s = check (assert_bound a s)\<close>. Note that it is also
 possible to do the first phase for several asserted atoms, and only
 then to let the expensive second phase work.
 
 \medskip Asserting an atom \<open>x \<bowtie> b\<close> begins with the function
 \<open>assert_bound\<close>.  If the atom is subsumed by the current bounds,
 then no changes are performed. Otherwise, bounds for \<open>x\<close> are
 changed to incorporate the atom. If the atom is inconsistent with the
 previous bounds for \<open>x\<close>, the @{term \<U>} flag is raised. If
 \<open>x\<close> is not a lhs variable in the current tableau and if the
 value for \<open>x\<close> in the current valuation violates the new bound
 \<open>b\<close>, the value for \<open>x\<close> can be updated and set to
 \<open>b\<close>, meanwhile updating the values for lhs variables of
 the tableau so that it remains satisfied. Otherwise, no changes to the
 current valuation are performed.\<close>
 
 fun satisfies_bounds_set  :: "'a::linorder valuation \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> var set \<Rightarrow> bool" where
   "satisfies_bounds_set v (lb, ub) S \<longleftrightarrow> (\<forall> x \<in> S. in_bounds x v (lb, ub))"
 declare satisfies_bounds_set.simps [simp del]
 syntax
   "_satisfies_bounds_set" :: "(var \<Rightarrow> 'a::linorder) \<Rightarrow> 'a bounds \<times> 'a bounds \<Rightarrow> var set \<Rightarrow> bool"    ("_ \<Turnstile>\<^sub>b _ \<parallel>/ _")
 translations
   "v \<Turnstile>\<^sub>b b \<parallel> S" == "CONST satisfies_bounds_set v b S"
 lemma satisfies_bounds_set_iff:
   "v \<Turnstile>\<^sub>b (lb, ub) \<parallel> S \<equiv> (\<forall> x \<in> S. v x \<ge>\<^sub>l\<^sub>b lb x \<and> v x \<le>\<^sub>u\<^sub>b ub x)"
   by (simp add: satisfies_bounds_set.simps)
 
 
 definition curr_val_satisfies_no_lhs ("\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s") where
   "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s \<equiv> \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t (\<T> s) \<and> (\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>b (\<B> s) \<parallel> (- lvars (\<T> s)))"
 lemma satisfies_satisfies_no_lhs:
   "\<Turnstile> s \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s"
   by (simp add: curr_val_satisfies_state_def satisfies_state_def curr_val_satisfies_no_lhs_def satisfies_bounds.simps satisfies_bounds_set.simps)
 
 
 definition bounds_consistent :: "('i,'a::linorder) state \<Rightarrow> bool" ("\<diamond>") where
   "\<diamond> s \<equiv>
    \<forall> x. if \<B>\<^sub>l s x = None \<or> \<B>\<^sub>u s x = None then True else the (\<B>\<^sub>l s x) \<le> the (\<B>\<^sub>u s x)"
 
 
 text\<open>So, the \<open>assert_bound\<close> function must ensure that the
 given atom is included in the bounds, that the tableau remains
 satisfied by the valuation and that all variables except the lhs variables
 in the tableau are within their
 bounds. To formalize this, we introduce the notation \<open>v
 \<Turnstile>\<^sub>b (lb, ub) \<parallel> S\<close>, and define @{thm
 satisfies_bounds_set_iff[no_vars]}, and @{thm
 curr_val_satisfies_no_lhs_def[no_vars]}. The \<open>assert_bound\<close>
 function raises the \<open>\<U>\<close> flag if and only if lower and upper
 bounds overlap. This is formalized as @{thm
 bounds_consistent_def[no_vars]}.\<close>
 
 
 lemma satisfies_bounds_consistent:
   "(v::'a::linorder valuation) \<Turnstile>\<^sub>b \<B> s \<longrightarrow> \<diamond> s"
   unfolding satisfies_bounds.simps in_bounds.simps bounds_consistent_def bound_compare_defs
   by (auto split: option.split) force
 
 lemma satisfies_consistent:
   "\<Turnstile> s \<longrightarrow> \<diamond> s"
   by (auto simp add: curr_val_satisfies_state_def satisfies_state_def satisfies_bounds_consistent)
 
 lemma bounds_consistent_geq_lb:
   "\<lbrakk>\<diamond> s; \<B>\<^sub>u s x\<^sub>i = Some c\<rbrakk>
     \<Longrightarrow> c \<ge>\<^sub>l\<^sub>b \<B>\<^sub>l s x\<^sub>i"
   unfolding bounds_consistent_def
   by (cases "\<B>\<^sub>l s x\<^sub>i", auto simp add: bound_compare_defs split: if_splits)
     (erule_tac x="x\<^sub>i" in allE, auto)
 
 lemma bounds_consistent_leq_ub:
   "\<lbrakk>\<diamond> s; \<B>\<^sub>l s x\<^sub>i = Some c\<rbrakk>
     \<Longrightarrow> c \<le>\<^sub>u\<^sub>b \<B>\<^sub>u s x\<^sub>i"
   unfolding bounds_consistent_def
   by (cases "\<B>\<^sub>u s x\<^sub>i", auto simp add: bound_compare_defs split: if_splits)
     (erule_tac x="x\<^sub>i" in allE, auto)
 
 lemma bounds_consistent_gt_ub:
   "\<lbrakk>\<diamond> s; c <\<^sub>l\<^sub>b \<B>\<^sub>l s x \<rbrakk> \<Longrightarrow> \<not> c >\<^sub>u\<^sub>b \<B>\<^sub>u s x"
   unfolding bounds_consistent_def
   by (case_tac[!] "\<B>\<^sub>l s x", case_tac[!] "\<B>\<^sub>u s x")
     (auto simp add: bound_compare_defs, erule_tac x="x" in allE, simp)
 
 lemma bounds_consistent_lt_lb:
   "\<lbrakk>\<diamond> s; c >\<^sub>u\<^sub>b \<B>\<^sub>u s x \<rbrakk> \<Longrightarrow> \<not> c <\<^sub>l\<^sub>b \<B>\<^sub>l s x"
   unfolding bounds_consistent_def
   by (case_tac[!] "\<B>\<^sub>l s x", case_tac[!] "\<B>\<^sub>u s x")
     (auto simp add: bound_compare_defs, erule_tac x="x" in allE, simp)
 
 
 text\<open>Since the \<open>assert_bound\<close> is the first step in the \<open>assert\<close> function implementation, the preconditions for \<open>assert_bound\<close> are the same as preconditions for the \<open>assert\<close>
 function. The specifiction for the \<open>assert_bound\<close> is:\<close>
 
 locale AssertBound = fixes assert_bound::"('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>The tableau remains unchanged and valuated.\<close>
 
 assert_bound_tableau: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> assert_bound a s = s' \<Longrightarrow> \<T> s' = \<T> s \<and> \<nabla> s'" and
 
 \<comment> \<open>If the @{term \<U>} flag is not set, all but the
    lhs variables in the tableau remain within their bounds,
    the new valuation satisfies the tableau, and bounds do not overlap.\<close>
 assert_bound_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> assert_bound a s = s' \<Longrightarrow> \<not> \<U> s' \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<and> \<diamond> s'" and
 
 \<comment> \<open>The set of asserted atoms remains equivalent to the bounds in the state.\<close>
 
 assert_bound_atoms_equiv_bounds: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
   flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert_bound a s)" and
 
 assert_bound_atoms_imply_bounds_index: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
   ats \<Turnstile>\<^sub>i \<B>\<I> s \<Longrightarrow> insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound a s)" and
 
 \<comment> \<open>@{term \<U>} flag is raised, only if the bounds became inconsistent:\<close>
 
 assert_bound_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> index_valid as s \<Longrightarrow> assert_bound a s = s' \<Longrightarrow> \<U> s' \<Longrightarrow> minimal_unsat_state_core s'" and
 
 assert_bound_index_valid: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> index_valid as s \<Longrightarrow> index_valid (insert a as) (assert_bound a s)"
 
 begin
 lemma assert_bound_tableau_id: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<T> (assert_bound a s) = \<T> s"
   using assert_bound_tableau by blast
 
 lemma assert_bound_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (assert_bound a s)"
   using assert_bound_tableau by blast
 
 end
 
 locale AssertBoundNoLhs =
   fixes assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes assert_bound_nolhs_tableau_id: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow> \<T> (assert_bound a s) = \<T> s"
   assumes assert_bound_nolhs_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     \<not> \<U> (assert_bound a s) \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound a s) \<and> \<diamond> (assert_bound a s)"
   assumes assert_bound_nolhs_atoms_equiv_bounds: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert_bound a s)"
   assumes assert_bound_nolhs_atoms_imply_bounds_index: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     ats \<Turnstile>\<^sub>i \<B>\<I> s \<Longrightarrow> insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound a s)"
   assumes assert_bound_nolhs_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     index_valid as s \<Longrightarrow> \<U> (assert_bound a s) \<Longrightarrow> minimal_unsat_state_core (assert_bound a s)"
   assumes assert_bound_nolhs_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
    \<nabla> (assert_bound a s)"
   assumes assert_bound_nolhs_index_valid: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s\<rbrakk> \<Longrightarrow>
     index_valid as s \<Longrightarrow> index_valid (insert a as) (assert_bound a s)"
 
 sublocale AssertBoundNoLhs < AssertBound 
   by unfold_locales
     ((metis satisfies_satisfies_no_lhs satisfies_consistent
         assert_bound_nolhs_tableau_id assert_bound_nolhs_sat assert_bound_nolhs_atoms_equiv_bounds
         assert_bound_nolhs_index_valid assert_bound_nolhs_atoms_imply_bounds_index
         assert_bound_nolhs_unsat assert_bound_nolhs_tableau_valuated)+) 
 
 
 text\<open>The second phase of \<open>assert\<close>, the \<open>check\<close> function,
 is the heart of the Simplex algorithm. It is always called after
 \<open>assert_bound\<close>, but in two different situations. In the first
 case \<open>assert_bound\<close> raised the \<open>\<U>\<close> flag and then
 \<open>check\<close> should retain the flag and should not perform any changes.
 In the second case \<open>assert_bound\<close> did not raise the
 \<open>\<U>\<close> flag, so \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close>, \<open>\<diamond> s\<close>, \<open>\<triangle> (\<T>
 s)\<close>, and \<open>\<nabla> s\<close> hold.\<close>
 
 locale Check = fixes check::"('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>If @{text check} is called from an inconsistent state, the state is unchanged.\<close>
 
 check_unsat_id: "\<U> s \<Longrightarrow> check s = s"  and
 
 \<comment> \<open>The tableau remains equivalent to the previous one, normalized and valuated.\<close>
 
 check_tableau:  "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
    let s' = check s in ((v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') \<and> \<nabla> s'" and
 
 \<comment> \<open>The bounds remain unchanged.\<close>
 
 check_bounds_id:  "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<B>\<^sub>i (check s) = \<B>\<^sub>i s"  and
 
 \<comment> \<open>If @{term \<U>} flag is not raised, the current valuation
    @{text "\<V>"} satisfies both the tableau and the bounds and if it is
    raised, there is no valuation that satisfies them.\<close>
 
 check_sat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<not> \<U> (check s) \<Longrightarrow> \<Turnstile> (check s)"  and
 
 
 check_unsat: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<U> (check s) \<Longrightarrow> minimal_unsat_state_core (check s)"
 
 begin
 
 lemma check_tableau_equiv: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow>
                       (v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (check s)"
   using check_tableau
   by (simp add: Let_def)
 
 lemma check_tableau_index_valid: assumes "\<not> \<U> s" " \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" "\<triangle> (\<T> s)" "\<nabla> s"
   shows "index_valid as (check s) = index_valid as s"
   unfolding index_valid_def using check_bounds_id[OF assms]
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 
 lemma check_tableau_normalized: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<triangle> (\<T> (check s))"
   using check_tableau
   by (simp add: Let_def)
 
 lemma check_tableau_valuated: "\<lbrakk>\<not> \<U> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<triangle> (\<T> s); \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (check s)"
   using check_tableau
   by (simp add: Let_def)
 
 lemma check_indices_state: assumes "\<not> \<U> s \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<not> \<U> s \<Longrightarrow> \<diamond> s" "\<not> \<U> s \<Longrightarrow> \<triangle> (\<T> s)" "\<not> \<U> s \<Longrightarrow> \<nabla> s"
   shows "indices_state (check s) = indices_state s" 
   using check_bounds_id[OF _ assms] check_unsat_id[of s]
   unfolding indices_state_def by (cases "\<U> s", auto)
 
 lemma check_distinct_indices_state: assumes "\<not> \<U> s \<Longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<not> \<U> s \<Longrightarrow> \<diamond> s" "\<not> \<U> s \<Longrightarrow> \<triangle> (\<T> s)" "\<not> \<U> s \<Longrightarrow> \<nabla> s"
   shows "distinct_indices_state (check s) = distinct_indices_state s" 
   using check_bounds_id[OF _ assms] check_unsat_id[of s]
   unfolding distinct_indices_state_def by (cases "\<U> s", auto)
   
 end
 
 
 locale Assert' = AssertBound assert_bound + Check check for
   assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" and
   check :: "('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
 begin
 definition assert :: "('i,'a) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "assert a s \<equiv> check (assert_bound a s)"
 
 lemma Assert'Precond:
   assumes "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   shows
     "\<triangle> (\<T> (assert_bound a s))"
     "\<not> \<U> (assert_bound a s) \<Longrightarrow>  \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound a s) \<and> \<diamond> (assert_bound a s)"
     "\<nabla> (assert_bound a s)"
   using assms
   using assert_bound_tableau_id assert_bound_sat assert_bound_tableau_valuated
   by (auto simp add: satisfies_bounds_consistent Let_def)
 end
 
 
 sublocale Assert' < Assert assert
 proof
   fix s::"('i,'a) state" and v::"'a valuation" and  a::"('i,'a) i_atom"
   assume *: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   have "\<triangle> (\<T> (assert a s))"
     using check_tableau_normalized[of "assert_bound a s"] check_unsat_id[of "assert_bound a s"] *
     using assert_bound_sat[of s a] Assert'Precond[of s a]
     by (force simp add: assert_def)
   moreover
   have "v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> (assert a s)"
     using check_tableau_equiv[of "assert_bound a s" v] *
     using check_unsat_id[of "assert_bound a s"]
     by (force simp add: assert_def Assert'Precond assert_bound_sat assert_bound_tableau_id)
   moreover
   have "\<nabla> (assert a s)"
     using assert_bound_tableau_valuated[of s a] *
     using check_tableau_valuated[of "assert_bound a s"]
     using check_unsat_id[of "assert_bound a s"]
     by (cases "\<U> (assert_bound a s)") (auto simp add: Assert'Precond assert_def)
   ultimately
   show "let s' = assert a s in (v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') \<and> \<nabla> s'"
     by (simp add: Let_def)
 next
   fix s::"('i,'a) state" and a::"('i,'a) i_atom"
   assume "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   then show "\<not> \<U> (assert a s) \<Longrightarrow> \<Turnstile> (assert a s)"
     unfolding assert_def
     using check_unsat_id[of "assert_bound a s"]
     using check_sat[of "assert_bound a s"]
     by (force simp add: Assert'Precond)
 next
   fix s::"('i,'a) state" and a::"('i,'a) i_atom" and ats::"('i,'a) i_atom set"
   assume "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   then show "flat ats \<doteq> \<B> s \<Longrightarrow> flat (ats \<union> {a}) \<doteq> \<B> (assert a s)"
     using assert_bound_atoms_equiv_bounds
     using check_unsat_id[of "assert_bound a s"] check_bounds_id
     by (cases "\<U> (assert_bound a s)") (auto simp add: Assert'Precond assert_def
         simp: indexl_def indexu_def boundsl_def boundsu_def)
 next
   fix s::"('i,'a) state" and a::"('i,'a) i_atom" and ats
   assume *: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s" "\<U> (assert a s)" "index_valid ats s"
   show "minimal_unsat_state_core (assert a s)"
   proof (cases "\<U> (assert_bound a s)")
     case True
     then show ?thesis
       unfolding assert_def
       using * assert_bound_unsat check_tableau_equiv[of "assert_bound a s"] check_bounds_id
       using check_unsat_id[of "assert_bound a s"]
       by (auto simp add: Assert'Precond satisfies_state_def Let_def)
   next
     case False
     then show ?thesis
       unfolding assert_def
       using * assert_bound_sat[of s a] check_unsat Assert'Precond
       by (metis assert_def)
   qed
 next
   fix ats
   fix s::"('i,'a) state" and a::"('i,'a) i_atom"
   assume *: "index_valid ats s"
     and **: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s"
   have *: "index_valid (insert a ats) (assert_bound a s)"
     using assert_bound_index_valid[OF ** *] .
   show "index_valid (insert a ats) (assert a s)"
   proof (cases "\<U> (assert_bound a s)")
     case True
     show ?thesis unfolding assert_def check_unsat_id[OF True] using * .
   next
     case False
     show ?thesis unfolding assert_def using Assert'Precond[OF **, of a] False *
       by (subst check_tableau_index_valid[OF False], auto)
   qed
 next
   fix s ats a
   let ?s = "assert_bound a s"
   assume *: "\<not> \<U> s" "\<Turnstile> s" "\<triangle> (\<T> s)" "\<nabla> s" "ats \<Turnstile>\<^sub>i \<B>\<I> s"
   from assert_bound_atoms_imply_bounds_index[OF this, of a]
   have as: "insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound a s)" by auto
   show "insert a ats \<Turnstile>\<^sub>i \<B>\<I> (assert a s)"
   proof (cases "\<U> ?s")
     case True
     from check_unsat_id[OF True] as show ?thesis unfolding assert_def by auto
   next
     case False
     from assert_bound_tableau_id[OF *(1-4)] *
     have t: "\<triangle> (\<T> ?s)" by simp
     from assert_bound_tableau_valuated[OF *(1-4)]
     have v: "\<nabla> ?s" .
     from assert_bound_sat[OF *(1-4) refl False]
     have "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s" "\<diamond> ?s" by auto
     from check_bounds_id[OF False this t v]  as
     show ?thesis unfolding assert_def
       by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
   qed
 qed
 
 text\<open>Under these assumptions for \<open>assert_bound\<close> and \<open>check\<close>, it can be easily shown that the implementation of \<open>assert\<close> (previously given) satisfies its specification.\<close>
 
 locale AssertAllState'' = Init init + AssertBoundNoLhs assert_bound + Check check for
   init :: "tableau \<Rightarrow> ('i,'a::lrv) state" and
   assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" and
   check :: "('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
 begin
 definition assert_bound_loop where
   "assert_bound_loop ats s \<equiv> foldl (\<lambda> s' a. if (\<U> s') then s' else assert_bound a s') s ats"
 definition assert_all_state where [simp]:
   "assert_all_state t ats \<equiv> check (assert_bound_loop ats (init t))"
 
 text\<open>However, for efficiency reasons, we want to allow
 implementations that delay the \<open>check\<close> function call and call it
 after several \<open>assert_bound\<close> calls. For example:
 
 \smallskip
 \begin{small}
 @{thm assert_bound_loop_def[no_vars]}
 
 @{thm assert_all_state_def[no_vars]}
 \end{small}
 \smallskip
 
 Then, the loop consists only of \<open>assert_bound\<close> calls, so \<open>assert_bound\<close> postcondition must imply its precondition. This is not
 the case, since variables on the lhs may be out of their
 bounds. Therefore, we make a refinement and specify weaker
 preconditions (replace \<open>\<Turnstile> s\<close>, by \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s\<close> and \<open>\<diamond> s\<close>) for \<open>assert_bound\<close>, and show that these
 preconditions are still good enough to prove the correctnes of this
 alternative \<open>assert_all_state\<close> definition.\<close>
 
 
 lemma AssertAllState''_precond':
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "\<not> \<U> s \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s \<and> \<diamond> s"
   shows "let s' = assert_bound_loop ats s in
          \<triangle> (\<T> s') \<and> \<nabla> s' \<and> (\<not> \<U> s' \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<and> \<diamond> s')"
   using assms
   using assert_bound_nolhs_tableau_id assert_bound_nolhs_sat assert_bound_nolhs_tableau_valuated
   by (induct ats rule: rev_induct) (auto simp add: assert_bound_loop_def Let_def)
 
 lemma AssertAllState''_precond:
   assumes "\<triangle> t"
   shows "let s' = assert_bound_loop ats (init t) in
          \<triangle> (\<T> s') \<and> \<nabla> s' \<and> (\<not> \<U> s' \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s' \<and> \<diamond> s')"
   using assms
   using AssertAllState''_precond'[of "init t" ats]
   by (simp add: Let_def init_tableau_id init_unsat_flag init_satisfies satisfies_consistent
       satisfies_satisfies_no_lhs init_tableau_valuated)
 
 lemma AssertAllState''Induct:
   assumes
     "\<triangle> t"
     "P {} (init t)"
     "\<And> as bs t. as \<subseteq> bs \<Longrightarrow> P as t \<Longrightarrow> P bs t"
     "\<And> s a ats. \<lbrakk>\<not> \<U> s;  \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s; \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<triangle> (\<T> s); \<nabla> s; \<diamond> s; P (set ats) s; index_valid (set ats) s\<rbrakk>
       \<Longrightarrow> P (insert a (set ats)) (assert_bound a s)"
   shows "P (set ats) (assert_bound_loop ats (init t))"
 proof -
   have "P (set ats) (assert_bound_loop ats (init t)) \<and> index_valid (set ats) (assert_bound_loop ats (init t))"
   proof (induct ats rule: rev_induct)
     case Nil
     then show ?case
       unfolding assert_bound_loop_def
       using assms(2) init_index_valid
       by simp
   next
     case (snoc a as')
     let ?s = "assert_bound_loop as' (init t)"
     from snoc index_valid_mono[of _ "set (a # as')" "assert_bound_loop as' (init t)"]
     have index: "index_valid (set (a # as')) (assert_bound_loop as' (init t))"
       by auto
     from snoc assms(3)[of "set as'" "set (a # as')"]
     have P: "P (set (a # as')) (assert_bound_loop as' (init t))" by auto
     show ?case
     proof (cases "\<U> ?s")
       case True
       then show ?thesis
         using P index
         unfolding assert_bound_loop_def
         by simp
     next
       case False
       have id': "set (as' @ [a]) = insert a (set as')" by simp
       have id: "assert_bound_loop (as' @ [a]) (init t) =
         assert_bound a (assert_bound_loop as' (init t))"
         using False unfolding assert_bound_loop_def by auto
       from snoc have index: "index_valid (set as') ?s" by simp
       show ?thesis unfolding id unfolding id' using False snoc AssertAllState''_precond[OF assms(1)]
         by (intro conjI assert_bound_nolhs_index_valid index assms(4); (force simp: Let_def curr_val_satisfies_no_lhs_def)?)
     qed
   qed
   then show ?thesis ..
 qed
 
 lemma AssertAllState''_tableau_id:
   "\<triangle> t \<Longrightarrow> \<T> (assert_bound_loop ats (init t)) = \<T> (init t)"
   by (rule AssertAllState''Induct) (auto simp add: init_tableau_id assert_bound_nolhs_tableau_id)
 
 lemma AssertAllState''_sat:
   "\<triangle> t \<Longrightarrow>
     \<not> \<U> (assert_bound_loop ats (init t)) \<longrightarrow> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (assert_bound_loop ats (init t)) \<and> \<diamond> (assert_bound_loop ats (init t))"
   by (rule AssertAllState''Induct) (auto simp add: init_unsat_flag init_satisfies satisfies_consistent satisfies_satisfies_no_lhs assert_bound_nolhs_sat)
 
 lemma AssertAllState''_unsat:
   "\<triangle> t \<Longrightarrow> \<U> (assert_bound_loop ats (init t)) \<longrightarrow> minimal_unsat_state_core (assert_bound_loop ats (init t))"
   by (rule AssertAllState''Induct)
     (auto simp add: init_tableau_id assert_bound_nolhs_unsat init_unsat_flag)
 
 lemma AssertAllState''_sat_atoms_equiv_bounds:
   "\<triangle> t \<Longrightarrow> \<not> \<U> (assert_bound_loop ats (init t)) \<longrightarrow> flat (set ats) \<doteq> \<B> (assert_bound_loop ats (init t))"
   using AssertAllState''_precond
   using assert_bound_nolhs_atoms_equiv_bounds init_atoms_equiv_bounds
   by (induct ats rule: rev_induct) (auto simp add: Let_def assert_bound_loop_def)
 
 lemma AssertAllState''_atoms_imply_bounds_index:
   assumes "\<triangle> t"
   shows "set ats \<Turnstile>\<^sub>i \<B>\<I> (assert_bound_loop ats (init t))"
 proof (induct ats rule: rev_induct)
   case Nil
   then show ?case
     unfolding assert_bound_loop_def
     using init_atoms_imply_bounds_index assms
     by simp
 next
   case (snoc a ats')
   let ?s = "assert_bound_loop ats' (init t)"
   show ?case
   proof (cases "\<U> ?s")
     case True
     then show ?thesis
       using snoc atoms_imply_bounds_index_mono[of "set ats'" "set (ats' @ [a])"]
       unfolding assert_bound_loop_def
       by auto
   next
     case False
     then have id: "assert_bound_loop (ats' @ [a]) (init t) = assert_bound a ?s"
       unfolding assert_bound_loop_def by auto
     from snoc have ats: "set ats' \<Turnstile>\<^sub>i \<B>\<I> ?s" by auto
     from AssertAllState''_precond[of t ats', OF assms, unfolded Let_def] False
     have *: "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?s" "\<triangle> (\<T> ?s)" "\<nabla> ?s" "\<diamond> ?s" by auto
     show ?thesis unfolding id using assert_bound_nolhs_atoms_imply_bounds_index[OF False * ats, of a] by auto
   qed
 qed 
 
 lemma AssertAllState''_index_valid:
   "\<triangle> t \<Longrightarrow> index_valid (set ats) (assert_bound_loop ats (init t))"
   by (rule AssertAllState''Induct, auto simp: init_index_valid index_valid_mono assert_bound_nolhs_index_valid)
 
 end
 
 sublocale AssertAllState'' < AssertAllState assert_all_state
 proof
   fix v::"'a valuation" and t ats s'
   assume *: "\<triangle> t" and "assert_all_state t ats = s'"
   then have s': "s' = assert_all_state t ats" by simp
   let ?s' = "assert_bound_loop ats (init t)"
   show "v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> s'"
     unfolding assert_all_state_def s'
     using * check_tableau_equiv[of ?s' v] AssertAllState''_tableau_id[of t ats] init_tableau_id[of t]
     using AssertAllState''_sat[of t ats] check_unsat_id[of ?s']
     using AssertAllState''_precond[of t ats]
     by force
 
   show "\<not> \<U> s' \<Longrightarrow> \<Turnstile> s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats]
     using check_sat check_unsat_id
     by (force simp add: Let_def)
 
   show "\<U> s' \<Longrightarrow> minimal_unsat_state_core s'"
     using * check_unsat check_unsat_id[of ?s'] check_bounds_id
     using AssertAllState''_unsat[of t ats] AssertAllState''_precond[of t ats] s'
     by (force simp add: Let_def satisfies_state_def)
 
   show "\<not> \<U> s' \<Longrightarrow> flat (set ats) \<doteq> \<B> s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats]
     using check_bounds_id[of ?s'] check_unsat_id[of ?s']
     using AssertAllState''_sat_atoms_equiv_bounds[of t ats]
     by (force simp add: Let_def simp: indexl_def indexu_def boundsl_def boundsu_def)
 
   show "\<U> s' \<Longrightarrow> set ats \<Turnstile>\<^sub>i \<B>\<I> s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats]
     unfolding Let_def
     using check_bounds_id[of ?s']
     using AssertAllState''_atoms_imply_bounds_index[of t ats]
     using check_unsat_id[of ?s']
     by (cases "\<U> ?s'") (auto simp add: Let_def simp: indexl_def indexu_def boundsl_def boundsu_def)
 
   show "index_valid (set ats) s'"
     unfolding assert_all_state_def s'
     using * AssertAllState''_precond[of t ats] AssertAllState''_index_valid[OF *, of ats]
     unfolding Let_def
     using check_tableau_index_valid[of ?s']
     using check_unsat_id[of ?s']
     by (cases "\<U> ?s'", auto)
 
   show "indices_state s' \<subseteq> fst ` set ats"
     by (intro index_valid_indices_state, fact)
 qed
 
 
 subsection\<open>Update and Pivot\<close>
 
 text\<open>Both \<open>assert_bound\<close> and \<open>check\<close> need to update
 the valuation so that the tableau remains satisfied. If the value for
 a variable not on the lhs of the tableau is changed, this
 can be done rather easily (once the value of that variable is changed,
 one should recalculate and change the values for all lhs
 variables of the tableau). The \<open>update\<close> function does this, and
 it is specified by:\<close>
 
 locale Update = fixes update::"var \<Rightarrow> 'a::lrv \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>Tableau, bounds, and the unsatisfiability flag are preserved.\<close>
 
 update_id:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow>
      let s' = update x c s in \<T> s' = \<T> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s" and
 
 \<comment> \<open>Tableau remains valuated.\<close>
 
 update_tableau_valuated:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<nabla> (update x v s)"  and
 
 \<comment> \<open>The given variable @{text "x"} in the updated valuation is
    set to the given value @{text "v"} while all other variables
    (except those on the lhs of the tableau) are
    unchanged.\<close>
 
 update_valuation_nonlhs:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> x' \<notin> lvars (\<T> s) \<longrightarrow>
        look (\<V> (update x v s)) x' = (if x = x' then Some v else look (\<V> s) x')" and
 
 \<comment> \<open>Updated valuation continues to satisfy the tableau.\<close>
 
 update_satisfies_tableau:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow>  \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<longrightarrow> \<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>t \<T> s"
 
 begin
 lemma update_bounds_id:
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   shows "\<B>\<^sub>i (update x c s) = \<B>\<^sub>i s"
     "\<B>\<I> (update x c s) = \<B>\<I> s"
     "\<B>\<^sub>l (update x c s) = \<B>\<^sub>l s"
     "\<B>\<^sub>u (update x c s) = \<B>\<^sub>u s"
   using update_id assms
   by (auto simp add: Let_def simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma update_indices_state_id:
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   shows "indices_state (update x c s) = indices_state s" 
   using update_bounds_id[OF assms] unfolding indices_state_def by auto
 
 lemma update_tableau_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<T> (update x c s) = \<T> s"
   using update_id
   by (auto simp add: Let_def)
 
 lemma update_unsat_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<U> (update x c s) = \<U> s"
   using update_id
   by (auto simp add: Let_def)
 
 lemma update_unsat_core_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x \<notin> lvars (\<T> s)\<rbrakk> \<Longrightarrow> \<U>\<^sub>c (update x c s) = \<U>\<^sub>c s"
   using update_id
   by (auto simp add: Let_def)
 
 definition assert_bound' where
   [simp]: "assert_bound' dir i x c s \<equiv>
        (if (\<unrhd>\<^sub>u\<^sub>b (lt dir)) c (UB dir s x) then s
           else let s' = update\<B>\<I> (UBI_upd dir) i x c s in
              if (\<lhd>\<^sub>l\<^sub>b (lt dir)) c ((LB dir) s x) then
                   set_unsat [i, ((LI dir) s x)] s'
              else if x \<notin> lvars (\<T> s') \<and> (lt dir) c (\<langle>\<V> s\<rangle> x) then
                   update x c s'
              else
                   s')"
 
 fun assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "assert_bound (i,Leq x c) s = assert_bound' Positive i x c s"
 | "assert_bound (i,Geq x c) s = assert_bound' Negative i x c s"
 
 lemma assert_bound'_cases:
   assumes "\<lbrakk>\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<rbrakk> \<Longrightarrow> P s"
   assumes "\<lbrakk>\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<rbrakk> \<Longrightarrow>
      P (set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<lbrakk>x \<notin> lvars (\<T> s); (lt dir) c (\<langle>\<V> s\<rangle> x); \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x))\<rbrakk> \<Longrightarrow>
      P (update x c (update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<lbrakk>\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)); x \<in> lvars (\<T> s)\<rbrakk> \<Longrightarrow>
      P (update\<B>\<I> (UBI_upd dir) i x c s)"
   assumes "\<lbrakk>\<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)); \<not> ((lt dir) c (\<langle>\<V> s\<rangle> x))\<rbrakk> \<Longrightarrow>
      P (update\<B>\<I> (UBI_upd dir) i x c s)"
   assumes "dir = Positive \<or> dir = Negative"
   shows "P (assert_bound' dir i x c s)"
 proof (cases "\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)")
   case True
   then show ?thesis
     using assms(1)
     by simp
 next
   case False
   show ?thesis
   proof (cases "\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)")
     case True
     then show ?thesis
       using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close>
       using assms(2)
       by simp
   next
     case False
     let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
     show ?thesis
     proof (cases "x \<notin> lvars (\<T> ?s) \<and> (lt dir) c (\<langle>\<V> s\<rangle> x)")
       case True
       then show ?thesis
         using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close> \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<close>
         using assms(3) assms(6)
         by auto
     next
       case False
       then have "x \<in> lvars (\<T> ?s) \<or> \<not> ((lt dir) c (\<langle>\<V> s\<rangle> x))"
         by simp
       then show ?thesis
       proof
         assume "x \<in> lvars (\<T> ?s)"
         then show ?thesis
           using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close> \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<close>
           using assms(4) assms(6)
           by auto
       next
         assume "\<not> (lt dir) c (\<langle>\<V> s\<rangle> x)"
         then show ?thesis
           using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)\<close> \<open>\<not> \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)\<close>
           using assms(5) assms(6)
           by simp
       qed
     qed
   qed
 qed
 
 lemma assert_bound_cases:
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)
      \<rbrakk> \<Longrightarrow>
        P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir) s"
   assumes "\<And> c x dir.
      \<lbrakk>dir = Positive \<or> dir = Negative;
       a = LE dir x c;
       \<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x); \<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x)
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
           (set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        x \<notin> lvars (\<T> s); (lt dir) c (\<langle>\<V> s\<rangle> x);
       \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x))
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
        (update x c ((update\<B>\<I> (UBI_upd dir) i x c s)))"
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        x \<in> lvars (\<T> s); \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x));
        \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x))
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
           ((update\<B>\<I> (UBI_upd dir) i x c s))"
   assumes "\<And> c x dir.
      \<lbrakk> dir = Positive \<or> dir = Negative;
        a = LE dir x c;
        \<not> (\<unrhd>\<^sub>u\<^sub>b (lt dir) c ((UB dir) s x)); \<not> (\<lhd>\<^sub>l\<^sub>b (lt dir) c ((LB dir) s x));
        \<not> ((lt dir) c (\<langle>\<V> s\<rangle> x))
      \<rbrakk> \<Longrightarrow>
         P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir)
            ((update\<B>\<I> (UBI_upd dir) i x c s))"
 
 assumes "\<And> s. P s = P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u \<B>\<^sub>i\<^sub>l_update \<I>\<^sub>l \<I>\<^sub>u Geq Leq s"
 assumes "\<And> s. P s = P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l \<B>\<^sub>i\<^sub>u_update \<I>\<^sub>u \<I>\<^sub>l Leq Geq s"
 shows "P (assert_bound (i,a) s)"
 proof (cases a)
   case (Leq x c)
   then show ?thesis
     apply (simp del: assert_bound'_def)
     apply (rule assert_bound'_cases, simp_all)
     using assms(1)[of Positive x c]
     using assms(2)[of Positive x c]
     using assms(3)[of Positive x c]
     using assms(4)[of Positive x c]
     using assms(5)[of Positive x c]
     using assms(7)
     by auto
 next
   case (Geq x c)
   then show ?thesis
     apply (simp del: assert_bound'_def)
     apply (rule assert_bound'_cases)
     using assms(1)[of Negative x c]
     using assms(2)[of Negative x c]
     using assms(3)[of Negative x c]
     using assms(4)[of Negative x c]
     using assms(5)[of Negative x c]
     using assms(6)
     by auto
 qed
 end
 
 lemma set_unsat_bounds_id: "\<B> (set_unsat I s) = \<B> s"
   unfolding boundsl_def boundsu_def by auto
 
 
 lemma decrease_ub_satisfied_inverse:
   assumes lt: "\<lhd>\<^sub>u\<^sub>b (lt dir) c  (UB dir s x)" and dir: "dir = Positive \<or> dir = Negative"
   assumes v: "v \<Turnstile>\<^sub>b \<B> (update\<B>\<I> (UBI_upd dir) i x c s)"
   shows "v \<Turnstile>\<^sub>b \<B> s"
   unfolding satisfies_bounds.simps
 proof
   fix x'
   show "in_bounds x' v (\<B> s)"
   proof (cases "x = x'")
     case False
     then show ?thesis
       using v dir
       unfolding satisfies_bounds.simps
       by (auto split: if_splits simp: boundsl_def boundsu_def)
   next
     case True
     then show ?thesis
       using v dir
       unfolding satisfies_bounds.simps
       using lt
       by (erule_tac x="x'" in allE)
         (auto simp add: lt_ubound_def[THEN sym] gt_lbound_def[THEN sym] compare_strict_nonstrict
           boundsl_def boundsu_def)
   qed
 qed
 
 lemma atoms_equiv_bounds_extend:
   fixes x c dir
   assumes "dir = Positive \<or> dir = Negative"  "\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)"  "ats \<doteq> \<B> s"
   shows "(ats \<union> {LE dir x c}) \<doteq> \<B> (update\<B>\<I> (UBI_upd dir) i x c s)"
   unfolding atoms_equiv_bounds.simps
 proof
   fix v
   let ?s = "update\<B>\<I> (UBI_upd dir) i x c s"
   show "v \<Turnstile>\<^sub>a\<^sub>s (ats \<union> {LE dir x c}) = v \<Turnstile>\<^sub>b \<B> ?s"
   proof
     assume "v \<Turnstile>\<^sub>a\<^sub>s (ats \<union> {LE dir x c})"
     then have "v \<Turnstile>\<^sub>a\<^sub>s ats" "le (lt dir) (v x) c"
       using \<open>dir = Positive \<or> dir = Negative\<close>
       unfolding satisfies_atom_set_def
       by auto
     show "v \<Turnstile>\<^sub>b \<B> ?s"
       unfolding satisfies_bounds.simps
     proof
       fix x'
       show "in_bounds x' v (\<B> ?s)"
         using \<open>v \<Turnstile>\<^sub>a\<^sub>s ats\<close> \<open>le (lt dir) (v x) c\<close> \<open>ats \<doteq> \<B> s\<close>
         using \<open>dir = Positive \<or> dir = Negative\<close>
         unfolding atoms_equiv_bounds.simps satisfies_bounds.simps
         by (cases "x = x'") (auto simp: boundsl_def boundsu_def)
     qed
   next
     assume "v \<Turnstile>\<^sub>b \<B> ?s"
     then have "v \<Turnstile>\<^sub>b \<B> s"
       using \<open>\<not> \<unrhd>\<^sub>u\<^sub>b (lt dir) c (UB dir s x)\<close>
       using \<open>dir = Positive \<or> dir = Negative\<close>
       using decrease_ub_satisfied_inverse[of dir c s x v]
       using neg_bounds_compare(1)[of c "\<B>\<^sub>u s x"]
       using neg_bounds_compare(5)[of c "\<B>\<^sub>l s x"]
       by (auto simp add:  lt_ubound_def[THEN sym] ge_ubound_def[THEN sym] le_lbound_def[THEN sym] gt_lbound_def[THEN sym])
     show "v \<Turnstile>\<^sub>a\<^sub>s (ats \<union> {LE dir x c})"
       unfolding satisfies_atom_set_def
     proof
       fix a
       assume "a \<in> ats \<union> {LE dir x c}"
       then show "v \<Turnstile>\<^sub>a a"
       proof
         assume "a \<in> {LE dir x c}"
         then show ?thesis
           using \<open>v \<Turnstile>\<^sub>b \<B> ?s\<close>
           using \<open>dir = Positive \<or> dir = Negative\<close>
           unfolding satisfies_bounds.simps
           by (auto split: if_splits simp: boundsl_def boundsu_def)
       next
         assume "a \<in> ats"
         then show ?thesis
           using \<open>ats \<doteq> \<B> s\<close>
           using \<open>v \<Turnstile>\<^sub>b \<B> s\<close>
           unfolding atoms_equiv_bounds.simps satisfies_atom_set_def
           by auto
       qed
     qed
   qed
 qed
 
 lemma bounds_updates: "\<B>\<^sub>l (\<B>\<^sub>i\<^sub>u_update u s) = \<B>\<^sub>l s"
   "\<B>\<^sub>u (\<B>\<^sub>i\<^sub>l_update u s) = \<B>\<^sub>u s"
   "\<B>\<^sub>u (\<B>\<^sub>i\<^sub>u_update (upd x (i,c)) s) = (\<B>\<^sub>u s) (x \<mapsto> c)"
   "\<B>\<^sub>l (\<B>\<^sub>i\<^sub>l_update (upd x (i,c)) s) = (\<B>\<^sub>l s) (x \<mapsto> c)"
   by (auto simp: boundsl_def boundsu_def)
 
 locale EqForLVar =
   fixes eq_idx_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> nat"
   assumes eq_idx_for_lvar:
     "\<lbrakk>x \<in> lvars t\<rbrakk> \<Longrightarrow> eq_idx_for_lvar t x < length t \<and> lhs (t ! eq_idx_for_lvar t x) = x"
 begin
 definition eq_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> eq" where
   "eq_for_lvar t v \<equiv> t ! (eq_idx_for_lvar t v)"
 lemma eq_for_lvar:
   "\<lbrakk>x \<in> lvars t\<rbrakk> \<Longrightarrow> eq_for_lvar t x \<in> set t \<and> lhs (eq_for_lvar t x) = x"
   unfolding eq_for_lvar_def
   using eq_idx_for_lvar
   by auto
 
 abbreviation rvars_of_lvar where
   "rvars_of_lvar t x \<equiv> rvars_eq (eq_for_lvar t x)"
 
 lemma rvars_of_lvar_rvars:
   assumes "x \<in> lvars t"
   shows "rvars_of_lvar t x \<subseteq> rvars t"
   using assms eq_for_lvar[of x t]
   unfolding rvars_def
   by auto
 
 end
 
 text \<open>Updating changes the value of \<open>x\<close> and then updates
 values of all lhs variables so that the tableau remains
 satisfied. This can be based on a function that recalculates rhs
 polynomial values in the changed valuation:\<close>
 
 locale RhsEqVal = fixes rhs_eq_val::"(var, 'a::lrv) mapping \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> eq \<Rightarrow> 'a"
   \<comment> \<open>@{text rhs_eq_val} computes the value of the rhs of @{text e} in @{text "\<langle>v\<rangle>(x := c)"}.\<close>
   assumes rhs_eq_val:  "\<langle>v\<rangle> \<Turnstile>\<^sub>e e \<Longrightarrow> rhs_eq_val v x c e = rhs e \<lbrace> \<langle>v\<rangle> (x := c) \<rbrace>"
 
 begin
 
 text\<open>\noindent Then, the next implementation of \<open>update\<close>
 satisfies its specification:\<close>
 
 abbreviation update_eq where
   "update_eq v x c v' e \<equiv> upd (lhs e) (rhs_eq_val v x c e) v'"
 
 definition update :: "var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where
   "update x c s \<equiv> \<V>_update (upd x c (foldl (update_eq (\<V> s) x c) (\<V> s) (\<T> s))) s"
 
 lemma update_no_set_none:
   shows "look (\<V> s) y \<noteq> None \<Longrightarrow>
          look (foldl (update_eq (\<V> s) x v) (\<V> s) t) y \<noteq> None"
   by (induct t rule: rev_induct, auto simp: lookup_update')
 
 lemma update_no_left:
   assumes  "y \<notin> lvars t"
   shows "look (\<V> s) y = look (foldl (update_eq (\<V> s) x v) (\<V> s) t) y"
   using assms
   by (induct t rule: rev_induct) (auto simp add: lvars_def lookup_update')
 
 lemma update_left:
   assumes "y \<in> lvars t"
   shows "\<exists> eq \<in> set t. lhs eq = y \<and>
      look (foldl (update_eq (\<V> s) x v) (\<V> s) t) y = Some (rhs_eq_val (\<V> s) x v eq)"
   using assms
   by (induct t rule: rev_induct) (auto simp add: lvars_def lookup_update')
 
 lemma update_valuate_rhs:
   assumes "e \<in> set (\<T> s)" "\<triangle> (\<T> s)"
   shows "rhs e \<lbrace> \<langle>\<V> (update x c s)\<rangle> \<rbrace> = rhs e \<lbrace> \<langle>\<V> s\<rangle> (x := c) \<rbrace>"
 proof (rule valuate_depend, safe)
   fix y
   assume "y \<in> rvars_eq e"
   then have "y \<notin> lvars (\<T> s)"
     using \<open>\<triangle> (\<T> s)\<close> \<open>e \<in> set (\<T> s)\<close>
     by (auto simp add: normalized_tableau_def rvars_def)
   then show "\<langle>\<V> (update x c s)\<rangle> y = (\<langle>\<V> s\<rangle>(x := c)) y"
     using update_no_left[of y "\<T> s" s x c]
     by (auto simp add: update_def map2fun_def lookup_update')
 qed
 
 end
 
 
 sublocale RhsEqVal < Update update
 proof
   fix s::"('i,'a) state" and x c
   show "let s' = update x c s in \<T> s' = \<T> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s"
     by (simp add: Let_def update_def add: boundsl_def boundsu_def indexl_def indexu_def)
 next
   fix s::"('i,'a) state" and x c
   assume "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   then show "\<nabla> (update x c s)"
     using update_no_set_none[of s]
     by (simp add: Let_def update_def tableau_valuated_def lookup_update')
 next
   fix s::"('i,'a) state" and  x x' c
   assume "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   show "x' \<notin> lvars (\<T> s) \<longrightarrow>
           look (\<V> (update x c s)) x' =
           (if x = x' then Some c else look (\<V> s) x')"
     using update_no_left[of x' "\<T> s" s x c]
     unfolding update_def lvars_def Let_def
     by (auto simp: lookup_update')
 next
   fix s::"('i,'a) state" and x c
   assume "\<triangle> (\<T> s)" "\<nabla> s" "x \<notin> lvars (\<T> s)"
   have "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<Longrightarrow> \<forall>e \<in> set (\<T> s). \<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>e e"
   proof
     fix e
     assume "e \<in> set (\<T> s)" "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s"
     then have "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>e e"
       by (simp add: satisfies_tableau_def)
 
     have "x \<noteq> lhs e"
       using \<open>x \<notin> lvars (\<T> s)\<close> \<open>e \<in> set (\<T> s)\<close>
       by (auto simp add: lvars_def)
     then have "\<langle>\<V> (update x c s)\<rangle> (lhs e) = rhs_eq_val (\<V> s) x c e"
       using update_left[of "lhs e" "\<T> s" s x c] \<open>e \<in> set (\<T> s)\<close> \<open>\<triangle> (\<T> s)\<close>
       by (auto simp add: lvars_def lookup_update' update_def Let_def map2fun_def normalized_tableau_def distinct_map inj_on_def)
     then show "\<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>e e"
       using \<open>\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>e e\<close> \<open>e \<in> set (\<T> s)\<close> \<open>x \<notin> lvars (\<T> s)\<close> \<open>\<triangle> (\<T> s)\<close>
       using rhs_eq_val
       by (simp add: satisfies_eq_def update_valuate_rhs)
   qed
   then show "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<longrightarrow> \<langle>\<V> (update x c s)\<rangle> \<Turnstile>\<^sub>t \<T> s"
     by(simp add: satisfies_tableau_def update_def)
 qed
 
 
 text\<open>To update the valuation for a variable that is on the lhs of
 the tableau it should first be swapped with some rhs variable of its
 equation, in an operation called \emph{pivoting}. Pivoting has the
 precondition that the tableau is normalized and that it is always
 called for a lhs variable of the tableau, and a rhs variable in the
 equation with that lhs variable. The set of rhs variables for the
 given lhs variable is found using the \<open>rvars_of_lvar\<close> function
 (specified in a very simple locale \<open>EqForLVar\<close>, that we do not
 print).\<close>
 
 locale Pivot = EqForLVar + fixes pivot::"var \<Rightarrow> var \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> ('i,'a) state"
   assumes
     \<comment> \<open>Valuation, bounds, and the unsatisfiability flag are not changed.\<close>
 
 pivot_id:  "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       let s' = pivot x\<^sub>i x\<^sub>j s in \<V> s' = \<V> s \<and> \<B>\<^sub>i s' = \<B>\<^sub>i s \<and> \<U> s' = \<U> s \<and> \<U>\<^sub>c s' = \<U>\<^sub>c s" and
 
 \<comment> \<open>The tableau remains equivalent to the previous one and normalized.\<close>
 
 pivot_tableau:  "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       let s' = pivot x\<^sub>i x\<^sub>j s in  ((v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> s') \<and> \<triangle> (\<T> s') " and
 
 \<comment> \<open>@{text "x\<^sub>i"} and @{text "x\<^sub>j"} are swapped, while the other variables do not change sides.\<close>
 
 pivot_vars':   "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> let s' = pivot x\<^sub>i x\<^sub>j s in
    rvars(\<T> s') = rvars(\<T> s)-{x\<^sub>j}\<union>{x\<^sub>i}  \<and>  lvars(\<T> s') = lvars(\<T> s)-{x\<^sub>i}\<union>{x\<^sub>j}"
 
 begin
 lemma pivot_bounds_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<B>\<^sub>i (pivot x\<^sub>i x\<^sub>j s) = \<B>\<^sub>i s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_bounds_id': assumes "\<triangle> (\<T> s)" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<B>\<I> (pivot x\<^sub>i x\<^sub>j s) = \<B>\<I> s" "\<B> (pivot x\<^sub>i x\<^sub>j s) = \<B> s" "\<I> (pivot x\<^sub>i x\<^sub>j s) = \<I> s"
   using pivot_bounds_id[OF assms]
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma pivot_valuation_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<V> (pivot x\<^sub>i x\<^sub>j s) = \<V> s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_unsat_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<U> (pivot x\<^sub>i x\<^sub>j s) = \<U> s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_unsat_core_id: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<U>\<^sub>c (pivot x\<^sub>i x\<^sub>j s) = \<U>\<^sub>c s"
   using pivot_id
   by (simp add: Let_def)
 
 lemma pivot_tableau_equiv: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       (v::'a valuation) \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t \<T> (pivot x\<^sub>i x\<^sub>j s)"
   using pivot_tableau
   by (simp add: Let_def)
 
 lemma pivot_tableau_normalized: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> \<triangle> (\<T> (pivot x\<^sub>i x\<^sub>j s))"
   using pivot_tableau
   by (simp add: Let_def)
 
 lemma pivot_rvars: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> rvars (\<T> (pivot x\<^sub>i x\<^sub>j s)) = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
   using pivot_vars'
   by (simp add: Let_def)
 
 lemma pivot_lvars: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> lvars (\<T> (pivot x\<^sub>i x\<^sub>j s)) = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
   using pivot_vars'
   by (simp add: Let_def)
 
 lemma pivot_vars:
   "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> tvars (\<T> (pivot x\<^sub>i x\<^sub>j s)) = tvars (\<T> s) "
   using pivot_lvars[of s x\<^sub>i x\<^sub>j] pivot_rvars[of s x\<^sub>i x\<^sub>j]
   using rvars_of_lvar_rvars[of x\<^sub>i "\<T> s"]
   by auto
 
 lemma
   pivot_tableau_valuated: "\<lbrakk>\<triangle> (\<T> s); x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i; \<nabla> s\<rbrakk> \<Longrightarrow> \<nabla> (pivot x\<^sub>i x\<^sub>j s)"
   using pivot_valuation_id pivot_vars
   by (auto simp add: tableau_valuated_def)
 
 end
 
 
 text\<open>Functions \<open>pivot\<close> and \<open>update\<close> can be used to
 implement the \<open>check\<close> function. In its context, \<open>pivot\<close>
 and \<open>update\<close> functions are always called together, so the
 following definition can be used: @{prop "pivot_and_update x\<^sub>i x\<^sub>j c s =
 update x\<^sub>i c (pivot x\<^sub>i x\<^sub>j s)"}. It is possible to make a more efficient
 implementation of \<open>pivot_and_update\<close> that does not use separate
 implementations of \<open>pivot\<close> and \<open>update\<close>. To allow this, a
 separate specification for \<open>pivot_and_update\<close> can be given. It can be
 easily shown that the \<open>pivot_and_update\<close> definition above
 satisfies this specification.\<close>
 
 
 locale PivotAndUpdate = EqForLVar +
   fixes pivot_and_update :: "var \<Rightarrow> var \<Rightarrow> 'a::lrv \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
   assumes  pivotandupdate_unsat_id:   "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<U> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<U> s"
   assumes pivotandupdate_unsat_core_id: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<U>\<^sub>c (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<U>\<^sub>c s"
   assumes  pivotandupdate_bounds_id:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<B>\<^sub>i (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<B>\<^sub>i s"
   assumes  pivotandupdate_tableau_normalized:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<triangle> (\<T> (pivot_and_update x\<^sub>i x\<^sub>j c s))"
   assumes  pivotandupdate_tableau_equiv:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       (v::'a valuation) \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t \<T> (pivot_and_update x\<^sub>i x\<^sub>j c s)"
   assumes pivotandupdate_satisfies_tableau:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       \<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s \<longrightarrow> \<langle>\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)\<rangle> \<Turnstile>\<^sub>t \<T> s"
   assumes  pivotandupdate_rvars:   "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       rvars (\<T> (pivot_and_update x\<^sub>i x\<^sub>j c s)) = rvars (\<T> s) - {x\<^sub>j} \<union> {x\<^sub>i}"
   assumes  pivotandupdate_lvars:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       lvars (\<T> (pivot_and_update x\<^sub>i x\<^sub>j c s)) = lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j}"
   assumes pivotandupdate_valuation_nonlhs:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
       x \<notin> lvars (\<T> s) - {x\<^sub>i} \<union> {x\<^sub>j} \<longrightarrow> look (\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)) x = (if x = x\<^sub>i then Some c else look (\<V> s) x)"
   assumes pivotandupdate_tableau_valuated:  "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow>
  \<nabla> (pivot_and_update x\<^sub>i x\<^sub>j c s)"
 begin
 
 lemma pivotandupdate_bounds_id':  assumes "\<triangle> (\<T> s)" "\<nabla> s" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<B>\<I> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<B>\<I> s"
     "\<B> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<B> s"
     "\<I> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<I> s"
   using pivotandupdate_bounds_id[OF assms]
   by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
 
 lemma  pivotandupdate_valuation_xi: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i\<rbrakk> \<Longrightarrow> look (\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)) x\<^sub>i = Some c"
   using pivotandupdate_valuation_nonlhs[of s x\<^sub>i x\<^sub>j x\<^sub>i c]
   using rvars_of_lvar_rvars
   by (auto simp add:  normalized_tableau_def)
 
 lemma  pivotandupdate_valuation_other_nolhs: "\<lbrakk>\<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i; x \<notin> lvars (\<T> s); x \<noteq> x\<^sub>j\<rbrakk> \<Longrightarrow> look (\<V> (pivot_and_update x\<^sub>i x\<^sub>j c s)) x = look (\<V> s) x"
   using pivotandupdate_valuation_nonlhs[of s x\<^sub>i x\<^sub>j x c]
   by auto
 
 lemma pivotandupdate_nolhs:
   "\<lbrakk> \<triangle> (\<T> s); \<nabla> s; x\<^sub>i \<in> lvars (\<T> s); x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i;
      \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s; \<diamond> s; \<B>\<^sub>l s x\<^sub>i = Some c \<or> \<B>\<^sub>u s x\<^sub>i = Some c\<rbrakk> \<Longrightarrow>
      \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s (pivot_and_update x\<^sub>i x\<^sub>j c s)"
   using pivotandupdate_satisfies_tableau[of s x\<^sub>i x\<^sub>j c]
   using pivotandupdate_tableau_equiv[of s x\<^sub>i x\<^sub>j _ c]
   using pivotandupdate_valuation_xi[of s x\<^sub>i x\<^sub>j c]
   using pivotandupdate_valuation_other_nolhs[of s x\<^sub>i x\<^sub>j _ c]
   using pivotandupdate_lvars[of s x\<^sub>i x\<^sub>j c]
   by (auto simp add: curr_val_satisfies_no_lhs_def satisfies_bounds.simps satisfies_bounds_set.simps
       bounds_consistent_geq_lb bounds_consistent_leq_ub map2fun_def pivotandupdate_bounds_id')
 
 lemma pivotandupdate_bounds_consistent:
   assumes "\<triangle> (\<T> s)" "\<nabla> s" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<diamond> (pivot_and_update x\<^sub>i x\<^sub>j c s) = \<diamond> s"
   using assms pivotandupdate_bounds_id'[of s x\<^sub>i x\<^sub>j c]
   by (simp add: bounds_consistent_def)
 end
 
 
 locale PivotUpdate = Pivot eq_idx_for_lvar pivot + Update update for
   eq_idx_for_lvar :: "tableau \<Rightarrow> var \<Rightarrow> nat" and
   pivot :: "var \<Rightarrow> var \<Rightarrow> ('i,'a::lrv) state \<Rightarrow> ('i,'a) state" and
   update :: "var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state"
 begin
 definition  pivot_and_update :: "var \<Rightarrow> var \<Rightarrow> 'a \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" where [simp]:
   "pivot_and_update x\<^sub>i x\<^sub>j c s \<equiv> update x\<^sub>i c (pivot x\<^sub>i x\<^sub>j s)"
 
 lemma pivot_update_precond:
   assumes "\<triangle> (\<T> s)" "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>j \<in> rvars_of_lvar (\<T> s) x\<^sub>i"
   shows "\<triangle> (\<T> (pivot x\<^sub>i x\<^sub>j s))" "x\<^sub>i \<notin> lvars (\<T> (pivot x\<^sub>i x\<^sub>j s))"
 proof-
   from assms have "x\<^sub>i \<noteq> x\<^sub>j"
     using rvars_of_lvar_rvars[of x\<^sub>i "\<T> s"]
     by (auto simp add: normalized_tableau_def)
   then show "\<triangle> (\<T> (pivot x\<^sub>i x\<^sub>j s))" "x\<^sub>i \<notin> lvars (\<T> (pivot x\<^sub>i x\<^sub>j s))"
     using assms
     using pivot_tableau_normalized[of s x\<^sub>i x\<^sub>j]
     using pivot_lvars[of s x\<^sub>i x\<^sub>j]
     by auto
 qed
 
 end
 
 
 sublocale PivotUpdate < PivotAndUpdate eq_idx_for_lvar pivot_and_update
   using pivot_update_precond
   using update_unsat_id pivot_unsat_id pivot_unsat_core_id update_bounds_id pivot_bounds_id
     update_tableau_id pivot_tableau_normalized pivot_tableau_equiv update_satisfies_tableau
     pivot_valuation_id pivot_lvars pivot_rvars  update_valuation_nonlhs update_valuation_nonlhs
     pivot_tableau_valuated update_tableau_valuated update_unsat_core_id
   by (unfold_locales, auto)
 
 text\<open>Given the @{term update} function, \<open>assert_bound\<close> can be
 implemented as follows.
 \vspace{-2mm}
 @{text[display]
   "assert_bound (Leq x c) s \<equiv>
           if c \<ge>\<^sub>u\<^sub>b \<B>\<^sub>u s x then s
           else let s' = s \<lparr> \<B>\<^sub>u := (\<B>\<^sub>u s) (x := Some c) \<rparr>
                in if c <\<^sub>l\<^sub>b \<B>\<^sub>l s x then s' \<lparr> \<U> := True \<rparr>
                else if x \<notin> lvars (\<T> s') \<and> c < \<langle>\<V> s\<rangle> x then update x c s' else s'"
 }
 \vspace{-2mm}
 \noindent The case of \<open>Geq x c\<close> atoms is analogous (a systematic way to
 avoid symmetries is discussed in Section \ref{sec:symmetries}). This
 implementation satisfies both its specifications.
 \<close>
 
 lemma indices_state_set_unsat: "indices_state (set_unsat I s) = indices_state s" 
   by (cases s, auto simp: indices_state_def)
 
 lemma \<B>\<I>_set_unsat: "\<B>\<I> (set_unsat I s) = \<B>\<I> s" 
   by (cases s, auto simp: boundsl_def boundsu_def indexl_def indexu_def)
 
 lemma satisfies_tableau_cong: assumes "\<And> x. x \<in> tvars t \<Longrightarrow> v x = w x"
   shows "(v \<Turnstile>\<^sub>t t) = (w \<Turnstile>\<^sub>t t)" 
   unfolding satisfies_tableau_def satisfies_eq_def
   by (intro ball_cong[OF refl] arg_cong2[of _ _ _ _ "(=)"] valuate_depend, 
       insert assms, auto simp: lvars_def rvars_def)
 
 lemma satisfying_state_valuation_to_atom_tabl: assumes J: "J \<subseteq> indices_state s" 
   and model: "(J, v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s" 
   and ivalid: "index_valid as s" 
   and dist: "distinct_indices_atoms as" 
 shows "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" "v \<Turnstile>\<^sub>t \<T> s" 
   unfolding i_satisfies_atom_set'.simps
 proof (intro ballI)
   from model[unfolded satisfies_state_index'.simps]
   have model: "v \<Turnstile>\<^sub>t \<T> s" "(J, v) \<Turnstile>\<^sub>i\<^sub>b\<^sub>e \<B>\<I> s" by auto
   show "v \<Turnstile>\<^sub>t \<T> s" by fact
   fix a 
   assume "a \<in> restrict_to J as" 
   then obtain i where iJ: "i \<in> J" and mem: "(i,a) \<in> as" by auto
   with J have "i \<in> indices_state s" by auto
   from this[unfolded indices_state_def] obtain x c where 
     look: "look (\<B>\<^sub>i\<^sub>l s) x = Some (i, c) \<or> look (\<B>\<^sub>i\<^sub>u s) x = Some (i, c)" by auto
   with ivalid[unfolded index_valid_def] 
   obtain b where "(i,b) \<in> as" "atom_var b = x" "atom_const b = c" by force
   with dist[unfolded distinct_indices_atoms_def, rule_format, OF this(1) mem]
   have a: "atom_var a = x" "atom_const a = c" by auto
   from model(2)[unfolded satisfies_bounds_index'.simps] look iJ have "v x = c" 
     by (auto simp: boundsu_def boundsl_def indexu_def indexl_def)
   thus "v \<Turnstile>\<^sub>a\<^sub>e a" unfolding satisfies_atom'_def a .
 qed
 
 text \<open>Note that in order to ensure minimality of the unsat cores, pivoting is required.\<close>
 
 sublocale AssertAllState < AssertAll assert_all
 proof
   fix t as v I
   assume D: "\<triangle> t"  
   from D show "assert_all t as = Sat v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s flat (set as)"
     unfolding Let_def assert_all_def
     using assert_all_state_tableau_equiv[OF D refl]
     using assert_all_state_sat[OF D refl]
     using assert_all_state_sat_atoms_equiv_bounds[OF D refl, of as]
     unfolding atoms_equiv_bounds.simps curr_val_satisfies_state_def satisfies_state_def satisfies_atom_set_def
     by (auto simp: Let_def split: if_splits)
   let ?s = "assert_all_state t as" 
   assume "assert_all t as = Unsat I"
   then have i: "I = the (\<U>\<^sub>c ?s)" and U: "\<U> ?s"
     unfolding assert_all_def Let_def by (auto split: if_splits)
   from assert_all_index_valid[OF D refl, of as] have ivalid: "index_valid (set as) ?s"  .
   note unsat = assert_all_state_unsat[OF D refl U, unfolded minimal_unsat_state_core_def unsat_state_core_def i[symmetric]]
   from unsat have "set I \<subseteq> indices_state ?s" by auto
   also have "\<dots> \<subseteq> fst ` set as" using assert_all_state_indices[OF D refl] .
   finally have indices: "set I \<subseteq> fst ` set as" .
   show "minimal_unsat_core_tabl_atoms (set I) t (set as)" 
     unfolding minimal_unsat_core_tabl_atoms_def
   proof (intro conjI impI allI indices, clarify)
     fix v
     assume model: "v \<Turnstile>\<^sub>t t" "(set I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as"
     from unsat have no_model: "\<not> ((set I, v) \<Turnstile>\<^sub>i\<^sub>s ?s)" by auto
     from assert_all_state_unsat_atoms_equiv_bounds[OF D refl U]
     have equiv: "set as \<Turnstile>\<^sub>i \<B>\<I> ?s" by auto
     from assert_all_state_tableau_equiv[OF D refl, of v] model
     have model_t: "v \<Turnstile>\<^sub>t \<T> ?s" by auto
     have model_as': "(set I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as"
       using model(2) by (auto simp: satisfies_atom_set_def)
     with equiv model_t have "(set I, v) \<Turnstile>\<^sub>i\<^sub>s ?s"
       unfolding satisfies_state_index.simps atoms_imply_bounds_index.simps by simp
     with no_model show False by simp
   next
     fix J
     assume dist: "distinct_indices_atoms (set as)" and J: "J \<subset> set I" 
     from J unsat[unfolded subsets_sat_core_def, folded i] 
     have J': "J \<subseteq> indices_state ?s" by auto
     from index_valid_distinct_indices[OF ivalid dist] J unsat[unfolded subsets_sat_core_def, folded i]
     obtain v where model: "(J, v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e ?s" by blast
     have "(J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s set as" "v \<Turnstile>\<^sub>t t" 
       using satisfying_state_valuation_to_atom_tabl[OF J' model ivalid dist]
        assert_all_state_tableau_equiv[OF D refl] by auto      
     then show "\<exists> v. v \<Turnstile>\<^sub>t t \<and> (J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s set as" by blast
   qed
 qed
 
 lemma (in Update) update_to_assert_bound_no_lhs: assumes pivot: "Pivot eqlvar (pivot :: var \<Rightarrow> var \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state)" 
   shows "AssertBoundNoLhs assert_bound" 
 proof
   fix s::"('i,'a) state" and a
   assume "\<not> \<U> s" "\<triangle> (\<T> s)" "\<nabla> s"
   then show "\<T> (assert_bound a s) = \<T> s"
     by (cases a, cases "snd a") (auto simp add: Let_def update_tableau_id tableau_valuated_def)
 next
   fix s::"('i,'a) state" and ia and as
   assume *: "\<not> \<U> s" "\<triangle> (\<T> s)" "\<nabla> s" and **: "\<U> (assert_bound ia s)"
     and index: "index_valid as s"
     and consistent: "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<diamond> s" 
   obtain i a where ia: "ia = (i,a)" by force
   let ?modelU = "\<lambda> lt UB UI s v x c i. UB s x = Some c \<longrightarrow> UI s x = i \<longrightarrow> i \<in> set (the (\<U>\<^sub>c s)) \<longrightarrow> (lt (v x) c \<or> v x = c)"
   let ?modelL = "\<lambda> lt LB LI s v x c i. LB s x = Some c \<longrightarrow> LI s x = i \<longrightarrow> i \<in> set (the (\<U>\<^sub>c s)) \<longrightarrow> (lt c (v x) \<or> c = v x)"
   let ?modelIU = "\<lambda> I lt UB UI s v x c i. UB s x = Some c \<longrightarrow> UI s x = i \<longrightarrow> i \<in> I \<longrightarrow> (v x = c)"
   let ?modelIL = "\<lambda> I lt LB LI s v x c i. LB s x = Some c \<longrightarrow> LI s x = i \<longrightarrow> i \<in> I \<longrightarrow> (v x = c)"
   let ?P' = "\<lambda> lt UBI LBI UB LB UBI_upd UI LI LE GE s.
     \<U> s \<longrightarrow> (set (the (\<U>\<^sub>c s)) \<subseteq> indices_state s \<and> \<not> (\<exists>v. (v \<Turnstile>\<^sub>t \<T> s
       \<and> (\<forall> x c i. ?modelU lt UB UI s v x c i)
       \<and> (\<forall> x c i. ?modelL lt LB LI s v x c i))))
       \<and> (distinct_indices_state s \<longrightarrow> (\<forall> I. I \<subset> set (the (\<U>\<^sub>c s)) \<longrightarrow> (\<exists> v. v \<Turnstile>\<^sub>t \<T> s \<and>
             (\<forall> x c i. ?modelIU I lt UB UI s v x c i) \<and> (\<forall> x c i. ?modelIL I lt LB LI s v x c i))))"
   have "\<U> (assert_bound ia s) \<longrightarrow> (unsat_state_core (assert_bound ia s) \<and> 
     (distinct_indices_state (assert_bound ia s) \<longrightarrow> subsets_sat_core (assert_bound ia s)))" (is "?P (assert_bound ia s)") unfolding ia
   proof (rule assert_bound_cases[of _ _ ?P'])
     fix s' :: "('i,'a) state"
     have id: "((x :: 'a) < y \<or> x = y) \<longleftrightarrow> x \<le> y" "((x :: 'a) > y \<or> x = y) \<longleftrightarrow> x \<ge> y" for x y by auto
     have id': "?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u undefined \<I>\<^sub>l \<I>\<^sub>u Geq Leq s' = ?P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l undefined \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'" 
       by (intro arg_cong[of _ _ "\<lambda> y. _ \<longrightarrow> y"] arg_cong[of _ _ "\<lambda> x. _ \<and> x"], 
         intro arg_cong2[of _ _ _ _ "(\<and>)"] arg_cong[of _ _ "\<lambda> y. _ \<longrightarrow> y"] arg_cong[of _ _ "\<lambda> y. \<forall> x \<subset> set (the (\<U>\<^sub>c s')). y x"] ext arg_cong[of _ _ Not],
         unfold id, auto)
     show "?P s' = ?P' (>) \<B>\<^sub>i\<^sub>l \<B>\<^sub>i\<^sub>u \<B>\<^sub>l \<B>\<^sub>u undefined \<I>\<^sub>l \<I>\<^sub>u Geq Leq s'"
       unfolding satisfies_state_def satisfies_bounds_index.simps satisfies_bounds.simps
         in_bounds.simps unsat_state_core_def satisfies_state_index.simps subsets_sat_core_def
         satisfies_state_index'.simps satisfies_bounds_index'.simps
       unfolding bound_compare''_defs id 
       by ((intro arg_cong[of _ _ "\<lambda> x. _ \<longrightarrow> x"] arg_cong[of _ _ "\<lambda> x. _ \<and> x"], 
         intro arg_cong2[of _ _ _ _ "(\<and>)"] refl arg_cong[of _ _ "\<lambda> x. _ \<longrightarrow> x"] arg_cong[of _ _ Not]
         arg_cong[of _ _ "\<lambda> y. \<forall> x \<subset> set (the (\<U>\<^sub>c s')). y x"] ext; intro arg_cong[of _ _ Ex] ext), auto)
     then show "?P s' = ?P' (<) \<B>\<^sub>i\<^sub>u \<B>\<^sub>i\<^sub>l \<B>\<^sub>u \<B>\<^sub>l undefined \<I>\<^sub>u \<I>\<^sub>l Leq Geq s'" unfolding id' .
   next
     fix c::'a and x::nat and dir
     assume "\<lhd>\<^sub>l\<^sub>b (lt dir) c (LB dir s x)" and dir: "dir = Positive \<or> dir = Negative"
     then obtain d where some: "LB dir s x = Some d" and lt: "lt dir c d"
       by (auto simp: bound_compare'_defs split: option.splits)
     from index[unfolded index_valid_def, rule_format, of x _ d]
       some dir obtain j where ind: "LI dir s x = j" "look (LBI dir s) x = Some (j,d)" and ge: "(j, GE dir x d) \<in> as"
       by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
     let ?s = "set_unsat [i, ((LI dir) s x)] (update\<B>\<I> (UBI_upd dir) i x c s)"
     let ?ss = "update\<B>\<I> (UBI_upd dir) i x c s" 
     show "?P' (lt dir) (UBI dir) (LBI dir) (UB dir) (LB dir) (UBI_upd dir) (UI dir) (LI dir) (LE dir) (GE dir) ?s"
     proof (intro conjI impI allI, goal_cases)
       case 1
       thus ?case using dir ind ge lt some by (force simp: indices_state_def split: if_splits)
     next
       case 2
       {
         fix v
         assume vU: "\<forall> x c i. ?modelU (lt dir) (UB dir) (UI dir) ?s v x c i"
         assume vL: "\<forall> x c i. ?modelL (lt dir) (LB dir) (LI dir) ?s v x c i" 
         from dir have "UB dir ?s x = Some c" "UI dir ?s x = i" by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         from vU[rule_format, OF this] have vx_le_c: "lt dir (v x) c \<or> v x = c" by auto
         from dir ind some have *: "LB dir ?s x = Some d" "LI dir ?s x = j" by (auto simp: boundsl_def boundsu_def indexl_def indexu_def)
         have d_le_vx: "lt dir d (v x) \<or> d = v x" by (intro vL[rule_format, OF *], insert some ind, auto)
         from dir d_le_vx vx_le_c lt
         have False by auto
       }
       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}"
+  have "?Al L \<subseteq> {t. mset t = mset ?t}"
   proof
     fix x
     assume "x \<in> ?Al L"
-    have "x <~~> ?t"
+    have "mset x = mset ?t"
       apply (rule tableau_perm)
       using \<open>?t \<in> ?Al L\<close> \<open>x \<in> ?Al L\<close>
       by auto
-    then show "x \<in> {t. t <~~> ?t}"
+    then show "x \<in> {t. mset t = mset ?t}"
       by simp
   qed
   moreover
-  have "finite {t. t <~~> ?t}"
-    by (rule perm_finite)
+  have "finite {t. mset t = mset ?t}"
+    by (fact mset_eq_finite)
   ultimately
   show ?thesis
     by (rule finite_subset)
 qed
 
 lemma finite_tableaus:
   assumes "finite V"
   shows "finite {t. tvars t = V \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}" (is "finite ?A")
 proof-
   let ?Al = "\<lambda> L. {t. lvars t = L \<and> rvars t = V - L \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}"
   have "?A = \<Union> (?Al ` {L. L \<subseteq> V})"
     by (auto simp add: normalized_tableau_def)
   then show ?thesis
     using \<open>finite V\<close>
     using finite_tableaus_aux
     by auto
 qed
 
 lemma finite_accessible_tableaus:
   shows "finite (\<T> ` {s'. s \<succ>\<^sup>* s'})"
 proof-
   have "{s'. s \<succ>\<^sup>* s'} = {s'. s \<succ>\<^sup>+ s'} \<union> {s}"
     by (auto simp add: rtrancl_eq_or_trancl)
   moreover
   have "finite (\<T> ` {s'. s \<succ>\<^sup>+ s'})" (is "finite ?A")
   proof-
     let ?T = "{t. tvars t = tvars (\<T> s) \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t(\<T> s))}"
     have "?A \<subseteq> ?T"
     proof
       fix t
       assume "t \<in> ?A"
       then obtain s' where "s \<succ>\<^sup>+ s'" "t = \<T> s'"
         by auto
       then obtain l where *: "l \<noteq> []" "1 < length l" "hd l = s" "last l = s'" "succ_chain l"
         using trancl_rel_chain[of s s' succ_rel]
         by auto
       show "t \<in> ?T"
       proof-
         have "tvars (\<T> s') = tvars (\<T> s)"
           using succ_chain_vars_id[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by simp
         moreover
         have "\<triangle> (\<T> s')"
           using \<open>s \<succ>\<^sup>+ s'\<close>
           using succ_inv(1)[of _ s']
           by (auto dest: tranclD2)
         moreover
         have "\<forall>v::'a valuation. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t \<T> s"
           using succ_chain_tableau_equiv[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         ultimately
         show ?thesis
           using \<open>t = \<T> s'\<close>
           by simp
       qed
     qed
     moreover
     have "finite (tvars (\<T> s))"
       by (auto simp add: lvars_def rvars_def finite_vars)
     ultimately
     show ?thesis
       using finite_tableaus[of "tvars (\<T> s)" "\<T> s"]
       by (auto simp add: finite_subset)
   qed
   ultimately
   show ?thesis
     by simp
 qed
 
 abbreviation check_valuation  where
   "check_valuation (v::'a valuation) v0 bl0 bu0 t0 V \<equiv>
      \<exists> t. tvars t = V \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0) \<and> v \<Turnstile>\<^sub>t t \<and>
      (\<forall> x \<in> rvars t. v x = v0 x \<or> v x = bl0 x \<or> v x = bu0 x) \<and>
      (\<forall> x. x \<notin> V \<longrightarrow> v x = v0 x)"
 
 lemma finite_valuations:
   assumes "finite V"
   shows "finite {v::'a valuation. check_valuation v v0 bl0 bu0 t0 V}" (is "finite ?A")
 proof-
   let ?Al = "\<lambda> L. {t. lvars t = L \<and> rvars t = V - L \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0)}"
   let ?Vt = "\<lambda> t. {v::'a valuation. v \<Turnstile>\<^sub>t t \<and> (\<forall> x \<in> rvars t. v x = v0 x \<or> v x = bl0 x \<or> v x = bu0 x) \<and> (\<forall> x. x \<notin> V \<longrightarrow> v x = v0 x)}"
 
   have "finite {L. L \<subseteq> V}"
     using \<open>finite V\<close>
     by auto
   have "\<forall> L. L \<subseteq> V \<longrightarrow> finite (?Al L)"
     using finite_tableaus_aux
     by auto
   have "\<forall> L t. L \<subseteq> V \<and> t \<in> ?Al L \<longrightarrow> finite (?Vt  t)"
   proof (safe)
     fix L t
     assume "lvars t \<subseteq> V" "rvars t = V - lvars t" "\<triangle> t" "\<forall>v. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t t0"
     then have "rvars t \<union> lvars t = V"
       by auto
 
     let ?f = "\<lambda> v x. if x \<in> rvars t then v x else 0"
 
     have "inj_on ?f (?Vt t)"
       unfolding inj_on_def
     proof (safe, rule ext)
       fix v1 v2 x
       assume "(\<lambda>x. if x \<in> rvars t then v1 x else (0 :: 'a)) =
               (\<lambda>x. if x \<in> rvars t then v2 x else (0 :: 'a))" (is "?f1 = ?f2")
       have "\<forall>x\<in>rvars t. v1 x = v2 x"
       proof
         fix x
         assume "x \<in> rvars t"
         then show "v1 x = v2 x"
           using \<open>?f1 = ?f2\<close> fun_cong[of ?f1 ?f2 x]
           by auto
       qed
       assume *: "v1 \<Turnstile>\<^sub>t t" "v2 \<Turnstile>\<^sub>t t"
         "\<forall>x. x \<notin> V \<longrightarrow> v1 x = v0 x" "\<forall>x. x \<notin> V \<longrightarrow> v2 x = v0 x"
       show "v1 x = v2 x"
       proof (cases "x \<in> lvars t")
         case False
         then show ?thesis
           using * \<open>\<forall>x\<in>rvars t. v1 x = v2 x\<close> \<open>rvars t \<union> lvars t = V\<close>
           by auto
       next
         case True
         let ?eq = "eq_for_lvar t x"
         have "?eq \<in> set t \<and> lhs ?eq = x"
           using eq_for_lvar \<open>x \<in> lvars t\<close>
           by simp
         then have "v1 x = rhs ?eq \<lbrace> v1 \<rbrace>" "v2 x = rhs ?eq \<lbrace> v2 \<rbrace>"
           using \<open>v1 \<Turnstile>\<^sub>t t\<close> \<open>v2 \<Turnstile>\<^sub>t t\<close>
           unfolding satisfies_tableau_def satisfies_eq_def
           by auto
         moreover
         have "rhs ?eq \<lbrace> v1 \<rbrace> = rhs ?eq \<lbrace> v2 \<rbrace>"
           apply (rule valuate_depend)
           using \<open>\<forall>x\<in>rvars t. v1 x = v2 x\<close> \<open>?eq \<in> set t \<and> lhs ?eq = x\<close>
           unfolding rvars_def
           by auto
         ultimately
         show ?thesis
           by simp
       qed
     qed
 
     let ?R = "{v. \<forall> x. if x \<in> rvars t then v x = v0 x \<or> v x = bl0 x \<or> v x = bu0 x else v x = 0 }"
     have "?f ` (?Vt t) \<subseteq> ?R"
       by auto
     moreover
     have "finite ?R"
     proof-
       have "finite (rvars t)"
         using \<open>finite V\<close> \<open>rvars t \<union> lvars t = V\<close>
         using  finite_subset[of "rvars t" V]
         by auto
       moreover
       let ?R' = "{v. \<forall> x. if x \<in> rvars t then v x \<in> {v0 x, bl0 x, bu0 x} else v x = 0}"
       have "?R = ?R'"
         by auto
       ultimately
       show ?thesis
         using finite_fun_args[of "rvars t" "\<lambda> x. {v0 x,  bl0 x, bu0 x}" "\<lambda> x. 0"]
         by auto
     qed
     ultimately
     have "finite (?f ` (?Vt t))"
       by (simp add: finite_subset)
     then show "finite (?Vt t)"
       using \<open>inj_on ?f (?Vt t)\<close>
       by (auto dest: finite_imageD)
   qed
 
   have "?A = \<Union> (\<Union> (((`) ?Vt) ` (?Al ` {L. L \<subseteq> V})))" (is "?A = ?A'")
     by (auto simp add: normalized_tableau_def cong del: image_cong_simp)
   moreover
   have "finite ?A'"
   proof (rule finite_Union)
     show "finite (\<Union> (((`) ?Vt) ` (?Al ` {L. L \<subseteq> V})))"
       using \<open>finite {L. L \<subseteq> V}\<close> \<open>\<forall> L. L \<subseteq> V \<longrightarrow> finite (?Al L)\<close>
       by auto
   next
     fix M
     assume "M \<in> \<Union> (((`) ?Vt) ` (?Al ` {L. L \<subseteq> V}))"
     then obtain L t where "L \<subseteq> V" "t \<in> ?Al L" "M = ?Vt t"
       by blast
     then show "finite M"
       using \<open>\<forall> L t. L \<subseteq> V \<and> t \<in> ?Al L \<longrightarrow> finite (?Vt  t)\<close>
       by blast
   qed
   ultimately
   show ?thesis
     by simp
 qed
 
 
 lemma finite_accessible_valuations:
   shows "finite (\<V> ` {s'. s \<succ>\<^sup>* s'})"
 proof-
   have "{s'. s \<succ>\<^sup>* s'} = {s'. s \<succ>\<^sup>+ s'} \<union> {s}"
     by (auto simp add: rtrancl_eq_or_trancl)
   moreover
   have "finite (\<V> ` {s'. s \<succ>\<^sup>+ s'})" (is "finite ?A")
   proof-
     let ?P = "\<lambda> v. check_valuation v (\<langle>\<V> s\<rangle>) (\<lambda> x. the (\<B>\<^sub>l s x)) (\<lambda> x. the (\<B>\<^sub>u s x)) (\<T> s) (tvars (\<T> s))"
     let ?P' = "\<lambda> v::(var, 'a) mapping.
          \<exists> t. tvars t = tvars (\<T> s) \<and> \<triangle> t \<and> (\<forall> v::'a valuation. v \<Turnstile>\<^sub>t t = v \<Turnstile>\<^sub>t \<T> s) \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and>
     (\<forall> x \<in> rvars t. \<langle>v\<rangle> x = \<langle>\<V> s\<rangle> x \<or>
                        \<langle>v\<rangle> x = the (\<B>\<^sub>l s x) \<or>
                        \<langle>v\<rangle> x = the (\<B>\<^sub>u s x)) \<and>
     (\<forall> x. x \<notin> tvars (\<T> s) \<longrightarrow> look v x = look (\<V> s) x) \<and>
     (\<forall> x. x \<in> tvars (\<T> s) \<longrightarrow> look v x \<noteq> None)"
 
     have "finite (tvars (\<T> s))"
       by (auto simp add: lvars_def rvars_def finite_vars)
     then have "finite {v. ?P v}"
       using finite_valuations[of "tvars (\<T> s)" "\<T> s" "\<langle>\<V> s\<rangle>" "\<lambda> x. the (\<B>\<^sub>l s x)" "\<lambda> x. the (\<B>\<^sub>u s x)"]
       by auto
     moreover
     have "map2fun ` {v. ?P' v} \<subseteq> {v. ?P v}"
       by (auto simp add: map2fun_def)
     ultimately
     have "finite (map2fun ` {v. ?P' v})"
       by (auto simp add: finite_subset)
     moreover
     have "inj_on map2fun {v. ?P' v}"
       unfolding inj_on_def
     proof (safe)
       fix x y
       assume "\<langle>x\<rangle> = \<langle>y\<rangle>" and *:
         "\<forall>x. x \<notin> Simplex.tvars (\<T> s) \<longrightarrow> look y x = look (\<V> s) x"
         "\<forall>xa. xa \<notin> Simplex.tvars (\<T> s) \<longrightarrow> look x xa = look (\<V> s) xa"
         "\<forall>x. x \<in> Simplex.tvars (\<T> s) \<longrightarrow> look y x \<noteq> None"
         "\<forall>xa. xa \<in> Simplex.tvars (\<T> s) \<longrightarrow> look x xa \<noteq> None"
       show "x = y"
       proof (rule mapping_eqI)
         fix k
         have "\<langle>x\<rangle> k = \<langle>y\<rangle> k"
           using \<open>\<langle>x\<rangle> = \<langle>y\<rangle>\<close>
           by simp
         then show "look x k = look y k"
           using *
           by  (cases "k \<in> tvars (\<T> s)") (auto simp add: map2fun_def split: option.split)
       qed
     qed
     ultimately
     have "finite {v. ?P' v}"
       by (rule finite_imageD)
     moreover
     have "?A \<subseteq> {v. ?P' v}"
     proof (safe)
       fix s'
       assume "s \<succ>\<^sup>+ s'"
       then obtain l where *: "l \<noteq> []" "1 < length l" "hd l = s" "last l = s'" "succ_chain l"
         using trancl_rel_chain[of s s' succ_rel]
         by auto
       show "?P' (\<V> s')"
       proof-
         have "\<nabla> s" "\<triangle> (\<T> s)" "\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s"
           using \<open>s \<succ>\<^sup>+ s'\<close>
           using tranclD[of s s' succ_rel]
           by (auto simp add: curr_val_satisfies_no_lhs_def)
         have "tvars (\<T> s') = tvars (\<T> s)"
           using succ_chain_vars_id[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by simp
         moreover
         have "\<triangle>(\<T> s')"
           using \<open>s \<succ>\<^sup>+ s'\<close>
           using succ_inv(1)[of _ s']
           by (auto dest: tranclD2)
         moreover
         have "\<forall>v::'a valuation. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t \<T> s"
           using succ_chain_tableau_equiv[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         moreover
         have "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'"
           using succ_chain_valuation_satisfies[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l] \<open>\<langle>\<V> s\<rangle> \<Turnstile>\<^sub>t \<T> s\<close>
           by simp
         moreover
         have "\<forall>x\<in>rvars (\<T> s'). \<langle>\<V> s'\<rangle> x = \<langle>\<V> s\<rangle> x \<or> \<langle>\<V> s'\<rangle> x = the (\<B>\<^sub>l s x) \<or> \<langle>\<V> s'\<rangle> x = the (\<B>\<^sub>u s x)"
           using succ_chain_rvar_valuation[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         moreover
         have "\<forall>x. x \<notin> tvars (\<T> s) \<longrightarrow> look (\<V> s') x = look (\<V> s) x"
           using succ_chain_no_vars_valuation[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           by auto
         moreover
         have "\<forall>x. x \<in> Simplex.tvars (\<T> s') \<longrightarrow> look (\<V> s') x \<noteq> None"
           using succ_chain_tableau_valuated[of l 0 "length l - 1"]
           using * hd_conv_nth[of l] last_conv_nth[of l]
           using \<open>tvars (\<T> s') = tvars (\<T> s)\<close> \<open>\<nabla> s\<close>
           by (auto simp add: tableau_valuated_def)
         ultimately
         show ?thesis
           by (rule_tac x="\<T> s'" in exI) auto
       qed
     qed
     ultimately
     show ?thesis
       by (auto simp add: finite_subset)
   qed
   ultimately
   show ?thesis
     by simp
 qed
 
 lemma accessible_bounds:
   shows "\<B>\<^sub>i ` {s'. s \<succ>\<^sup>* s'} = {\<B>\<^sub>i s}"
 proof -
   have "s \<succ>\<^sup>* s' \<Longrightarrow> \<B>\<^sub>i s' = \<B>\<^sub>i s" for s'
     by (induct s s' rule: rtrancl.induct, auto)
   then show ?thesis by blast
 qed
 
 lemma accessible_unsat_core:
   shows "\<U>\<^sub>c ` {s'. s \<succ>\<^sup>* s'} = {\<U>\<^sub>c s}"
 proof -
   have "s \<succ>\<^sup>* s' \<Longrightarrow> \<U>\<^sub>c s' = \<U>\<^sub>c s" for s'
     by (induct s s' rule: rtrancl.induct, auto)
   then show ?thesis by blast
 qed
 
 lemma state_eqI:
   "\<B>\<^sub>i\<^sub>l s = \<B>\<^sub>i\<^sub>l s' \<Longrightarrow> \<B>\<^sub>i\<^sub>u s = \<B>\<^sub>i\<^sub>u s' \<Longrightarrow>
    \<T> s = \<T> s' \<Longrightarrow> \<V> s = \<V> s' \<Longrightarrow>
    \<U> s = \<U> s' \<Longrightarrow> \<U>\<^sub>c s = \<U>\<^sub>c s' \<Longrightarrow>
    s = s'"
   by (cases s, cases s', auto)
 
 lemma finite_accessible_states:
   shows "finite {s'. s \<succ>\<^sup>* s'}" (is "finite ?A")
 proof-
   let ?V = "\<V> ` ?A"
   let ?T = "\<T> ` ?A"
   let ?P = "?V \<times> ?T \<times> {\<B>\<^sub>i s} \<times> {True, False} \<times> {\<U>\<^sub>c s}"
   have "finite ?P"
     using finite_accessible_valuations finite_accessible_tableaus
     by auto
   moreover
   let ?f = "\<lambda> s. (\<V> s, \<T> s, \<B>\<^sub>i s, \<U> s, \<U>\<^sub>c s)"
   have "?f ` ?A \<subseteq> ?P"
     using accessible_bounds[of s] accessible_unsat_core[of s]
     by auto
   moreover
   have "inj_on ?f ?A"
     unfolding inj_on_def by (auto intro: state_eqI)
   ultimately
   show ?thesis
     using finite_imageD [of ?f ?A]
     using finite_subset
     by auto
 qed
 
 (* -------------------------------------------------------------------------- *)
 lemma acyclic_suc_rel: "acyclic succ_rel"
 proof (rule acyclicI, rule allI)
   fix s
   show "(s, s) \<notin> succ_rel\<^sup>+"
   proof
     assume "s \<succ>\<^sup>+ s"
     then obtain l where
       "l \<noteq> []" "length l > 1" "hd l = s" "last l = s" "succ_chain l"
       using trancl_rel_chain[of s s succ_rel]
       by auto
 
     have "l ! 0 = s"
       using \<open>l \<noteq> []\<close> \<open>hd l = s\<close>
       by (simp add: hd_conv_nth)
     then have "s \<succ> (l ! 1)"
       using \<open>succ_chain l\<close>
       unfolding rel_chain_def
       using \<open>length l > 1\<close>
       by auto
     then have "\<triangle> (\<T> s)"
       by simp
 
     let ?enter_rvars =
       "{x. \<exists> sl. swap_lr l sl x}"
 
     have "finite ?enter_rvars"
     proof-
       let ?all_vars = "\<Union> (set (map (\<lambda> t. lvars t \<union> rvars t) (map \<T> l)))"
       have "finite ?all_vars"
         by (auto simp add: lvars_def rvars_def finite_vars)
       moreover
       have "?enter_rvars \<subseteq> ?all_vars"
         by force
       ultimately
       show ?thesis
         by (simp add: finite_subset)
     qed
 
     let ?xr = "Max ?enter_rvars"
     have "?xr \<in> ?enter_rvars"
     proof (rule Max_in)
       show "?enter_rvars \<noteq> {}"
       proof-
         from \<open>s \<succ> (l ! 1)\<close>
         obtain x\<^sub>i x\<^sub>j :: var where
           "x\<^sub>i \<in> lvars (\<T> s)" "x\<^sub>i \<in> rvars (\<T> (l ! 1))"
           by (rule succ_vars) auto
         then have "x\<^sub>i \<in> ?enter_rvars"
           using \<open>hd l = s\<close> \<open>l \<noteq> []\<close> \<open>length l > 1\<close>
           by (auto simp add: hd_conv_nth)
         then show ?thesis
           by auto
       qed
     next
       show "finite ?enter_rvars"
         using \<open>finite ?enter_rvars\<close>
         .
     qed
     then obtain xr sl where
       "xr = ?xr" "swap_lr l sl xr"
       by auto
     then have "sl + 1 < length l"
       by simp
 
     have "(l ! sl) \<succ> (l ! (sl + 1))"
       using \<open>sl + 1 < length l\<close> \<open>succ_chain l\<close>
       unfolding rel_chain_def
       by auto
 
 
     have "length l > 2"
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with \<open>length l > 1\<close>
       have "length l = 2"
         by auto
       then have "last l = l ! 1"
         by (cases l) (auto simp add: last_conv_nth nth_Cons split: nat.split)
       then have "xr \<in> lvars (\<T> s)" "xr \<in> rvars (\<T> s)"
         using \<open>length l = 2\<close>
         using \<open>swap_lr l sl xr\<close>
         using \<open>hd l = s\<close> \<open>last l = s\<close> \<open>l \<noteq> []\<close>
         by (auto simp add: hd_conv_nth)
       then show False
         using \<open>\<triangle> (\<T> s)\<close>
         unfolding normalized_tableau_def
         by auto
     qed
 
     obtain l' where
       "hd l' = l ! (sl + 1)" "last l' = l ! sl" "length l' = length l - 1"  "succ_chain l'" and
       l'_l:   "\<forall> i. i + 1 < length l' \<longrightarrow>
      (\<exists> j. j + 1 < length l \<and> l' ! i = l ! j \<and> l' ! (i + 1) = l ! (j + 1))"
       using \<open>length l > 2\<close> \<open>sl + 1 < length l\<close> \<open>hd l = s\<close> \<open>last l = s\<close> \<open>succ_chain l\<close>
       using reorder_cyclic_list[of l s sl]
       by blast
 
     then have "xr \<in> rvars (\<T> (hd l'))"  "xr \<in> lvars (\<T> (last l'))" "length l' > 1" "l' \<noteq> []"
       using \<open>swap_lr l sl xr\<close> \<open>length l > 2\<close>
       by auto
 
     then have "\<exists> sp. swap_rl l' sp xr"
       using \<open>succ_chain l'\<close>
       using succ_chain_swap_rl_exists[of l' 0 "length l' - 1" xr]
       by (auto simp add: hd_conv_nth last_conv_nth)
     then have "\<exists> sp. swap_rl l' sp xr \<and> (\<forall> sp'. sp' < sp \<longrightarrow> \<not> swap_rl l' sp' xr)"
       by (rule min_element)
     then obtain sp where
       "swap_rl l' sp xr" "\<forall> sp'. sp' < sp \<longrightarrow> \<not> swap_rl l' sp' xr"
       by blast
     then have "sp + 1 < length l'"
       by simp
 
     have "\<langle>\<V> (l' ! 0)\<rangle> xr = \<langle>\<V> (l' ! sp)\<rangle> xr"
     proof-
       have "always_r l' 0 sp xr"
         using \<open>xr \<in> rvars (\<T> (hd l'))\<close> \<open>sp + 1 < length l'\<close>
           \<open>\<forall> sp'. sp' < sp \<longrightarrow> \<not> swap_rl l' sp' xr\<close>
       proof (induct sp)
         case 0
         then have "l' \<noteq> []"
           by auto
         then show ?case
           using 0(1)
           by (auto simp add: hd_conv_nth)
       next
         case (Suc sp')
         show ?case
         proof (safe)
           fix k
           assume "k \<le> Suc sp'"
           show "xr \<in> rvars (\<T> (l' ! k))"
           proof (cases "k = sp' + 1")
             case False
             then show ?thesis
               using Suc \<open>k \<le> Suc sp'\<close>
               by auto
           next
             case True
             then have "xr \<in> rvars (\<T> (l' ! (k - 1)))"
               using Suc
               by auto
             moreover
             then have "xr \<notin> lvars (\<T> (l' ! k))"
               using True Suc(3) Suc(4)
               by auto
             moreover
             have "(l' ! (k - 1)) \<succ> (l' ! k)"
               using \<open>succ_chain l'\<close>
               using Suc(3) True
               by (simp add: rel_chain_def)
             ultimately
             show ?thesis
               using succ_vars_id[of "l' ! (k - 1)" "l' ! k"]
               by auto
           qed
         qed
       qed
       then show ?thesis
         using \<open>sp + 1 < length l'\<close>
         using \<open>succ_chain l'\<close>
         using succ_chain_always_r_valuation_id
         by simp
     qed
 
     have "(l' ! sp) \<succ> (l' ! (sp+1))"
       using \<open>sp + 1 < length l'\<close> \<open>succ_chain l'\<close>
       unfolding rel_chain_def
       by simp
     then obtain xs xr' :: var where
       "xs \<in> lvars (\<T> (l' ! sp))"
       "xr \<in> rvars (\<T> (l' ! sp))"
       "swap_lr l' sp xs"
       apply (rule succ_vars)
       using \<open>swap_rl l' sp xr\<close> \<open>sp + 1 < length l'\<close>
       by auto
     then have "xs \<noteq> xr"
       using \<open>(l' ! sp) \<succ> (l' ! (sp+1))\<close>
       by (auto simp add: normalized_tableau_def)
 
     obtain sp' where
       "l' ! sp = l ! sp'" "l' ! (sp + 1) = l ! (sp' + 1)"
       "sp' + 1 < length l"
       using \<open>sp + 1 < length l'\<close> l'_l
       by auto
 
     have "xs \<in> ?enter_rvars"
       using \<open>swap_lr l' sp xs\<close> l'_l
       by force
 
     have "xs < xr"
     proof-
       have "xs \<le> ?xr"
         using \<open>finite ?enter_rvars\<close> \<open>xs \<in> ?enter_rvars\<close>
         by (rule Max_ge)
       then show ?thesis
         using \<open>xr = ?xr\<close> \<open>xs \<noteq> xr\<close>
         by simp
     qed
 
     let ?sl = "l ! sl"
     let ?sp = "l' ! sp"
     let ?eq = "eq_for_lvar (\<T> ?sp) xs"
     let ?bl = "\<V> ?sl"
     let ?bp = "\<V> ?sp"
 
     have "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sl" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sp"
       using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>
       using \<open>l' ! sp \<succ> (l' ! (sp+ 1))\<close>
       by simp_all
 
     have "\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl"
     proof-
       have "\<B>\<^sub>i (l' ! sp) = \<B>\<^sub>i (l' ! (length l' - 1))"
         using \<open>sp + 1 < length l'\<close> \<open>succ_chain l'\<close>
         using succ_chain_bounds_id
         by auto
       then have "\<B>\<^sub>i (last l') = \<B>\<^sub>i (l' ! sp)"
         using \<open>l' \<noteq> []\<close>
         by (simp add: last_conv_nth)
       then show ?thesis
         using \<open>last l' = l ! sl\<close>
         by simp
     qed
 
     have diff_satified: "\<langle>?bl\<rangle> xs - \<langle>?bp\<rangle> xs = ((rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace>) - ((rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>)"
     proof-
       have "\<langle>?bp\<rangle> \<Turnstile>\<^sub>e ?eq"
         using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sp\<close>
         using eq_for_lvar[of xs "\<T> ?sp"]
         using \<open>xs \<in> lvars (\<T> (l' ! sp))\<close>
         unfolding curr_val_satisfies_no_lhs_def satisfies_tableau_def
         by auto
       moreover
       have "\<langle>?bl\<rangle> \<Turnstile>\<^sub>e ?eq"
       proof-
         have "\<langle>\<V> (l ! sl)\<rangle> \<Turnstile>\<^sub>t \<T> (l' ! sp)"
           using \<open>l' ! sp = l ! sp'\<close> \<open>sp' + 1 < length l\<close> \<open>sl + 1 < length l\<close>
           using \<open>succ_chain l\<close>
           using succ_chain_tableau_equiv[of l sl sp']
           using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sl\<close>
           unfolding curr_val_satisfies_no_lhs_def
           by simp
         then show ?thesis
           unfolding satisfies_tableau_def
           using eq_for_lvar
           using \<open>xs \<in> lvars (\<T> (l' ! sp))\<close>
           by simp
       qed
       moreover
       have "lhs ?eq = xs"
         using \<open>xs \<in> lvars (\<T> (l' ! sp))\<close>
         using eq_for_lvar
         by simp
       ultimately
       show ?thesis
         unfolding satisfies_eq_def
         by auto
     qed
 
     have "\<not> in_bounds xr \<langle>?bl\<rangle> (\<B> ?sl)"
       using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>  \<open>swap_lr l sl xr\<close>
       using succ_min_lvar_not_in_bounds(1)[of ?sl "l ! (sl + 1)" xr]
       by simp
 
     have "\<forall> x. x < xr \<longrightarrow> in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)"
     proof (safe)
       fix x
       assume "x < xr"
       show "in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)"
       proof (cases "x \<in> lvars (\<T> ?sl)")
         case True
         then show ?thesis
           using succ_min_lvar_not_in_bounds(2)[of ?sl "l ! (sl + 1)" xr]
           using \<open>l ! sl \<succ> (l ! (sl + 1))\<close>  \<open>swap_lr l sl xr\<close> \<open>x < xr\<close>
           by simp
       next
         case False
         then show ?thesis
           using \<open>\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s ?sl\<close>
           unfolding curr_val_satisfies_no_lhs_def
           by (simp add: satisfies_bounds_set.simps)
       qed
     qed
 
     then have "in_bounds xs \<langle>?bl\<rangle> (\<B> ?sl)"
       using \<open>xs < xr\<close>
       by simp
 
     have "\<not> in_bounds xs \<langle>?bp\<rangle> (\<B> ?sp)"
       using \<open>l' ! sp \<succ> (l' ! (sp + 1))\<close>  \<open>swap_lr l' sp xs\<close>
       using succ_min_lvar_not_in_bounds(1)[of ?sp "l' ! (sp + 1)" xs]
       by simp
 
     have "\<forall> x \<in> rvars_eq ?eq. x > xr \<longrightarrow> \<langle>?bp\<rangle> x = \<langle>?bl\<rangle> x"
     proof (safe)
       fix x
       assume "x \<in> rvars_eq ?eq" "x > xr"
       then have "always_r l' 0 (length l' - 1) x"
       proof (safe)
         fix k
         assume "x \<in> rvars_eq ?eq" "x > xr" "0 \<le> k" "k \<le> length l' - 1"
         obtain k' where "l ! k' = l' ! k" "k' < length l"
           using l'_l \<open>k \<le> length l' - 1\<close> \<open>length l' > 1\<close>
           apply (cases "k > 0")
            apply (erule_tac x="k - 1" in allE)
            apply (drule mp)
           by auto
 
         let ?eq' = "eq_for_lvar (\<T> (l ! sp')) xs"
 
         have "\<forall> x \<in> rvars_eq ?eq'. x > xr \<longrightarrow> always_r l 0 (length l - 1) x"
         proof (safe)
           fix x k
           assume "x \<in> rvars_eq ?eq'" "xr < x" "0 \<le> k" "k \<le> length l - 1"
           then have "x \<in> rvars (\<T> (l ! sp'))"
             using eq_for_lvar[of xs "\<T> (l ! sp')"]
             using \<open>swap_lr l' sp xs\<close> \<open>l' ! sp = l ! sp'\<close>
             by (auto simp add: rvars_def)
           have *: "\<forall> i. i < sp' \<longrightarrow> x \<in> rvars (\<T> (l ! i))"
           proof (safe, rule ccontr)
             fix i
             assume "i < sp'" "x \<notin> rvars (\<T> (l ! i))"
             then have "x \<in> lvars (\<T> (l ! i))"
               using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
               using \<open>sp' + 1 < length l\<close>
               using \<open>succ_chain l\<close>
               using succ_chain_vars_id[of l i sp']
               by auto
             obtain i' where "swap_lr l i' x"
               using \<open>x \<in> lvars (\<T> (l ! i))\<close>
               using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
               using \<open>i < sp'\<close> \<open>sp' + 1 < length l\<close>
               using \<open>succ_chain l\<close>
               using succ_chain_swap_lr_exists[of l i sp' x]
               by auto
             then have "x \<in> ?enter_rvars"
               by auto
             then have "x \<le> ?xr"
               using \<open>finite ?enter_rvars\<close>
               using Max_ge[of ?enter_rvars x]
               by simp
             then show False
               using \<open>x > xr\<close>
               using \<open>xr = ?xr\<close>
               by simp
           qed
 
           then have "x \<in> rvars (\<T> (last l))"
             using \<open>hd l = s\<close> \<open>last l = s\<close> \<open>l \<noteq> []\<close>
             using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
             by (auto simp add: hd_conv_nth)
 
           show "x \<in> rvars (\<T> (l ! k))"
           proof (cases "k = length l - 1")
             case True
             then show ?thesis
               using \<open>x \<in> rvars (\<T> (last l))\<close>
               using \<open>l \<noteq> []\<close>
               by (simp add: last_conv_nth)
           next
             case False
             then have "k < length l - 1"
               using \<open>k \<le> length l - 1\<close>
               by simp
             then have "k < length l"
               using \<open>length l > 1\<close>
               by auto
             show ?thesis
             proof (rule ccontr)
               assume "\<not> ?thesis"
               then have "x \<in> lvars (\<T> (l ! k))"
                 using \<open>x \<in> rvars (\<T> (l ! sp'))\<close>
                 using \<open>sp' + 1 < length l\<close> \<open>k < length l\<close>
                 using succ_chain_vars_id[of l k sp']
                 using \<open>succ_chain l\<close> \<open>l \<noteq> []\<close>
                 by auto
               obtain i' where "swap_lr l i' x"
                 using \<open>succ_chain l\<close>
                 using \<open>x \<in> lvars (\<T> (l ! k))\<close>
                 using \<open>x \<in> rvars (\<T> (last l))\<close>
                 using \<open>k < length l - 1\<close> \<open>l \<noteq> []\<close>
                 using succ_chain_swap_lr_exists[of l k "length l - 1" x]
                 by (auto simp add: last_conv_nth)
               then have "x \<in> ?enter_rvars"
                 by auto
               then have "x \<le> ?xr"
                 using \<open>finite ?enter_rvars\<close>
                 using Max_ge[of ?enter_rvars x]
                 by simp
               then show False
                 using \<open>x > xr\<close>
                 using \<open>xr = ?xr\<close>
                 by simp
             qed
           qed
         qed
         then have "x \<in> rvars (\<T> (l ! k'))"
           using \<open>x \<in> rvars_eq ?eq\<close> \<open>x > xr\<close> \<open>k' < length l\<close>
           using \<open>l' ! sp = l ! sp'\<close>
           by simp
 
         then show "x \<in> rvars (\<T> (l' ! k))"
           using \<open>l ! k' = l' ! k\<close>
           by simp
       qed
       then have "\<langle>?bp\<rangle> x = \<langle>\<V> (l' ! (length l' - 1))\<rangle> x"
         using \<open>succ_chain l'\<close> \<open>sp + 1 < length l'\<close>
         by (auto intro!: succ_chain_always_r_valuation_id[rule_format])
       then have "\<langle>?bp\<rangle> x = \<langle>\<V> (last l')\<rangle> x"
         using \<open>l' \<noteq> []\<close>
         by (simp add: last_conv_nth)
       then show "\<langle>?bp\<rangle> x = \<langle>?bl\<rangle> x"
         using \<open>last l' = l ! sl\<close>
         by simp
     qed
 
     have "\<langle>?bp\<rangle> xr = \<langle>\<V> (l ! (sl + 1))\<rangle> xr"
       using \<open>\<langle>\<V> (l' ! 0)\<rangle> xr = \<langle>\<V> (l' ! sp)\<rangle> xr\<close>
       using \<open>hd l' = l ! (sl + 1)\<close> \<open>l' \<noteq> []\<close>
       by (simp add: hd_conv_nth)
 
     {
       fix dir1 dir2 :: "('i,'a) Direction"
       assume dir1: "dir1 = (if \<langle>?bl\<rangle> xr <\<^sub>l\<^sub>b \<B>\<^sub>l ?sl xr then Positive else Negative)"
       then have "\<lhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)"
         using \<open>\<not> in_bounds xr \<langle>?bl\<rangle> (\<B> ?sl)\<close>
         using neg_bounds_compare(7) neg_bounds_compare(3)
         by (auto simp add: bound_compare''_defs)
       then have "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)"
         using bounds_compare_contradictory(7) bounds_compare_contradictory(3) neg_bounds_compare(6) dir1
         unfolding bound_compare''_defs
         by auto force
       have "LB dir1 ?sl xr \<noteq> None"
         using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir1) (\<langle>?bl\<rangle> xr) (LB dir1 ?sl xr)\<close>
         by (cases "LB dir1 ?sl xr")  (auto simp add: bound_compare_defs)
 
       assume dir2: "dir2 = (if \<langle>?bp\<rangle> xs <\<^sub>l\<^sub>b \<B>\<^sub>l ?sp xs then Positive else Negative)"
       then have "\<lhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)"
         using \<open>\<not> in_bounds xs \<langle>?bp\<rangle> (\<B> ?sp)\<close>
         using neg_bounds_compare(2) neg_bounds_compare(6)
         by (auto simp add: bound_compare''_defs)
       then have "\<not> \<unrhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)"
         using bounds_compare_contradictory(3) bounds_compare_contradictory(7) neg_bounds_compare(6) dir2
         unfolding bound_compare''_defs
         by auto force
       then have "\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow> \<not> reasable_var dir2 x ?eq ?sp"
         using succ_min_rvar[of ?sp "l' ! (sp + 1)" xs xr ?eq]
         using \<open>l' ! sp \<succ> (l' ! (sp + 1))\<close>
         using \<open>swap_lr l' sp xs\<close> \<open>swap_rl l' sp xr\<close> dir2
         unfolding bound_compare''_defs
         by auto
 
       have "LB dir2 ?sp xs \<noteq> None"
         using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)\<close>
         by (cases "LB dir2 ?sp xs")  (auto simp add: bound_compare_defs)
 
       have *: "\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow>
         ((coeff (rhs ?eq) x > 0 \<longrightarrow> \<unrhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (UB dir2 ?sp x)) \<and>
          (coeff (rhs ?eq) x < 0 \<longrightarrow> \<unlhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (LB dir2 ?sp x)))"
       proof (safe)
         fix x
         assume "x \<in> rvars_eq ?eq" "x < xr" "coeff (rhs ?eq) x > 0"
         then have "\<not> \<lhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (UB dir2 ?sp x)"
           using \<open>\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow> \<not> reasable_var dir2 x ?eq ?sp\<close>
           by simp
         then show "\<unrhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (UB dir2 ?sp x)"
           using dir2 neg_bounds_compare(4) neg_bounds_compare(8)
           unfolding bound_compare''_defs
           by force
       next
         fix x
         assume "x \<in> rvars_eq ?eq" "x < xr" "coeff (rhs ?eq) x < 0"
         then have "\<not> \<rhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (LB dir2 ?sp x)"
           using \<open>\<forall> x \<in> rvars_eq ?eq. x < xr \<longrightarrow> \<not> reasable_var dir2 x ?eq ?sp\<close>
           by simp
         then show "\<unlhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> x) (LB dir2 ?sp x)"
           using dir2 neg_bounds_compare(4) neg_bounds_compare(8) dir2
           unfolding bound_compare''_defs
           by force
       qed
 
       have "(lt dir2) (\<langle>?bp\<rangle> xs) (\<langle>?bl\<rangle> xs)"
         using \<open>\<lhd>\<^sub>l\<^sub>b (lt dir2) (\<langle>?bp\<rangle> xs) (LB dir2 ?sp xs)\<close>
         using \<open>\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl\<close> dir2
         using \<open>in_bounds xs \<langle>?bl\<rangle> (\<B> ?sl)\<close>
         by (auto simp add: bound_compare''_defs
             simp: indexl_def indexu_def boundsl_def boundsu_def)
       then have "(lt dir2) 0 (\<langle>?bl\<rangle> xs - \<langle>?bp\<rangle> xs)"
         using dir2
         by (auto simp add: minus_gt[THEN sym] minus_lt[THEN sym])
 
       moreover
 
       have "le (lt dir2) ((rhs ?eq) \<lbrace> \<langle>?bl\<rangle> \<rbrace> - (rhs ?eq) \<lbrace> \<langle>?bp\<rangle> \<rbrace>) 0"
       proof-
         have "\<forall> x \<in> rvars_eq ?eq. (0 < coeff (rhs ?eq) x \<longrightarrow> le (lt dir2) 0 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x)) \<and>
                     (coeff (rhs ?eq) x < 0 \<longrightarrow> le (lt dir2) (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x) 0)"
         proof
           fix x
           assume "x \<in> rvars_eq ?eq"
           show "(0 < coeff (rhs ?eq) x \<longrightarrow> le (lt dir2) 0 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x)) \<and>
                 (coeff (rhs ?eq) x < 0 \<longrightarrow> le (lt dir2) (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x) 0)"
           proof (cases "x < xr")
             case True
             then have "in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)"
               using \<open>\<forall> x. x < xr \<longrightarrow> in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)\<close>
               by simp
             show ?thesis
             proof (safe)
               assume "coeff (rhs ?eq) x > 0" "0 \<noteq> \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x"
               then have "\<unrhd>\<^sub>u\<^sub>b (lt dir2) (\<langle>\<V> (l' ! sp)\<rangle> x) (UB dir2 (l' ! sp) x)"
                 using * \<open>x < xr\<close> \<open>x \<in> rvars_eq ?eq\<close>
                 by simp
               then have "le (lt dir2) (\<langle>?bl\<rangle> x) (\<langle>?bp\<rangle> x)"
                 using \<open>in_bounds x \<langle>?bl\<rangle> (\<B> ?sl)\<close> \<open>\<B>\<^sub>i ?sp = \<B>\<^sub>i ?sl\<close> dir2
                 apply (auto simp add: bound_compare''_defs)
                 using bounds_lg(3)[of "\<langle>?bp\<rangle> x" "\<B>\<^sub>u (l ! sl) x" "\<langle>?bl\<rangle> x"]
                 using bounds_lg(6)[of "\<langle>?bp\<rangle> x" "\<B>\<^sub>l (l ! sl) x" "\<langle>?bl\<rangle> x"]
                 unfolding bound_compare''_defs
                 by (auto simp: indexl_def indexu_def boundsl_def boundsu_def)
               then show "lt dir2 0 (\<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x)"
                 using \<open>0 \<noteq> \<langle>?bp\<rangle> x - \<langle>?bl\<rangle> x\<close>
                 using minus_gt[of "\<langle>?bl\<rangle> x" "\<langle>?bp\<rangle> x"] minus_lt[of "\<langle>?bp\<rangle> x" "\<langle>?bl\<rangle> x"] dir2
                 by auto
             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,235 @@
 (* Authors: F. Maric, M. Spasic *)
 section \<open>Auxiliary Results\<close>
 theory Simplex_Auxiliary
   imports 
-    "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