diff --git a/thys/ABY3_Protocols/Finite_Number_Type.thy b/thys/ABY3_Protocols/Finite_Number_Type.thy
--- a/thys/ABY3_Protocols/Finite_Number_Type.thy
+++ b/thys/ABY3_Protocols/Finite_Number_Type.thy
@@ -1,102 +1,102 @@
 theory Finite_Number_Type
   imports
     "HOL-Library.Cardinality"
 begin
 
 text \<open>
 To avoid carrying the modulo all the time, we introduce a new type for integers @{term "{0..<L}"}
 with the only restriction that the bound @{term L} must be greater than 1.
 It generalizes $Z_{2^k}$, the group considered in ABY3's additive secret sharing scheme.
 \<close>
 
 consts L :: nat 
 
 specification (L) L_gt_1: "L > 1"
   by auto
 
 typedef natL = "{0..<int L}"
   using L_gt_1 by auto
 
 setup_lifting type_definition_natL
 
 instantiation natL :: comm_ring_1
 begin
 
 lift_definition zero_natL :: natL is 0
   using L_gt_1 by simp
 
 lift_definition one_natL :: natL is 1
   using L_gt_1 by simp
 
 lift_definition uminus_natL :: "natL \<Rightarrow> natL" is "\<lambda>x. (-x) mod int L"
   by simp
 
 lift_definition plus_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is "\<lambda>x y. (x + y) mod int L"
   by simp
 
 lift_definition minus_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is "\<lambda>x y. (x - y) mod int L"
   by simp
 
 lift_definition times_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is "\<lambda>x y. (x * y) mod int L"
   by simp
 
 instance
   by (standard; (transfer, simp add: algebra_simps mod_simps))
 
 end
 typ int
 
 instantiation natL :: "{distrib_lattice, bounded_lattice, linorder}"
 begin
 
 lift_definition inf_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is inf
   unfolding inf_int_def by auto
 
 lift_definition sup_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is sup
   unfolding sup_int_def by auto
 
 lift_definition less_eq_natL :: "natL \<Rightarrow> natL \<Rightarrow> bool" is less_eq .
 
 lift_definition less_natL :: "natL \<Rightarrow> natL \<Rightarrow> bool" is less .
 
 lift_definition top_natL :: "natL" is "int L-1"
   using L_gt_1 by simp
 
 lift_definition bot_natL :: "natL" is 0
   using L_gt_1 by simp
 
 instance
   by (standard; (transfer, simp add: inf_int_def sup_int_def))+
 
 end
 
 instantiation natL :: semiring_modulo
 begin
 
 lift_definition divide_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is divide
   apply (auto simp: div_int_pos_iff)
-  by (smt div_by_0 div_by_1 zdiv_mono2)
+  by (smt (verit) div_by_0 div_by_1 zdiv_mono2)
 
 lift_definition modulo_natL :: "natL \<Rightarrow> natL \<Rightarrow> natL" is modulo
   apply (auto simp: mod_int_pos_iff)
-  by (smt zmod_le_nonneg_dividend)
+  by (smt (verit) zmod_le_nonneg_dividend)
 
 instance
   by (standard; (transfer, simp add: mod_simps))
 
 end
 
 instance natL :: finite
   apply standard
   unfolding type_definition.univ[OF type_definition_natL]
   by simp
 
 lemma natL_card[simp]:
   "CARD(natL) = L"
   unfolding type_definition.univ[OF type_definition_natL]
   apply (subst card_image)
   subgoal by (meson Abs_natL_inject inj_onI)
   subgoal by simp
   done
 
 end
\ No newline at end of file
diff --git a/thys/ABY3_Protocols/Shuffle.thy b/thys/ABY3_Protocols/Shuffle.thy
--- a/thys/ABY3_Protocols/Shuffle.thy
+++ b/thys/ABY3_Protocols/Shuffle.thy
@@ -1,2343 +1,2343 @@
 theory Shuffle
   imports 
     CryptHOL.CryptHOL
     Additive_Sharing
     Spmf_Common
     Sharing_Lemmas
 begin
 
 text \<open>
 This is the formalization of the array shuffling protocol defined in \cite{laud2016secure}
 adapted for the ABY3 sharing scheme.
 For the moment, we assume an oracle that generates uniformly distributed permutations,
 instead of instantiating it with e.g. Fischer-Yates algorithm.
 \<close>
 
 no_notation (ASCII) comp  (infixl "o" 55)
 no_notation m_inv ("inv\<index> _" [81] 80)
 
 no_adhoc_overloading Monad_Syntax.bind bind_pmf
 
 fun shuffleF :: "natL sharing list \<Rightarrow> natL sharing list spmf" where
   "shuffleF xsl = spmf_of_set (permutations_of_multiset (mset xsl))"
 
 type_synonym zero_sharing = "natL sharing list"
 type_synonym party2_data = "natL list"
 type_synonym party01_permutation = "nat \<Rightarrow> nat"
 type_synonym phase_msg = "zero_sharing \<times> party2_data \<times> party01_permutation"
 
 type_synonym role_msg = "(natL list \<times> natL list \<times> natL list) \<times> party2_data \<times> (party01_permutation \<times> party01_permutation)"
 
 (* (a, b, c) \<rightarrow> (a, b+c, 0) *)
 definition aby3_stack_sharing :: "Role \<Rightarrow> natL sharing \<Rightarrow> natL sharing" where
   "aby3_stack_sharing r s = make_sharing' r (next_role r) (prev_role r)
                              (get_party r s)
                              (get_party (next_role r) s + get_party (prev_role r) s)
                              0"
 
 (* one permutation step *)
 definition aby3_do_permute :: "Role \<Rightarrow> natL sharing list \<Rightarrow> (phase_msg \<times> natL sharing list) spmf" where
   "aby3_do_permute r x = (do {
     let n = length x;
     \<zeta> \<leftarrow> sequence_spmf (replicate n zero_sharing);
     \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
     let x2 = map (get_party (prev_role r)) x;
     let y' = map (aby3_stack_sharing r) x;
     let y = map2 (map_sharing2 (+)) (permute_list \<pi> y') \<zeta>;
     let msg = (\<zeta>, x2, \<pi>);
     return_spmf (msg, y)
   })"
 
 (* the shuffling protocol, consisting of three shuffling steps *)
 definition aby3_shuffleR :: "natL sharing list \<Rightarrow> (role_msg sharing \<times> natL sharing list) spmf" where
   "aby3_shuffleR x = (do {
     ((\<zeta>a,x',\<pi>a), a) \<leftarrow> aby3_do_permute Party1 x;     \<comment> \<open>1st round\<close>
     ((\<zeta>b,a',\<pi>b), b) \<leftarrow> aby3_do_permute Party2 a;     \<comment> \<open>2nd round\<close>
     ((\<zeta>c,b',\<pi>c), c) \<leftarrow> aby3_do_permute Party3 b;     \<comment> \<open>3rd round\<close>
     let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
     let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
     let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
     let msg = make_sharing msg1 msg2 msg3;
     return_spmf (msg, c)
   })"
 
 
 (* the ideal functionality of shuffling *)
 definition aby3_shuffleF :: "natL sharing list \<Rightarrow> natL sharing list spmf" where
   "aby3_shuffleF x = (do {
     \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<length x}};
     let x1 = map reconstruct x;
     let x\<pi> = permute_list \<pi> x1;
     y \<leftarrow> sequence_spmf (map share_nat x\<pi>);
     return_spmf y
   })"
 
 (* the simulator for party 1 *)
 definition S1 :: "natL list \<Rightarrow> natL list \<Rightarrow> role_msg spmf" where
     "S1 x1 yc1 = (do {
        let n = length x1;
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          ya1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          yb1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          yb2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) ya1 (permute_list \<pi>a x1);
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = yb1;
 
 \<comment> \<open>round 3\<close>
          let b' = yb2;
          let \<zeta>c1 = map2 (-) (yc1) (permute_list \<pi>c (map2 (+) yb1 yb2));  \<comment> \<open>non-free message\<close>
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf msg1
     })"
 
 (* the simulator for party 2 *)
 definition S2 :: "natL list \<Rightarrow> natL list \<Rightarrow> role_msg spmf" where
     "S2 x2 yc2 = (do {
        let n = length x2;
        x3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          ya2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          yb2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
 \<comment> \<open>round 1\<close>
          let x' = x3;
          let \<zeta>a2 = map2 (-) ya2 (permute_list \<pi>a (map2 (+) x2 x3));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) yb2 (permute_list \<pi>b ya2);
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = yc2;  \<comment> \<open>non-free message\<close>
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf msg2
     })"
 
 (* the simulator for party 3 *)
 definition S3 :: "natL list \<Rightarrow> natL list \<Rightarrow> role_msg spmf" where
     "S3 x3 yc3 = (do {
        let n = length x3;
 
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          ya3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          ya1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          yb3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = ya3;
 
 \<comment> \<open>round 2\<close>
          let a' = ya1;
          let \<zeta>b3 = map2 (-) yb3 (permute_list \<pi>b (map2 (+) ya3 ya1));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) yc3 (permute_list \<pi>c yb3);  \<comment> \<open>non-free message\<close>
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf msg3
 
     })"
 
 definition S :: "Role \<Rightarrow> natL list \<Rightarrow> natL list \<Rightarrow> role_msg spmf" where
   "S r = get_party r (make_sharing S1 S2 S3)"
   
 definition is_uniform_sharing_list :: "natL sharing list spmf \<Rightarrow> bool" where
   "is_uniform_sharing_list xss \<longleftrightarrow> (\<exists>xs. xss = bind_spmf xs (sequence_spmf \<circ> map share_nat))"
 
 lemma case_prod_nesting_same:
   "case_prod (\<lambda>a b. f (case_prod g x) a b ) x = case_prod (\<lambda>a b. f (g a b) a b ) x"
   by (cases x) simp
 
 lemma zip_map_map_same:
   "map (\<lambda>x. (f x, g x)) xs = zip (map f xs) (map g xs)"
   unfolding zip_map_map
   unfolding zip_same_conv_map
   by simp
 
 lemma dup_map_eq:
   "length xs = length ys \<Longrightarrow> (xs, map2 f ys xs) = (\<lambda>xys. (map fst xys, map snd xys)) (map2 (\<lambda>x y. (y, f x y)) ys xs)"
   by (auto simp: map_snd_zip[unfolded snd_def])
 
 
 abbreviation "map2_spmf f xs ys \<equiv> map_spmf (case_prod f) (pair_spmf xs ys)"
 abbreviation "map3_spmf f xs ys zs \<equiv> map2_spmf (\<lambda>a. case_prod (f a)) xs (pair_spmf ys zs)"
 
 lemma map_spmf_cong2:
   assumes "p = map_spmf m q" "\<And>x. x\<in>set_spmf q \<Longrightarrow> f (m x) = g x"
   shows "map_spmf f p = map_spmf g q"
   using assms by (simp add: spmf.map_comp cong: map_spmf_cong)
 
 lemma bind_spmf_cong2:
   assumes "p = map_spmf m q" "\<And>x. x\<in>set_spmf q \<Longrightarrow> f (m x) = g x"
   shows "bind_spmf p f = bind_spmf q g"
   using assms by (simp add: map_spmf_conv_bind_spmf cong: bind_spmf_cong)
 
 lemma map2_spmf_map2_sequence:
   "length xss = length yss \<Longrightarrow> map2_spmf (map2 f) (sequence_spmf xss) (sequence_spmf yss) = sequence_spmf (map2 (map2_spmf f) xss yss)"
   apply (induction xss yss rule: list_induct2)
   subgoal by simp
   subgoal premises IH for x xs y ys
     apply simp
     apply (fold IH)
     apply (unfold pair_map_spmf)
     apply (unfold spmf.map_comp)
     apply (rule map_spmf_cong2[where m="\<lambda>((x,y),(xs,ys)). ((x,xs),(y,ys))"])
     subgoal 
       unfolding pair_spmf_alt_def
       apply (simp add: map_spmf_conv_bind_spmf)
       apply (subst bind_commute_spmf[where q=y])
       ..
     subgoal by auto
     done
   done
 
 abbreviation map3 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list \<Rightarrow> 'd list" where
   "map3 f a b c \<equiv> map2 (\<lambda>a (b,c). f a b c) a (zip b c)"
 
 lemma map3_spmf_map3_sequence:
   "length xss = length yss \<Longrightarrow> length yss = length zss \<Longrightarrow> map3_spmf (map3 f) (sequence_spmf xss) (sequence_spmf yss) (sequence_spmf zss) = sequence_spmf (map3 (map3_spmf f) xss yss zss)"
   apply (induction xss yss zss rule: list_induct3)
   subgoal by simp
   subgoal premises IH for x xs y ys z zs
     apply simp
     apply (fold IH)
     apply (unfold pair_map_spmf)
     apply (unfold spmf.map_comp)
     apply (rule map_spmf_cong2[where m="\<lambda>((x,y,z),(xs,ys,zs)). ((x,xs),(y,ys),(z,zs))"])
     subgoal 
       unfolding pair_spmf_alt_def
       apply (simp add: map_spmf_conv_bind_spmf)
       apply (subst bind_commute_spmf[where q=y])
       apply (subst bind_commute_spmf[where q=z])
       apply (subst bind_commute_spmf[where q=z])
       ..
     subgoal by auto
     done
   done
 
 
 lemma in_pairD2:
   "x \<in> A \<times> B \<Longrightarrow> snd x \<in> B"
   by auto
 
 lemma list_map_cong2:
   "x = map m y \<Longrightarrow> (\<And>z. z\<in>set y =simp=> f (m z) = g z) \<Longrightarrow> map f x = map g y"
   unfolding simp_implies_def
   by simp
 
 lemma map_swap_zip:
   "map prod.swap (zip xs ys) = zip ys xs"
   apply (induction xs arbitrary: ys)
   subgoal by simp
   subgoal for x xs ys
     by (cases ys) auto
   done
 
 lemma inv_zero_sharing_sequence:
   "n = length x \<Longrightarrow>
    map_spmf (\<lambda>\<zeta>s. (\<zeta>s, map2 (map_sharing2 (+)) x \<zeta>s)) (sequence_spmf (replicate n zero_sharing))
    =
    map_spmf (\<lambda>ys. (map2 (map_sharing2 (-)) ys x, ys)) (sequence_spmf (map (share_nat \<circ>reconstruct) x))"
 proof -
   assume n: "n = length x"
   have "map_spmf (\<lambda>\<zeta>s. (\<zeta>s, map2 (map_sharing2 (+)) x \<zeta>s)) (sequence_spmf (replicate n zero_sharing))
 =
 map2_spmf (\<lambda>\<zeta>s x. (\<zeta>s, map2 (map_sharing2 (+)) x \<zeta>s)) (sequence_spmf (replicate n zero_sharing)) (sequence_spmf (map return_spmf x))"
     unfolding sequence_map_return_spmf
     apply (rule map_spmf_cong2[where m="fst"])
     subgoal by simp
     subgoal by (auto simp: case_prod_unfold dest: in_pairD2)
     done
 
   also have "... = map_spmf (\<lambda>\<zeta>xs. (map fst \<zeta>xs, map snd \<zeta>xs)) (map2_spmf (map2 (\<lambda>\<zeta> x. (\<zeta>, map_sharing2 (+) x \<zeta>))) (sequence_spmf (replicate n zero_sharing)) (sequence_spmf (map return_spmf x)))"
     apply (unfold spmf.map_comp)
     apply (rule map_spmf_cong[OF refl])
     using n by (auto simp: case_prod_unfold comp_def set_sequence_spmf list_all2_iff map_swap_zip intro: list_map_cong2[where m=prod.swap])
 
   also have "... = map_spmf (\<lambda>\<zeta>xs. (map fst \<zeta>xs, map snd \<zeta>xs)) (map2_spmf (map2 (\<lambda>y x. (map_sharing2 (-) y x, y))) (sequence_spmf (map (share_nat \<circ> reconstruct) x)) (sequence_spmf (map return_spmf x)))"
     apply (rule arg_cong[where f="map_spmf _"])
     using n     apply (simp add: map2_spmf_map2_sequence)
     apply (rule arg_cong[where f=sequence_spmf])
     apply (unfold list_eq_iff_nth_eq)
     apply safe
     subgoal by simp
     apply (simp add: )
     apply (subst map_spmf_cong2[where p="pair_spmf _ (return_spmf _)"])
       apply (rule pair_spmf_return_spmf2)
      apply simp
     apply (subst map_spmf_cong2[where p="pair_spmf _ (return_spmf _)"])
       apply (rule pair_spmf_return_spmf2)
      apply simp
     using inv_zero_sharing .
 
   also have "... = map2_spmf (\<lambda>ys x. (map2 (map_sharing2 (-)) ys x, ys)) (sequence_spmf (map (share_nat \<circ>reconstruct) x)) (sequence_spmf (map return_spmf x))"
     apply (unfold spmf.map_comp)
     apply (rule map_spmf_cong[OF refl])
     using n by (auto simp: case_prod_unfold comp_def set_sequence_spmf list_all2_iff map_swap_zip intro: list_map_cong2[where m=prod.swap])
 
   also have "... = map_spmf (\<lambda>ys. (map2 (map_sharing2 (-)) ys x, ys)) (sequence_spmf (map (share_nat \<circ>reconstruct) x))"
     unfolding sequence_map_return_spmf
     apply (rule map_spmf_cong2[where m="fst", symmetric])
     subgoal by simp
     subgoal by (auto simp: case_prod_unfold dest: in_pairD2)
     done
 
   finally show ?thesis .
 qed
 
 lemma get_party_map_sharing2:
   "get_party p \<circ> (case_prod (map_sharing2 f)) = case_prod f \<circ> map_prod (get_party p) (get_party p)"
   by auto
 
 lemma map_map_prod_zip:
   "map (map_prod f g) (zip xs ys) = zip (map f xs) (map g ys)"
   by (simp add: map_prod_def zip_map_map)
 
 lemma map_map_prod_zip':
   "map (h \<circ> map_prod f g) (zip xs ys) = map h (zip (map f xs) (map g ys))"
   by (simp add: map_prod_def zip_map_map)
 
 lemma eq_map_spmf_conv:
   assumes "\<And>x. f (f' x) = x" "f' = inv f" "map_spmf f' x = y"
   shows "x = map_spmf f y"
 proof -
   have surj: "surj f"
     apply (rule surjI) using assms(1) .
   have "map_spmf f (map_spmf f' x) = map_spmf f y"
     unfolding assms(3) ..
   thus ?thesis
     using assms(1) by (simp add: spmf.map_comp surj_iff comp_def)
 qed
 
 
 lemma lift_map_spmf_pairs:
   "map2_spmf f = F \<Longrightarrow> map_spmf (case_prod f) (pair_spmf A B) = F A B"
   by auto
 
 lemma measure_pair_spmf_times':
     "C = A \<times> B \<Longrightarrow> measure (measure_spmf (pair_spmf p q)) C = measure (measure_spmf p) A * measure (measure_spmf q) B"
   by (simp add: measure_pair_spmf_times)
 
 lemma map_spmf_pairs_tmp:
   "map_spmf (\<lambda>(a,b,c,d,e,f,g). (a,e,b,f,c,g,d)) (pair_spmf A (pair_spmf B (pair_spmf C (pair_spmf D (pair_spmf E (pair_spmf F G))))))
        = (pair_spmf A (pair_spmf E (pair_spmf B (pair_spmf F (pair_spmf C (pair_spmf G  D))))))"
   apply (rule spmf_eqI)
   apply (clarsimp simp add: spmf_map)
   subgoal for a e b f c g d
     apply (subst measure_pair_spmf_times'[where A="{a}"]) defer
     apply (subst measure_pair_spmf_times'[where A="{b}"]) defer
     apply (subst measure_pair_spmf_times'[where A="{c}"]) defer
     apply (subst measure_pair_spmf_times'[where A="{d}"]) defer
     apply (subst measure_pair_spmf_times'[where A="{e}"]) defer
          apply (subst measure_pair_spmf_times'[where A="{f}" and B="{g}"]) defer
           apply (auto simp: spmf_conv_measure_spmf)
     done
   done
 
 lemma case_case_prods_tmp:
   "(case case x of (a, b, c, d, e, f, g) \<Rightarrow> (a, e, b, f, c, g, d) of
                 (ya, yb, yc, yd, ye, yf, yg) \<Rightarrow> F ya yb yc yd ye yf yg)
       = (case x of (a,b,c,d,e,f,g) \<Rightarrow> F a e b f c g d)"
   by (cases x) simp
 
 lemma bind_spmf_permutes_cong:
   "(\<And>\<pi>. \<pi> permutes {..<(x::nat)} \<Longrightarrow> f \<pi> = g \<pi>)
     \<Longrightarrow> bind_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<x}}) f = bind_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<x}}) g"
   by (rule bind_spmf_cong[OF refl]) (simp add: set_spmf_of_set finite_permutations set_sequence_spmf[unfolded list_all2_iff])
 
 lemma map_eq_iff_list_all2:
   "map f xs = map g ys \<longleftrightarrow> list_all2 (\<lambda>x y. f x = g y) xs ys"
   apply (induction xs arbitrary: ys)
   subgoal by auto
   subgoal for x xs ys by (cases ys) (auto)
   done
 
 lemma bind_spmf_sequence_map_share_nat_cong:
   "(\<And>l. map reconstruct l = x \<Longrightarrow> f l = g l)
     \<Longrightarrow> bind_spmf (sequence_spmf (map share_nat x)) f = bind_spmf (sequence_spmf (map share_nat x)) g"
   subgoal premises prems
     apply (rule bind_spmf_cong[OF refl])
     apply (rule prems)
     unfolding set_sequence_spmf mem_Collect_eq
     apply (simp add: map_eq_iff_list_all2[where g=id, simplified])
     apply (simp add: list_all2_map2)
     apply (erule list_all2_mono)
     unfolding share_nat_def
     by simp
   done
 
 lemma map_reconstruct_comp_eq_iff:
   "(\<And>x. x\<in>set xs \<Longrightarrow> reconstruct (f x) = reconstruct x) \<Longrightarrow> map (reconstruct \<circ> f) xs = map reconstruct xs"
   by (induction xs) auto
 
 lemma permute_list_replicate:
   "p permutes {..<n} \<Longrightarrow> permute_list p (replicate n x) = replicate n x"
   apply (fold map_replicate_const[where lst="[0..<n]", simplified])
   apply (simp add: permute_list_map)
   unfolding map_replicate_const
   by simp
 
 lemma map2_minus_zero:
   "length xs = length ys \<Longrightarrow> (\<And>y::natL. y\<in>set ys \<Longrightarrow> y = 0) \<Longrightarrow> map2 (-) xs ys = xs"
   by (induction xs ys rule: list_induct2) auto
 
 lemma permute_comp_left_inj:
   "p permutes {..<n} \<Longrightarrow> inj (\<lambda>p'. p \<circ> p')"
   by (rule fun.inj_map) (rule permutes_inj_on)
 
 lemma permute_comp_left_inj_on:
   "p permutes {..<n} \<Longrightarrow> inj_on (\<lambda>p'. p \<circ> p') A"
   using permute_comp_left_inj inj_on_subset by blast
 
 lemma permute_comp_right_inj:
   "p permutes {..<n} \<Longrightarrow> inj (\<lambda>p'. p' \<circ> p)"
   using inj_onI comp_id o_assoc permutes_surj surj_iff
-  by (smt)
+  by (smt (verit))
 
 lemma permute_comp_right_inj_on:
   "p permutes {..<n} \<Longrightarrow> inj_on (\<lambda>p'. p' \<circ> p) A"
   using permute_comp_right_inj inj_on_subset by blast
 
 lemma permutes_inv_comp_left:
   "p permutes {..<n} \<Longrightarrow> inv (\<lambda>p'. p \<circ> p') = (\<lambda>p'. inv p \<circ> p')"
   by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc[symmetric])
 
 lemma permutes_inv_comp_right:
   "p permutes {..<n} \<Longrightarrow> inv (\<lambda>p'. p' \<circ> p) = (\<lambda>p'. p' \<circ> inv p)"
   by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc)
 
 lemma permutes_inv_comp_left_right:
   "\<pi>a permutes {..<n} \<Longrightarrow> \<pi>b permutes {..<n} \<Longrightarrow> inv (\<lambda>p'. \<pi>a \<circ> p' \<circ> \<pi>b) = (\<lambda>p'. inv \<pi>a \<circ> p' \<circ> inv \<pi>b)"
   by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc, simp add: permutes_inv_o comp_assoc[symmetric])
 
 lemma permutes_inv_comp_left_left:
   "\<pi>a permutes {..<n} \<Longrightarrow> \<pi>b permutes {..<n} \<Longrightarrow> inv (\<lambda>p'. \<pi>a \<circ> \<pi>b \<circ> p') = (\<lambda>p'. inv \<pi>b \<circ> inv \<pi>a \<circ> p')"
   by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc, simp add: permutes_inv_o comp_assoc[symmetric])
 
 lemma permutes_inv_comp_right_right:
   "\<pi>a permutes {..<n} \<Longrightarrow> \<pi>b permutes {..<n} \<Longrightarrow> inv (\<lambda>p'. p' \<circ> \<pi>a \<circ>  \<pi>b) = (\<lambda>p'. p' \<circ> inv \<pi>b \<circ> inv \<pi>a)"
   by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc, simp add: permutes_inv_o comp_assoc[symmetric])
 
 lemma image_compose_permutations_left_right:
   fixes S
   assumes "\<pi>a permutes S" "\<pi>b permutes S"
   shows "{\<pi>a \<circ> \<pi> \<circ> \<pi>b |\<pi>. \<pi> permutes S} = {\<pi>. \<pi> permutes S}"
 proof -
   have *: "(\<lambda>\<pi>. \<pi>a \<circ> \<pi> \<circ> \<pi>b) = (\<lambda>\<pi>'. \<pi>a \<circ> \<pi>') \<circ> (\<lambda>\<pi>. \<pi> \<circ> \<pi>b)"
     by (simp add: comp_def)
   then show ?thesis
     apply (fold image_Collect)
     apply (unfold *)
     apply (fold image_comp)
     apply (subst image_Collect)
     apply (unfold image_compose_permutations_right[OF assms(2)])
     apply (subst image_Collect)
     apply (unfold image_compose_permutations_left[OF assms(1)])
     ..
 qed
 
 lemma image_compose_permutations_left_left:
   fixes S
   assumes "\<pi>a permutes S" "\<pi>b permutes S"
   shows "{\<pi>a \<circ> \<pi>b \<circ> \<pi> |\<pi>. \<pi> permutes S} = {\<pi>. \<pi> permutes S}"
   using image_compose_permutations_left image_compose_permutations_right 
 proof -
   have *: "(\<lambda>\<pi>. \<pi>a \<circ> \<pi>b \<circ> \<pi>) = (\<lambda>\<pi>'. \<pi>a \<circ> \<pi>') \<circ> (\<lambda>\<pi>. \<pi>b \<circ> \<pi>)"
     by (simp add: comp_def)
   show ?thesis
     apply (fold image_Collect)
     apply (unfold *)
     apply (fold image_comp)
     apply (subst image_Collect)
     apply (unfold image_compose_permutations_left[OF assms(2)])
     apply (subst image_Collect)
     apply (unfold image_compose_permutations_left[OF assms(1)])
     ..
 qed
 
 lemma image_compose_permutations_right_right:
   fixes S
   assumes "\<pi>a permutes S" "\<pi>b permutes S"
   shows "{\<pi> \<circ> \<pi>a \<circ> \<pi>b |\<pi>. \<pi> permutes S} = {\<pi>. \<pi> permutes S}"
   using image_compose_permutations_left image_compose_permutations_right 
 proof -
   have *: "(\<lambda>\<pi>. \<pi> \<circ> \<pi>a \<circ> \<pi>b) = (\<lambda>\<pi>. \<pi> \<circ> \<pi>b) \<circ> (\<lambda>\<pi>'. \<pi>' \<circ> \<pi>a)"
     by (simp add: comp_def)
   show ?thesis
     apply (fold image_Collect)
     apply (unfold *)
     apply (fold image_comp)
     apply (subst image_Collect)
     apply (unfold image_compose_permutations_right[OF assms(1)])
     apply (subst image_Collect)
     apply (unfold image_compose_permutations_right[OF assms(2)])
     ..
 qed
 
 lemma random_perm_middle:
   defines "random_perm n \<equiv> spmf_of_set {\<pi>. \<pi> permutes {..<n::nat}}"
   shows
     "map_spmf (\<lambda>(\<pi>a,\<pi>b,\<pi>c). ((\<pi>a,\<pi>b,\<pi>c),\<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))
      = map_spmf (\<lambda>(\<pi>,\<pi>a,\<pi>c). ((\<pi>a,inv \<pi>a \<circ> \<pi> \<circ> inv \<pi>c,\<pi>c),\<pi>)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))"
     (is "?lhs = ?rhs")
 proof -
   have "?lhs = (do {\<pi>a \<leftarrow> random_perm n; \<pi>c \<leftarrow> random_perm n; (\<pi>b,p) \<leftarrow> map_spmf (\<lambda>\<pi>b. (\<pi>b,\<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (random_perm n); return_spmf ((\<pi>a, \<pi>b, \<pi>c), p)})"
     unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def
     apply simp
     apply (subst (4) bind_commute_spmf)
     ..
   also
   have "\<dots> = (do {\<pi>a \<leftarrow> random_perm n; \<pi>c \<leftarrow> random_perm n; map_spmf (\<lambda>p. ((\<pi>a, inv \<pi>a \<circ> p \<circ> inv \<pi>c,\<pi>c),p)) (random_perm n)})"
     unfolding random_perm_def
     supply [intro!] =
       bind_spmf_permutes_cong
     apply rule+
     apply (subst inv_uniform)
     subgoal for \<pi>a \<pi>c
       apply (rule inj_compose[unfolded comp_def, where f="\<lambda>p. p \<circ> \<pi>c"])
       subgoal by (rule permute_comp_right_inj_on)
       subgoal by (rule permute_comp_left_inj_on)
       done
     apply (simp add: permutes_inv_comp_left_right map_spmf_conv_bind_spmf image_Collect image_compose_permutations_left_right)
     done
   also
   have "\<dots> = ?rhs"
     unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def
     apply (subst (2) bind_commute_spmf)
     apply (subst (1) bind_commute_spmf)
     apply simp
     done
   finally show ?thesis .
 qed
 
 lemma random_perm_right:
   defines "random_perm n \<equiv> spmf_of_set {\<pi>. \<pi> permutes {..<n::nat}}"
   shows
     "map_spmf (\<lambda>(\<pi>a,\<pi>b,\<pi>c). ((\<pi>a,\<pi>b,\<pi>c),\<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))
      = map_spmf (\<lambda>(\<pi>,\<pi>a,\<pi>b). ((\<pi>a,\<pi>b,inv \<pi>b \<circ> inv \<pi>a \<circ> \<pi>),\<pi>)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))"
     (is "?lhs = ?rhs")
 proof -
   have "?lhs = (do {\<pi>a \<leftarrow> random_perm n; \<pi>b \<leftarrow> random_perm n; (\<pi>c,\<pi>) \<leftarrow> map_spmf (\<lambda>\<pi>c. (\<pi>c,\<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (random_perm n); return_spmf ((\<pi>a, \<pi>b, \<pi>c), \<pi>)})"
     unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def
     by simp
   also
   have "\<dots> = (do {\<pi>a \<leftarrow> random_perm n; \<pi>b \<leftarrow> random_perm n; map_spmf (\<lambda>\<pi>. ((\<pi>a, \<pi>b, inv \<pi>b \<circ> inv \<pi>a \<circ> \<pi>),\<pi>)) (random_perm n)})"
     unfolding random_perm_def
     supply [intro!] =
       bind_spmf_permutes_cong
     apply rule+
     apply (subst inv_uniform)
     subgoal
       apply (rule permute_comp_left_inj_on)
       using permutes_compose .
     apply (simp add: permutes_inv_comp_left_left map_spmf_conv_bind_spmf image_Collect image_compose_permutations_left_left)
     done
   also
   have "\<dots> = ?rhs"
     unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def
     apply (subst (2) bind_commute_spmf)
     apply (subst (1) bind_commute_spmf)
     apply simp
     done
   finally show ?thesis .
 qed
 
 lemma random_perm_left:
   defines "random_perm n \<equiv> spmf_of_set {\<pi>. \<pi> permutes {..<n::nat}}"
   shows
     "map_spmf (\<lambda>(\<pi>a,\<pi>b,\<pi>c). ((\<pi>a,\<pi>b,\<pi>c),\<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))
      = map_spmf (\<lambda>(\<pi>,\<pi>b,\<pi>c). ((\<pi> \<circ> inv \<pi>c \<circ> inv \<pi>b,\<pi>b,\<pi>c),\<pi>)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))"
     (is "?lhs = ?rhs")
 proof -
   have "?lhs = (do {\<pi>b \<leftarrow> random_perm n; \<pi>c \<leftarrow> random_perm n; (\<pi>a,\<pi>) \<leftarrow> map_spmf (\<lambda>\<pi>a. (\<pi>a,\<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (random_perm n); return_spmf ((\<pi>a, \<pi>b, \<pi>c), \<pi>)})"
     unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def
     apply simp
     apply (subst (4) bind_commute_spmf)
     apply (subst (3) bind_commute_spmf)
     ..
   also
   have "\<dots> = (do {\<pi>b \<leftarrow> random_perm n; \<pi>c \<leftarrow> random_perm n; map_spmf (\<lambda>\<pi>. ((\<pi> \<circ> inv \<pi>c \<circ> inv \<pi>b, \<pi>b, \<pi>c),\<pi>)) (random_perm n)})"
     unfolding random_perm_def
     supply [intro!] =
       bind_spmf_permutes_cong
     apply rule+
     apply (subst inv_uniform)
     subgoal
       apply (unfold comp_assoc)
       apply (rule permute_comp_right_inj_on)
       using permutes_compose .
     apply (simp add: permutes_inv_comp_right_right map_spmf_conv_bind_spmf image_Collect image_compose_permutations_right_right)
     done
   also
   have "\<dots> = ?rhs"
     unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def
     apply (subst (2) bind_commute_spmf)
     apply (subst (1) bind_commute_spmf)
     apply simp
     done
   finally show ?thesis .
 qed
 
 lemma case_prod_return_spmf:
   "case_prod (\<lambda>a b. return_spmf (f a b)) = (\<lambda>x. return_spmf (case_prod f x))"
   by auto
 
 lemma sequence_share_nat_calc':
   assumes "r1\<noteq>r2" "r2\<noteq>r3" "r3\<noteq>r1"
   shows
   "sequence_spmf (map share_nat xs) = (do {
     let n = length xs;
     let random_seq = sequence_spmf (replicate n (spmf_of_set UNIV));
     (dp, dpn) \<leftarrow> (pair_spmf random_seq random_seq);
     return_spmf (map3 (\<lambda>x a b. make_sharing' r1 r2 r3 a b (x - (a + b))) xs dp dpn)
   })" (is "_ = ?rhs")
 proof -
   have
   "sequence_spmf (map share_nat xs) = (do {
     let n = length xs;
     let random_seq = sequence_spmf (replicate n (spmf_of_set UNIV));
     (xs, dp, dpn) \<leftarrow> pair_spmf (sequence_spmf (map return_spmf xs)) (pair_spmf random_seq random_seq);
     return_spmf (map3 (\<lambda>x a b. make_sharing' r1 r2 r3 a b (x - (a + b))) xs dp dpn)
   })"
     apply (unfold Let_def)
     apply (unfold case_prod_return_spmf)
     apply (fold map_spmf_conv_bind_spmf)
     apply (subst map3_spmf_map3_sequence)
     subgoal by simp
     subgoal by simp
     apply (rule arg_cong[where f=sequence_spmf])
     apply (unfold map_eq_iff_list_all2)
     apply (rule list_all2_all_nthI)
     subgoal by simp
     unfolding share_nat_def_calc'[OF assms]
     apply (auto simp: map_spmf_conv_bind_spmf pair_spmf_alt_def)
     done
   also have "\<dots> = ?rhs"
     by (auto simp: pair_spmf_alt_def sequence_map_return_spmf)
   finally show ?thesis .
 qed
 
 
 lemma reconstruct_stack_sharing_eq_reconstruct:
   "reconstruct \<circ> aby3_stack_sharing r = reconstruct"
   unfolding aby3_stack_sharing_def reconstruct_def
   by (cases r) (auto simp: make_sharing'_sel)
 
 lemma map2_ignore1:
   "length xs = length ys \<Longrightarrow> map2 (\<lambda>_. f) xs ys = map f ys"
   apply (unfold map_eq_iff_list_all2)
   apply (rule list_all2_all_nthI)
   by auto
 
 lemma map2_ignore2:
   "length xs = length ys \<Longrightarrow> map2 (\<lambda>a b. f a) xs ys = map f xs"
   apply (unfold map_eq_iff_list_all2)
   apply (rule list_all2_all_nthI)
   by auto
 
 
 lemma map_sequence_share_nat_reconstruct:
   "map_spmf (\<lambda>x. (x, map reconstruct x)) (sequence_spmf (map share_nat y)) = map_spmf (\<lambda>x. (x, y)) (sequence_spmf (map share_nat y))"
   apply (unfold map_spmf_conv_bind_spmf)
   apply (rule bind_spmf_cong[OF refl])
   apply (auto simp: set_sequence_spmf list_eq_iff_nth_eq list_all2_conv_all_nth share_nat_def)
   done
 
 (* the main theorem of security of the shuffling protocol *)
 theorem shuffle_secrecy:
   assumes
     "is_uniform_sharing_list x_dist"
   shows
     "(do {
        x \<leftarrow> x_dist;
        (msg, y) \<leftarrow> aby3_shuffleR x;
        return_spmf (map (get_party r) x,
                     get_party r msg,
                     y)
      })
      =
      (do {
        x \<leftarrow> x_dist;
        y \<leftarrow> aby3_shuffleF x;
        let xr = map (get_party r) x;
        let yr = map (get_party r) y;
        msg \<leftarrow> S r xr yr;
        return_spmf (xr, msg, y)
      })"
     (is "?lhs = ?rhs")
 proof -
   obtain xs where xs: "x_dist = xs \<bind> (sequence_spmf \<circ> map share_nat)"
     using assms unfolding is_uniform_sharing_list_def by auto
 
   have left_unfolded:
     "(do {
        x \<leftarrow> x_dist;
        (msg, y) \<leftarrow> aby3_shuffleR x;
        return_spmf (map (get_party r) x, get_party r msg, y)})
      =
      (do {
        xs \<leftarrow> xs;
        x \<leftarrow> sequence_spmf (map share_nat xs); 
 
 \<comment> \<open>round 1\<close>
          let n = length x;
          \<zeta>a \<leftarrow> sequence_spmf (replicate n zero_sharing);
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let x' = map (get_party (prev_role Party1)) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let a = map2 (map_sharing2 (+)) (permute_list \<pi>a y') \<zeta>a;
 
 \<comment> \<open>round 2\<close>
          let n = length a;
          \<zeta>b \<leftarrow> sequence_spmf (replicate n zero_sharing);
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let a' = map (get_party (prev_role Party2)) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let b = map2 (map_sharing2 (+)) (permute_list \<pi>b y') \<zeta>b;
 
 \<comment> \<open>round 3\<close>
          let n = length b;
          \<zeta>c \<leftarrow> sequence_spmf (replicate n zero_sharing);
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let b' = map (get_party (prev_role Party3)) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let c = map2 (map_sharing2 (+)) (permute_list \<pi>c y') \<zeta>c;
 
        let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
        let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
        let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
        let msg = make_sharing msg1 msg2 msg3;
        return_spmf (map (get_party r) x, get_party r msg, c)
    })"
     unfolding xs aby3_shuffleR_def aby3_do_permute_def
     by (auto simp: case_prod_unfold Let_def)
 
   also have clarify_length:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs); 
 
 \<comment> \<open>round 1\<close>
          \<zeta>a \<leftarrow> sequence_spmf (replicate n zero_sharing);
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let x' = map (get_party (prev_role Party1)) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let a = map2 (map_sharing2 (+)) (permute_list \<pi>a y') \<zeta>a;
 
 \<comment> \<open>round 2\<close>
          \<zeta>b \<leftarrow> sequence_spmf (replicate n zero_sharing);
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let a' = map (get_party (prev_role Party2)) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let b = map2 (map_sharing2 (+)) (permute_list \<pi>b y') \<zeta>b;
 
 \<comment> \<open>round 3\<close>
          \<zeta>c \<leftarrow> sequence_spmf (replicate n zero_sharing);
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let b' = map (get_party (prev_role Party3)) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let c = map2 (map_sharing2 (+)) (permute_list \<pi>c y') \<zeta>c;
 
        let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
        let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
        let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
        let msg = make_sharing msg1 msg2 msg3;
        return_spmf (map (get_party r) x, get_party r msg, c)
    })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
     by (auto simp: Let_def)
 
   also have hoist_permutations:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs); 
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party (prev_role Party1)) x;
          let y' = map (aby3_stack_sharing Party1) x;
          \<zeta>a \<leftarrow> sequence_spmf (replicate n zero_sharing);
          let a = map2 (map_sharing2 (+)) (permute_list \<pi>a y') \<zeta>a;
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party (prev_role Party2)) a;
          let y' = map (aby3_stack_sharing Party2) a;
          \<zeta>b \<leftarrow> sequence_spmf (replicate n zero_sharing);
          let b = map2 (map_sharing2 (+)) (permute_list \<pi>b y') \<zeta>b;
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party (prev_role Party3)) b;
          let y' = map (aby3_stack_sharing Party3) b;
          \<zeta>c \<leftarrow> sequence_spmf (replicate n zero_sharing);
          let c = map2 (map_sharing2 (+)) (permute_list \<pi>c y') \<zeta>c;
 
        let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
        let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
        let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
        let msg = make_sharing msg1 msg2 msg3;
        return_spmf (map (get_party r) x, get_party r msg, c)
    })"
     apply (simp add: Let_def)
     apply (subst (1) bind_commute_spmf[where q="spmf_of_set _"])
     apply (subst (2) bind_commute_spmf[where q="spmf_of_set _"])
     apply (subst (2) bind_commute_spmf[where q="spmf_of_set _"])
     apply (subst (3) bind_commute_spmf[where q="spmf_of_set _"])
     apply (subst (3) bind_commute_spmf[where q="spmf_of_set _"])
     apply (subst (3) bind_commute_spmf[where q="spmf_of_set _"])
     by simp
 
   also have hoist_permutations:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs); 
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party (prev_role Party1)) x;
          let y' = map (aby3_stack_sharing Party1) x;
          a \<leftarrow> sequence_spmf (map (share_nat \<circ> reconstruct) (permute_list \<pi>a y'));
          let \<zeta>a = map2 (map_sharing2 (-)) a (permute_list \<pi>a y');
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party (prev_role Party2)) a;
          let y' = map (aby3_stack_sharing Party2) a;
          b \<leftarrow> sequence_spmf (map (share_nat \<circ> reconstruct) (permute_list \<pi>b y'));
          let \<zeta>b = map2 (map_sharing2 (-)) b (permute_list \<pi>b y');
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party (prev_role Party3)) b;
          let y' = map (aby3_stack_sharing Party3) b;
          c \<leftarrow> sequence_spmf (map (share_nat \<circ> reconstruct) (permute_list \<pi>c y'));
          let \<zeta>c = map2 (map_sharing2 (-)) c (permute_list \<pi>c y');
 
        let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
        let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
        let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
        let msg = make_sharing msg1 msg2 msg3;
        return_spmf (map (get_party r) x, get_party r msg, c)
    })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
     apply rule+
     apply (subst hoist_map_spmf[where s="sequence_spmf (replicate _ _)" and f = "map2 (map_sharing2 (+)) _"])
     apply (subst hoist_map_spmf'[where s="sequence_spmf (map _ _)" and f = "\<lambda>ys. map2 (map_sharing2 (-)) ys _"])
     apply (subst inv_zero_sharing_sequence)
     subgoal by simp
     apply (unfold map_spmf_conv_bind_spmf)
     apply (unfold bind_spmf_assoc)
     apply (unfold return_bind_spmf)
     apply rule+
     apply (subst (1 12) Let_def)
     apply rule+
 
     apply (subst hoist_map_spmf[where s="sequence_spmf (replicate _ _)" and f = "map2 (map_sharing2 (+)) _"])
     apply (subst hoist_map_spmf'[where s="sequence_spmf (map _ _)" and f = "\<lambda>ys. map2 (map_sharing2 (-)) ys _"])
     apply (subst inv_zero_sharing_sequence)
     subgoal by simp
     apply (unfold map_spmf_conv_bind_spmf)
     apply (unfold bind_spmf_assoc)
     apply (unfold return_bind_spmf)
     apply rule+
     apply (subst (1 9) Let_def)
     apply rule+
 
     apply (subst hoist_map_spmf[where s="sequence_spmf (replicate _ _)" and f = "map2 (map_sharing2 (+)) _"])
     apply (subst hoist_map_spmf'[where s="sequence_spmf (map _ _)" and f = "\<lambda>ys. map2 (map_sharing2 (-)) ys _"])
     apply (subst inv_zero_sharing_sequence)
     subgoal by simp
     apply (unfold map_spmf_conv_bind_spmf)
     apply (unfold bind_spmf_assoc)
     apply (unfold return_bind_spmf)
     apply rule+
     apply (subst (1 6) Let_def)
     apply rule+
 
     done
 
   also have reconstruct:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs); 
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party (prev_role Party1)) x;
          let y' = map (aby3_stack_sharing Party1) x;
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          let \<zeta>a = map2 (map_sharing2 (-)) a (permute_list \<pi>a y');
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party (prev_role Party2)) a;
          let y' = map (aby3_stack_sharing Party2) a;
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          let \<zeta>b = map2 (map_sharing2 (-)) b (permute_list \<pi>b y');
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party (prev_role Party3)) b;
          let y' = map (aby3_stack_sharing Party3) b;
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
          let \<zeta>c = map2 (map_sharing2 (-)) c (permute_list \<pi>c y');
 
        let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
        let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
        let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
        let msg = make_sharing msg1 msg2 msg3;
        return_spmf (map (get_party r) x, get_party r msg, c)
    })"
 
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       bind_spmf_sequence_map_share_nat_cong
 
     apply rule+
     apply (subst list.map_comp[symmetric])
     apply (rule bind_spmf_cong)
     subgoal by (auto simp:permute_list_map[symmetric] map_reconstruct_comp_eq_iff reconstruct_def set_sequence_spmf[unfolded list_all2_iff] make_sharing'_sel reconstruct_stack_sharing_eq_reconstruct comp_assoc)
     apply rule+
     apply (subst list.map_comp[symmetric])
     apply (rule bind_spmf_cong)
     subgoal for x l xa \<pi>a \<pi>b \<pi>c xb xc xd xe xf xg
       apply (subst permute_list_map[symmetric] )
       subgoal by (auto simp add: set_sequence_spmf[unfolded list_all2_iff])
       apply simp
       apply (subst map_reconstruct_comp_eq_iff)
       subgoal by (simp add: reconstruct_def make_sharing'_sel aby3_stack_sharing_def)
       unfolding set_sequence_spmf mem_Collect_eq 
       unfolding list_all2_map2
       apply (subst map_eq_iff_list_all2[where f=reconstruct and g=id and xs=xd and ys="permute_list \<pi>a x", simplified, THEN iffD2])
       subgoal by (erule list_all2_mono) (simp add: share_nat_def)
       apply (subst permute_list_compose)
       subgoal by auto
       ..
     apply rule+
     apply (subst list.map_comp[symmetric])
     apply (rule bind_spmf_cong)
     subgoal for x l xa \<pi>a \<pi>b \<pi>c xb xc xd xe xf xg xh xi xj xk
       apply (subst permute_list_map[symmetric] )
       subgoal by (auto simp add: set_sequence_spmf[unfolded list_all2_iff])
       apply simp
       apply (subst map_reconstruct_comp_eq_iff)
       subgoal by (simp add: reconstruct_def make_sharing'_sel aby3_stack_sharing_def)
       unfolding set_sequence_spmf mem_Collect_eq 
       unfolding list_all2_map2
       apply (subst map_eq_iff_list_all2[where f=reconstruct and g=id and xs=xh and ys="permute_list (\<pi>a \<circ> \<pi>b) x", simplified, THEN iffD2])
       subgoal by (erule list_all2_mono) (simp add: share_nat_def)
       apply (subst permute_list_compose[symmetric])
       subgoal by auto
       ..
     ..
 
   also have hoist:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party (prev_role Party1)) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a = map2 (map_sharing2 (-)) a (permute_list \<pi>a y');
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party (prev_role Party2)) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b = map2 (map_sharing2 (-)) b (permute_list \<pi>b y');
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party (prev_role Party3)) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c = map2 (map_sharing2 (-)) c (permute_list \<pi>c y');
 
        let msg1 = ((map (get_party Party1) \<zeta>a, map (get_party Party1) \<zeta>b, map (get_party Party1) \<zeta>c), b', \<pi>a, \<pi>c);
        let msg2 = ((map (get_party Party2) \<zeta>a, map (get_party Party2) \<zeta>b, map (get_party Party2) \<zeta>c), x', \<pi>a, \<pi>b);
        let msg3 = ((map (get_party Party3) \<zeta>a, map (get_party Party3) \<zeta>b, map (get_party Party3) \<zeta>c), a', \<pi>b, \<pi>c);
        let msg = make_sharing msg1 msg2 msg3;
        return_spmf (map (get_party r) x, get_party r msg, c)
    })"
     unfolding Let_def ..
   finally have hoisted_save: "?lhs = \<dots>" .
   let ?hoisted = \<dots>
 
   { assume r: "r = Party1"
     have project_to_Party1:
     "?hoisted = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a1 = map (case_prod (-)) (zip (map (get_party Party1) a) (map (get_party Party1) (permute_list \<pi>a y')));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b1 = map (case_prod (-)) (zip (map (get_party Party1) b) (map (get_party Party1) (permute_list \<pi>b y')));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c1 = map (case_prod (-)) (zip (map (get_party Party1) c) (map (get_party Party1) (permute_list \<pi>c y')));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
    })"
       by (simp add: r Let_def get_party_map_sharing2 map_map_prod_zip')
 
     also have project_to_Party1:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) y'));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b1 = map2 (-) (map (get_party Party1) b) (permute_list \<pi>b (map (get_party Party1) y'));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map (get_party Party1) y'));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
       ..
 
     also have reduce_Lets:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = map2 (-) (map (get_party Party1) b) (permute_list \<pi>b (replicate (length a) 0));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b)));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
       unfolding Let_def
       unfolding aby3_stack_sharing_def
       by (simp add: comp_def make_sharing'_sel map_replicate_const zip_map_map_same[symmetric])
 
     also have simplify_minus_zero:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = (map (get_party Party1) b);
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b)));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       apply rule+
       apply (subst permute_list_replicate)
       subgoal by simp
 
       apply (subst map2_minus_zero)
       subgoal by simp
       subgoal by simp
 
       ..
 
     also have break_perms_1:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          (\<pi>a,\<pi>b,\<pi>c) \<leftarrow> pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (spmf_of_set {\<pi>. \<pi> permutes {..<n}}));
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = (map (get_party Party1) b);
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b)));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
       unfolding pair_spmf_alt_def by simp
 
     also have break_perms_2:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          ((\<pi>a,\<pi>b,\<pi>c),\<pi>) \<leftarrow> map_spmf (\<lambda>(\<pi>a,\<pi>b,\<pi>c). ((\<pi>a,\<pi>b,\<pi>c), \<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (spmf_of_set {\<pi>. \<pi> permutes {..<n}})));
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = (map (get_party Party1) b);
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b)));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
       unfolding pair_spmf_alt_def map_spmf_conv_bind_spmf by simp
 
     also have break_perms_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let \<pi>b = inv \<pi>a \<circ> \<pi> \<circ> inv \<pi>c;
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = (map (get_party Party1) b);
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b)));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
       apply (unfold random_perm_middle)
       apply (unfold map_spmf_conv_bind_spmf pair_spmf_alt_def)
       by simp
 
     also have break_seqs_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
 
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let \<pi>b = inv \<pi>a \<circ> \<pi> \<circ> inv \<pi>c;
 
          a1 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          a2 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          let a = map3 (\<lambda>a b c. make_sharing b c (a - (b + c))) (permute_list \<pi>a xs) a1 a2;
          b1 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          b2 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          let b = map3 (\<lambda>a b c. make_sharing b c (a - (b + c))) (permute_list (\<pi>a \<circ> \<pi>b) xs) b1 b2;
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) (map (get_party Party1) a) (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = (map (get_party Party1) b);
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b)));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
       apply (unfold sequence_share_nat_calc'[of Party1 Party2 Party3, simplified])
       apply (simp add: pair_spmf_alt_def Let_def)
       done
 
     also have break_seqs_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
 
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          a2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          b1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          b2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a1 = map2 (-) a1 (permute_list \<pi>a (map (get_party Party1) x));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b1 = b1;
 
 \<comment> \<open>round 3\<close>
          let b' = b2;
          let \<zeta>c1 = map2 (-) (map (get_party Party1) c) (permute_list \<pi>c (map2 (+) b1 b2));
 
        let msg1 = ((\<zeta>a1, \<zeta>b1, \<zeta>c1), b', \<pi>a, \<pi>c);
        return_spmf (map (get_party Party1) x, msg1, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       unfolding Let_def
       apply rule+
       apply (auto simp: map2_ignore1 map2_ignore2 comp_def prod.case_distrib bind_spmf_const)
       done
 
     also have
       "\<dots> = (do {x \<leftarrow> x_dist; y \<leftarrow> aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \<leftarrow> S r xr yr; return_spmf (xr, msg, y)})"
       unfolding xs
       unfolding aby3_shuffleF_def
       apply (simp add: bind_spmf_const map_spmf_conv_bind_spmf)
       apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def])
       subgoal by simp
       apply simp
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
 
       apply (subst (3) hoist_map_spmf[where s="sequence_spmf (map share_nat _)" and f="map reconstruct"])
       apply (subst map_sequence_share_nat_reconstruct)
       apply (simp add: map_spmf_conv_bind_spmf)
       apply (subst Let_def)
 
       supply [intro!] =
         bind_spmf_cong[OF refl]
         let_cong[OF refl]
         prod.case_cong[OF refl]
         bind_spmf_sequence_map_cong
         bind_spmf_sequence_replicate_cong
         bind_spmf_permutes_cong
 
       supply [simp] = finite_permutations
 
       apply rule
       apply rule
       apply simp
       apply rule
       apply rule
       unfolding S_def S1_def r
       apply (simp add: Let_def)
       done
 
     finally have "?hoisted = \<dots>" .
   } note simulate_party1 = this
 
   { assume r: "r = Party2"
     have project_to_Party2:
     "?hoisted = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a2 = map (case_prod (-)) (zip (map (get_party Party2) a) (map (get_party Party2) (permute_list \<pi>a y')));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b2 = map (case_prod (-)) (zip (map (get_party Party2) b) (map (get_party Party2) (permute_list \<pi>b y')));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c2 = map (case_prod (-)) (zip (map (get_party Party2) c) (map (get_party Party2) (permute_list \<pi>c y')));
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
    })"
       by (simp add: r Let_def get_party_map_sharing2 map_map_prod_zip')
 
     also have project_to_Party2:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map (get_party Party2) y'));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) y'));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c2 = map2 (-) (map (get_party Party2) c) (permute_list \<pi>c (map (get_party Party2) y'));
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
       ..
 
     also have reduce_Lets:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x)));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) a));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = map2 (-) (map (get_party Party2) c) (permute_list \<pi>c (replicate (length b) 0));
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
 
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
       unfolding Let_def
       unfolding aby3_stack_sharing_def
       by (simp add: comp_def make_sharing'_sel map_replicate_const zip_map_map_same[symmetric])
 
     also have simplify_minus_zero:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x)));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) a));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = (map (get_party Party2) c);
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       apply rule+
       apply (subst permute_list_replicate)
       subgoal by simp
 
       apply (subst map2_minus_zero)
       subgoal by simp
       subgoal by simp
 
       ..
 
     also have break_perms_1:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          (\<pi>a,\<pi>b,\<pi>c) \<leftarrow> pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (spmf_of_set {\<pi>. \<pi> permutes {..<n}}));
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x)));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) a));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = (map (get_party Party2) c);
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
       unfolding pair_spmf_alt_def by simp
 
     also have break_perms_2:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          ((\<pi>a,\<pi>b,\<pi>c),\<pi>) \<leftarrow> map_spmf (\<lambda>(\<pi>a,\<pi>b,\<pi>c). ((\<pi>a,\<pi>b,\<pi>c), \<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (spmf_of_set {\<pi>. \<pi> permutes {..<n}})));
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x)));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) a));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = (map (get_party Party2) c);
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
       unfolding pair_spmf_alt_def map_spmf_conv_bind_spmf by simp
 
     also have break_perms_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let \<pi>c = inv \<pi>b \<circ> inv \<pi>a \<circ> \<pi>;
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x)));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) a));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = (map (get_party Party2) c);
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
       apply (unfold random_perm_right)
       apply (unfold map_spmf_conv_bind_spmf pair_spmf_alt_def)
       by simp
 
     also have break_seqs_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
 
        x2 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        x3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        let x = map3 (\<lambda>a b c. make_sharing' Party2 Party3 Party1 b c (a - (b + c))) xs x2 x3;
 
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a2 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          a3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          let a = map3 (\<lambda>a b c. make_sharing' Party2 Party3 Party1 b c (a - (b + c))) (permute_list \<pi>a xs) a2 a3;
          b2 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          b3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          let b = map3 (\<lambda>a b c. make_sharing' Party2 Party3 Party1 b c (a - (b + c))) (permute_list (\<pi>a \<circ> \<pi>b) xs) b2 b3;
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let \<zeta>a2 = map2 (-) (map (get_party Party2) a) (permute_list \<pi>a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x)));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) (map (get_party Party2) b) (permute_list \<pi>b (map (get_party Party2) a));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = (map (get_party Party2) c);
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (map (get_party Party2) x, msg2, c)
     })"
       apply (unfold sequence_share_nat_calc'[of Party2 Party3 Party1, simplified])
       apply (simp add: pair_spmf_alt_def Let_def)
       done
 
     also have break_seqs_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
 
        x2 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        x3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          a3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          b2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          b3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let x' = x3;
          let \<zeta>a2 = map2 (-) a2 (permute_list \<pi>a (map2 (+) x2 x3));
 
 \<comment> \<open>round 2\<close>
          let \<zeta>b2 = map2 (-) b2 (permute_list \<pi>b a2);
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c2 = (map (get_party Party2) c);
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, \<zeta>c2), x', \<pi>a, \<pi>b);
        return_spmf (x2, msg2, c)
 
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       unfolding Let_def
       apply rule+
       apply (auto simp: map2_ignore1 map2_ignore2 comp_def prod.case_distrib bind_spmf_const make_sharing'_sel)
       done
 
     also have
       "\<dots> = (do {x \<leftarrow> x_dist; y \<leftarrow> aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \<leftarrow> S r xr yr; return_spmf (xr, msg, y)})"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       unfolding xs
       unfolding aby3_shuffleF_def
       apply (simp add: bind_spmf_const map_spmf_conv_bind_spmf)
       apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def])
       subgoal by simp
       apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def])
       subgoal by simp
       apply simp
 
       apply rule
 
       apply (subst (2) sequence_share_nat_calc'[of Party2 Party3 Party1, simplified])
       apply (subst (2) Let_def)
       apply (simp add: pair_spmf_alt_def)
       apply (subst Let_def)
       unfolding S_def r
       apply (simp add: pair_spmf_alt_def comp_def prod.case_distrib map2_ignore2 make_sharing'_sel)
 
       apply (rule trans[rotated])
       apply (rule bind_spmf_sequence_replicate_cong)
        apply (rule bind_spmf_sequence_replicate_cong)
        apply (simp add: map2_ignore1 map2_ignore2)
       apply (subst bind_spmf_const)
       apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def])
       subgoal by simp
       apply simp
 
       apply (subst (2) bind_commute_spmf[where p="sequence_spmf (replicate _ _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
 
       apply rule
       apply rule
       apply rule
 
       unfolding S2_def Let_def
       apply simp
       done
 
     finally have "?hoisted = \<dots>" .
   } note simulate_party2 = this
 
 
   { assume r: "r = Party3"
     have project_to_Party3:
     "?hoisted = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a3 = map (case_prod (-)) (zip (map (get_party Party3) a) (map (get_party Party3) (permute_list \<pi>a y')));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b3 = map (case_prod (-)) (zip (map (get_party Party3) b) (map (get_party Party3) (permute_list \<pi>b y')));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c3 = map (case_prod (-)) (zip (map (get_party Party3) c) (map (get_party Party3) (permute_list \<pi>c y')));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
    })"
       by (simp add: r Let_def get_party_map_sharing2 map_map_prod_zip')
 
     also have project_to_Party1:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let x' = map (get_party Party3) x;
          let y' = map (aby3_stack_sharing Party1) x;
          let \<zeta>a3 = map2 (-) (map (get_party Party3) a) (permute_list \<pi>a (map (get_party Party3) y'));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let y' = map (aby3_stack_sharing Party2) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map (get_party Party3) y'));
 
 \<comment> \<open>round 3\<close>
          let b' = map (get_party Party2) b;
          let y' = map (aby3_stack_sharing Party3) b;
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) y'));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
 
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
 
       apply rule+
       apply (subst permute_list_map[symmetric])
       subgoal by simp
       ..
 
     also have reduce_Lets:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = map2 (-) (map (get_party Party3) a) (permute_list \<pi>a (replicate (length x) 0));
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a)));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) b));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
       unfolding Let_def
       unfolding aby3_stack_sharing_def
       by (simp add: comp_def make_sharing'_sel map_replicate_const zip_map_map_same[symmetric])
 
     also have simplify_minus_zero:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = (map (get_party Party3) a);
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a)));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) b));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
       apply rule+
       apply (subst permute_list_replicate)
       subgoal by simp
 
       apply (subst map2_minus_zero)
       subgoal by simp
       subgoal by simp
 
       ..
 
     also have break_perms_1:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          (\<pi>a,\<pi>b,\<pi>c) \<leftarrow> pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (spmf_of_set {\<pi>. \<pi> permutes {..<n}}));
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b \<circ> \<pi>c) xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = (map (get_party Party3) a);
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a)));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) b));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
       unfolding pair_spmf_alt_def by simp
 
     also have break_perms_2:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          ((\<pi>a,\<pi>b,\<pi>c),\<pi>) \<leftarrow> map_spmf (\<lambda>(\<pi>a,\<pi>b,\<pi>c). ((\<pi>a,\<pi>b,\<pi>c), \<pi>a \<circ> \<pi>b \<circ> \<pi>c)) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (pair_spmf (spmf_of_set {\<pi>. \<pi> permutes {..<n}}) (spmf_of_set {\<pi>. \<pi> permutes {..<n}})));
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = (map (get_party Party3) a);
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a)));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) b));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
       unfolding pair_spmf_alt_def map_spmf_conv_bind_spmf by simp
 
     also have break_perms_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let \<pi>a = \<pi> \<circ> inv \<pi>c \<circ> inv \<pi>b;
 
          a \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi>a xs));
          b \<leftarrow> sequence_spmf (map share_nat (permute_list (\<pi>a \<circ> \<pi>b) xs));
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = (map (get_party Party3) a);
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a)));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) b));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
       apply (unfold random_perm_left)
       apply (unfold map_spmf_conv_bind_spmf pair_spmf_alt_def)
       by (simp add: Let_def)
 
     also have break_seqs_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let \<pi>a = \<pi> \<circ> inv \<pi>c \<circ> inv \<pi>b;
 
          a3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          a1 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          let a = map3 (\<lambda>a b c. make_sharing' Party3 Party1 Party2 b c (a - (b + c))) (permute_list \<pi>a xs) a3 a1;
          b3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          b1 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          let b = map3 (\<lambda>a b c. make_sharing' Party3 Party1 Party2 b c (a - (b + c))) (permute_list (\<pi>a \<circ> \<pi>b) xs) b3 b1;
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = (map (get_party Party3) a);
 
 \<comment> \<open>round 2\<close>
          let a' = map (get_party Party1) a;
          let \<zeta>b3 = map2 (-) (map (get_party Party3) b) (permute_list \<pi>b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a)));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c (map (get_party Party3) b));
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
       apply (unfold sequence_share_nat_calc'[of Party3 Party1 Party2, simplified])
       apply (simp add: pair_spmf_alt_def Let_def)
       done
 
     also have break_seqs_3:
     "\<dots> = (do {
        xs \<leftarrow> xs;
        let n = length xs;
 
        x \<leftarrow> sequence_spmf (map share_nat xs);
 
          \<pi> \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
          let \<pi>a = \<pi> \<circ> inv \<pi>c \<circ> inv \<pi>b;
 
          a3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          a1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          b3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
          b1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
          c \<leftarrow> sequence_spmf (map share_nat (permute_list \<pi> xs));
 
 \<comment> \<open>round 1\<close>
          let \<zeta>a3 = a3;
 
 \<comment> \<open>round 2\<close>
          let a' = a1;
          let \<zeta>b3 = map2 (-) b3 (permute_list \<pi>b (map2 (+) a3 a1));
 
 \<comment> \<open>round 3\<close>
          let \<zeta>c3 = map2 (-) (map (get_party Party3) c) (permute_list \<pi>c b3);
 
        let msg3 = ((\<zeta>a3, \<zeta>b3, \<zeta>c3), a', \<pi>b, \<pi>c);
        return_spmf (map (get_party Party3) x, msg3, c)
     })"
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       unfolding Let_def
       apply rule+
       apply (auto simp: map2_ignore1 map2_ignore2 comp_def prod.case_distrib bind_spmf_const make_sharing'_sel)
       done
 
     also have
       "\<dots> = (do {x \<leftarrow> x_dist; y \<leftarrow> aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \<leftarrow> S r xr yr; return_spmf (xr, msg, y)})"
       unfolding xs
       unfolding aby3_shuffleF_def
       apply (subst bind_spmf_const)
       apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def])
       subgoal by simp
       apply (simp add:  map_spmf_conv_bind_spmf)
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
       apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"])
 
       apply (subst (3) hoist_map_spmf[where s="sequence_spmf (map share_nat _)" and f="map reconstruct"])
       apply (subst map_sequence_share_nat_reconstruct)
       apply (simp add: map_spmf_conv_bind_spmf)
       apply (subst Let_def)
 
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
 
     supply [simp] = finite_permutations
 
       apply rule
       apply rule
       apply simp
       apply rule
       apply rule
       unfolding S_def S3_def r
       apply (simp add: Let_def)
       done
 
     finally have "?hoisted = \<dots>" .
   } note simulate_party3 = this
 
   show ?thesis
     unfolding hoisted_save
     apply (cases r)
     subgoal using simulate_party1 .
     subgoal using simulate_party2 .
     subgoal using simulate_party3 .
     done
 qed
 
 
 lemma Collect_case_prod:
   "{f x y | x y. P x y} = (case_prod f) ` (Collect (case_prod P))"
   by auto
 
 lemma inj_split_Cons': "inj_on (\<lambda>(n, xs). n#xs) X"
   by (auto intro!: inj_onI)
 
 lemma finite_indicator_eq_sum:
   "finite A \<Longrightarrow> indicat_real A x = sum (indicat_real {x}) A"
   by (induction rule: finite_induct) (auto  simp: indicator_def)
 
 lemma spmf_of_set_Cons:
   "spmf_of_set (set_Cons A B) = map2_spmf (#) (spmf_of_set A) (spmf_of_set B)"
   unfolding set_Cons_def pair_spmf_of_set
   apply (rule spmf_eq_iff_set)
   subgoal unfolding Collect_case_prod apply (auto simp: set_spmf_of_set )
      apply (subst (asm) finite_image_iff)
     subgoal by (rule inj_split_Cons')
     subgoal by (auto simp: finite_cartesian_product_iff)
     done
   subgoal unfolding Collect_case_prod
     apply (auto simp: spmf_of_set map_spmf_conv_bind_spmf spmf_bind integral_spmf_of_set)
     apply (subst card_image)
     subgoal by (rule inj_split_Cons')
     apply (auto simp: card_eq_0_iff indicator_single_Some)
     apply (subst (asm) finite_indicator_eq_sum)
     subgoal by (simp add: finite_image_iff inj_split_Cons')
     apply (subst (asm) sum.reindex)
     subgoal by (simp add: finite_image_iff inj_split_Cons')
     apply (auto)
     done
   done
 
 lemma sequence_spmf_replicate:
   "sequence_spmf (replicate n (spmf_of_set A)) = spmf_of_set (listset (replicate n A))"
   apply (induction n)
   subgoal by (auto simp: spmf_of_set_singleton)
   subgoal by (auto simp: spmf_of_set_Cons)
   done
 
 lemma listset_replicate:
   "listset (replicate n A) = {l. length l = n \<and> set l \<subseteq> A}"
   apply (induction n)
    apply (auto simp: set_Cons_def)
   subgoal for n x
     by (cases x; simp)
   done
 
 lemma map2_map2_map3:
   "map2 f (map2 g x y) z = map3 (\<lambda>x y. f (g x y)) x y z"
   by (auto simp: zip_assoc map_zip_map)
 
 lemma inv_add_sequence:
   assumes "n = length x"
   shows "
   map_spmf (\<lambda>\<zeta>::natL list. (\<zeta>, map2 (+) \<zeta> x)) (sequence_spmf (replicate n (spmf_of_set UNIV)))
   =
   map_spmf (\<lambda>y. (map2 (-) y x, y)) (sequence_spmf (replicate n (spmf_of_set UNIV)))"
   unfolding sequence_spmf_replicate
   apply (subst map_spmf_of_set_inj_on)
   subgoal   unfolding inj_on_def by simp
   apply (subst map_spmf_of_set_inj_on)
   subgoal  unfolding inj_on_def by simp
   apply (rule arg_cong[where f="spmf_of_set"])
   using assms apply (auto simp: image_def listset_replicate map2_map2_map3 zip_same_conv_map map_zip_map2 map2_ignore2)
   done
   
 lemma S1_def_simplified:
     "S1 x1 yc1 = (do {
        let n = length x1;
 
        \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
        \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
        \<zeta>a1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        yb1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        yb2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
        let \<zeta>c1 = map2 (-) (yc1) (permute_list \<pi>c (map2 (+) yb1 yb2));
        return_spmf ((\<zeta>a1, yb1, \<zeta>c1), yb2, \<pi>a, \<pi>c)
     })"
 
   unfolding S1_def
 
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       bind_spmf_sequence_map_share_nat_cong
 
   apply rule
   apply rule
   apply rule
   apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\<lambda>x. map2 (-) x _"])
   apply (subst inv_add_sequence[symmetric])
   subgoal by simp
   unfolding map_spmf_conv_bind_spmf
   apply simp
   done
 
 lemma S2_def_simplified:
     "S2 x2 yc2 = (do {
        let n = length x2;
 
        x3 \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        \<pi>a \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
        \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
        \<zeta>a2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        \<zeta>b2::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
        let msg2 = ((\<zeta>a2, \<zeta>b2, yc2), x3, \<pi>a, \<pi>b);
        return_spmf msg2
     })"
   unfolding S2_def
 
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       bind_spmf_sequence_map_share_nat_cong
 
   apply rule
   apply rule
   apply rule
   apply rule
   apply (rule trans)
   apply (rule bind_spmf_sequence_replicate_cong)
 
   apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\<lambda>x. map2 (-) x _"])
   apply (subst inv_add_sequence[symmetric])
   subgoal by simp
    apply (rule refl)
   apply (unfold map_spmf_conv_bind_spmf)
   apply simp
   apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\<lambda>x. map2 (-) x _"])
   apply (subst inv_add_sequence[symmetric])
   subgoal by simp
   apply (unfold map_spmf_conv_bind_spmf)
   apply simp
   done
 
 lemma S3_def_simplified:
     "S3 x3 yc3 = (do {
        let n = length x3;
 
        \<pi>b \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
        \<pi>c \<leftarrow> spmf_of_set {\<pi>. \<pi> permutes {..<n}};
        ya3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        ya1::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
        \<zeta>b3::natL list \<leftarrow> sequence_spmf (replicate n (spmf_of_set UNIV));
 
        let \<zeta>c3 = map2 (-) yc3 (permute_list \<pi>c (map2 (+) \<zeta>b3 (permute_list \<pi>b (map2 (+) ya3 ya1))));
        return_spmf ((ya3, \<zeta>b3, \<zeta>c3), ya1, \<pi>b, \<pi>c)
     })"
 
   unfolding S3_def
 
     supply [intro!] =
       bind_spmf_cong[OF refl]
       let_cong[OF refl]
       prod.case_cong[OF refl]
       bind_spmf_sequence_map_cong
       bind_spmf_sequence_replicate_cong
       bind_spmf_permutes_cong
       bind_spmf_sequence_map_share_nat_cong
 
   apply rule
   apply rule
   apply rule
   apply rule
   apply rule
   apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\<lambda>x. map2 (-) x _"])
   apply (subst inv_add_sequence[symmetric])
   subgoal by simp
   apply (unfold map_spmf_conv_bind_spmf)
   apply simp
   done
 
 end
diff --git a/thys/ABY3_Protocols/Spmf_Common.thy b/thys/ABY3_Protocols/Spmf_Common.thy
--- a/thys/ABY3_Protocols/Spmf_Common.thy
+++ b/thys/ABY3_Protocols/Spmf_Common.thy
@@ -1,437 +1,437 @@
 theory Spmf_Common
   imports CryptHOL.CryptHOL
 begin
 
 no_adhoc_overloading Monad_Syntax.bind bind_pmf
 
 lemma mk_lossless_back_eq:
   "scale_spmf (weight_spmf s) (mk_lossless s) = s"
   unfolding mk_lossless_def
   unfolding scale_scale_spmf
   by (auto simp: field_simps weight_spmf_eq_0)
 
 
 lemma cond_spmf_enforce:
   "cond_spmf sx (Collect A) = mk_lossless (enforce_spmf A sx)"
   unfolding enforce_spmf_def
   unfolding cond_spmf_alt
   unfolding restrict_spmf_def
   unfolding enforce_option_alt_def
   apply (rule arg_cong[where f="mk_lossless"])
   apply (rule arg_cong[where f="\<lambda>x. map_pmf x sx"])
   apply (intro ext)
   apply (rule arg_cong[where f="Option.bind _"])
   apply auto
   done
 
 
 definition "rel_scale_spmf s t \<longleftrightarrow> (mk_lossless s = mk_lossless t)"
 
 lemma rel_scale_spmf_refl:
   "rel_scale_spmf s s"
   unfolding rel_scale_spmf_def ..
 
 lemma rel_scale_spmf_sym:
   "rel_scale_spmf s t \<Longrightarrow> rel_scale_spmf t s"
   unfolding rel_scale_spmf_def by simp
 
 lemma rel_scale_spmf_trans:
   "rel_scale_spmf s t \<Longrightarrow> rel_scale_spmf t u \<Longrightarrow> rel_scale_spmf s u"
   unfolding rel_scale_spmf_def by simp
 
 lemma rel_scale_spmf_equiv:
   "equivp rel_scale_spmf"
   using rel_scale_spmf_refl rel_scale_spmf_sym
   by (auto intro!: equivpI reflpI sympI transpI dest: rel_scale_spmf_trans)
 
 
 lemma spmf_eq_iff: "p = q \<longleftrightarrow> (\<forall>i. spmf p i = spmf q i)"
   using spmf_eqI by auto
 
 lemma spmf_eq_iff_set:
   "set_spmf a = set_spmf b \<Longrightarrow> (\<And>x. x \<in> set_spmf b \<Longrightarrow> spmf a x = spmf b x) \<Longrightarrow> a = b"
   using in_set_spmf_iff_spmf spmf_eq_iff
   by (metis)
 
 lemma rel_scale_spmf_None:
   "rel_scale_spmf s t \<Longrightarrow> s = return_pmf None \<longleftrightarrow> t = return_pmf None"
   unfolding rel_scale_spmf_def by auto
 
 lemma rel_scale_spmf_def_alt:
   "rel_scale_spmf s t \<longleftrightarrow> (\<exists>k>0. s = scale_spmf k t)"
 proof
   assume rel: "rel_scale_spmf s t"
   then consider (isNone) "s = return_pmf None \<and> t = return_pmf None" | (notNone) "weight_spmf s > 0 \<and> weight_spmf t > 0"
     using rel_scale_spmf_None weight_spmf_eq_0 zero_less_measure_iff by blast
   then show "\<exists>k>0. s = scale_spmf k t"
   proof cases
     case isNone
     show ?thesis
       apply (rule exI[of _ 1])
       using isNone by simp
   next
     case notNone
     have "scale_spmf (weight_spmf s) (mk_lossless s) = scale_spmf (weight_spmf s / weight_spmf t) t"
       unfolding rel[unfolded rel_scale_spmf_def]
       unfolding mk_lossless_def
       unfolding scale_scale_spmf
       by (auto simp: field_simps)
     then show "\<exists>k>0. s = scale_spmf k t"
       apply (unfold mk_lossless_back_eq)
       using notNone divide_pos_pos by blast
   qed
 next
   assume "\<exists>k>0. s = scale_spmf k t"
   then obtain k where kpos: "k>0" and st: "s = scale_spmf k t" by blast
   then consider (isNone) "weight_spmf s = 0 \<and> weight_spmf t = 0" | (notNone) "weight_spmf s > 0 \<and> weight_spmf t > 0"
     using zero_less_measure_iff mult_pos_pos zero_less_measure_iff by (fastforce simp: weight_scale_spmf)
   then show "rel_scale_spmf s t"
   proof cases
     case isNone
     then show ?thesis
       unfolding rel_scale_spmf_def weight_spmf_eq_0 by simp
   next
     case notNone
     then show ?thesis
       unfolding rel_scale_spmf_def
       unfolding mk_lossless_def
       unfolding st
       by (cases "k < inverse (weight_spmf t)")
         (auto simp: weight_scale_spmf scale_scale_spmf field_simps)
   qed
 qed
 
 lemma rel_scale_spmf_def_alt2:
   "rel_scale_spmf s t \<longleftrightarrow>
     (s = return_pmf None \<and> t = return_pmf None)
   | (weight_spmf s > 0 \<and> weight_spmf t > 0 \<and> s = scale_spmf (weight_spmf s / weight_spmf t) t)"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume rel: ?lhs
   then consider (isNone) "s = return_pmf None \<and> t = return_pmf None" | (notNone) "weight_spmf s > 0 \<and> weight_spmf t > 0"
     using rel_scale_spmf_None weight_spmf_eq_0 zero_less_measure_iff by blast
   thus ?rhs
   proof cases
     case notNone
     have "scale_spmf (weight_spmf s) (mk_lossless s) = scale_spmf (weight_spmf s / weight_spmf t) t"
       unfolding rel[unfolded rel_scale_spmf_def]
       unfolding mk_lossless_def
       unfolding scale_scale_spmf
       by (auto simp: field_simps)
     thus ?thesis
       apply (unfold mk_lossless_back_eq)
       using notNone by simp
   qed simp
 next
   assume ?rhs
   then show ?lhs
   proof cases
     case right
     then have gt0: "weight_spmf s > 0" "weight_spmf t > 0" and st: "s = scale_spmf (weight_spmf s / weight_spmf t) t"
       by auto
     then have "(1 / weight_spmf t) \<ge> (weight_spmf s / weight_spmf t)"
       using weight_spmf_le_1 divide_le_cancel by fastforce
     then show ?thesis
       unfolding rel_scale_spmf_def mk_lossless_def
       apply (subst (3) st)
       using gt0 by (auto simp: scale_scale_spmf field_simps)
   qed (simp add: rel_scale_spmf_refl)
 qed
 
 lemma rel_scale_spmf_scale:
   "r > 0 \<Longrightarrow> rel_scale_spmf s t \<Longrightarrow> rel_scale_spmf s (scale_spmf r t)"
   apply (unfold rel_scale_spmf_def_alt)
   by (metis rel_scale_spmf_def rel_scale_spmf_def_alt)
 
 lemma rel_scale_spmf_mk_lossless:
   "rel_scale_spmf s t \<Longrightarrow> rel_scale_spmf s (mk_lossless t)"
   unfolding rel_scale_spmf_def_alt
   unfolding mk_lossless_def
   apply (cases "weight_spmf t = 0")
   subgoal by(simp add: weight_spmf_eq_0)
   subgoal
     apply (auto simp: weight_spmf_eq_0 field_simps scale_scale_spmf)
     using rel_scale_spmf_def_alt rel_scale_spmf_def_alt2 by blast
   done
 
 lemma rel_scale_spmf_eq_iff:
   "rel_scale_spmf s t \<Longrightarrow> weight_spmf s = weight_spmf t \<Longrightarrow> s = t"
   unfolding rel_scale_spmf_def_alt2 by auto
 
 lemma rel_scale_spmf_set_restrict:
   "finite A \<Longrightarrow> rel_scale_spmf (restrict_spmf (spmf_of_set A) B) (spmf_of_set (A \<inter> B))"
   apply (unfold rel_scale_spmf_def)
   apply (fold cond_spmf_alt)
   apply (subst cond_spmf_spmf_of_set)
   subgoal .
   apply (unfold mk_lossless_spmf_of_set)
   ..
 
 lemma spmf_of_set_restrict_empty:
   "A \<inter> B = {} \<Longrightarrow> restrict_spmf (spmf_of_set A) B = return_pmf None"
   unfolding spmf_of_set_def
   by simp
 
 lemma spmf_of_set_restrict_scale:
   "finite A \<Longrightarrow> restrict_spmf (spmf_of_set A) B = scale_spmf (card (A\<inter>B) / card A) (spmf_of_set (A\<inter>B))"
   apply (rule rel_scale_spmf_eq_iff)
   subgoal
     apply (cases "A\<inter>B = {}")
     subgoal
       by (auto simp: spmf_of_set_restrict_empty intro: rel_scale_spmf_refl)
     subgoal
       apply (rule rel_scale_spmf_scale)
       subgoal
         by (metis card_gt_0_iff divide_pos_pos finite_Int inf_bot_left of_nat_0_less_iff)
       subgoal by (rule rel_scale_spmf_set_restrict)
       done
     done
   subgoal
     apply (auto simp add: weight_scale_spmf measure_spmf_of_set)
     by (smt (verit, best) card_gt_0_iff card_mono disjoint_notin1 divide_le_eq_1_pos finite_Int inf_le1 of_nat_0_less_iff of_nat_le_iff)
   done
 
 lemma min_em2:
   "min a b = c \<Longrightarrow> a\<noteq>c \<Longrightarrow> b=c"
   unfolding min_def by auto
 
 lemma weight_0_spmf:
   "weight_spmf s = 0 \<Longrightarrow> spmf s i = 0"
   using order_trans[OF spmf_le_weight, of s 0 i] by simp
 
 lemma mk_lossless_scale_absorb:
   "r > 0 \<Longrightarrow> mk_lossless (scale_spmf r s) = mk_lossless s"
   apply (rule rel_scale_spmf_eq_iff)
   subgoal
     apply (rule rel_scale_spmf_trans[where t=s])
     subgoal
       apply (rule rel_scale_spmf_sym)
       apply (rule rel_scale_spmf_mk_lossless)
       apply (rule rel_scale_spmf_scale)
       subgoal .
       subgoal by (rule rel_scale_spmf_refl)
       done
     subgoal
       apply (rule rel_scale_spmf_mk_lossless)
       apply (rule rel_scale_spmf_refl)
       done
     done
   subgoal
     unfolding weight_mk_lossless
     by (auto simp flip: weight_spmf_eq_0 simp: weight_scale_spmf dest: min_em2)
   done
 
 lemma scale_spmf_None_iff:
   "scale_spmf k s = return_pmf None \<longleftrightarrow> k\<le>0 \<or> s=return_pmf None"
   apply (auto simp: spmf_eq_iff spmf_scale_spmf)
   using
     inverse_nonpositive_iff_nonpositive
     weight_0_spmf
     measure_le_0_iff
-  by smt
+  by (smt (verit))
 
 lemma spmf_of_pmf_the:
   "lossless_spmf s \<Longrightarrow> spmf_of_pmf (map_pmf the s) = s"
   unfolding lossless_spmf_conv_spmf_of_pmf by auto
 
 lemma lossless_mk_lossless:
   "s \<noteq> return_pmf None \<Longrightarrow> lossless_spmf (mk_lossless s)"
   unfolding lossless_spmf_def
   unfolding weight_mk_lossless
   by simp
 
 definition pmf_of_spmf where
   "pmf_of_spmf p = map_pmf the (mk_lossless p)"
 
 lemma scale_weight_spmf_of_pmf:
   "p = scale_spmf (weight_spmf p) (spmf_of_pmf (pmf_of_spmf p))"
   unfolding pmf_of_spmf_def
   apply (cases "p = return_pmf None")
   subgoal by simp
   subgoal
     apply (subst mk_lossless_back_eq[of p, symmetric])
     apply (rule arg_cong[where f="scale_spmf _ "])
     apply (rule spmf_of_pmf_the[symmetric])
     by (fact lossless_mk_lossless)
   done
 
 lemma pmf_spmf:
   "pmf_of_spmf (spmf_of_pmf p) = p"
   unfolding pmf_of_spmf_def
   unfolding lossless_spmf_spmf_of_spmf[THEN mk_lossless_lossless]
   unfolding map_the_spmf_of_pmf
   ..
 
 lemma spmf_pmf:
   "lossless_spmf p \<Longrightarrow> spmf_of_pmf (pmf_of_spmf p) = p"
   unfolding pmf_of_spmf_def
   by (simp add: spmf_of_pmf_the)
 
 lemma pmf_of_spmf_scale_spmf:
   "r > 0 \<Longrightarrow> pmf_of_spmf (scale_spmf r p) = pmf_of_spmf p"
   unfolding pmf_of_spmf_def
   by (simp add: mk_lossless_scale_absorb)
 
 lemma nonempty_spmf_weight:
   "p \<noteq> return_pmf None \<longleftrightarrow> weight_spmf p > 0"
   apply (fold weight_spmf_eq_0)
   using dual_order.not_eq_order_implies_strict[OF _ weight_spmf_nonneg[of p]]
   by auto
 
 lemma pmf_of_spmf_mk_lossless:
   "pmf_of_spmf (mk_lossless p) = pmf_of_spmf p"
   apply (cases "p = return_pmf None")
   subgoal by auto
   apply (unfold mk_lossless_def)
   apply (subst pmf_of_spmf_scale_spmf)
   subgoal by (simp add: nonempty_spmf_weight)
   ..
 
 lemma spmf_pmf':
   "p \<noteq> return_pmf None \<Longrightarrow> spmf_of_pmf (pmf_of_spmf p) = mk_lossless p"
   apply (subst spmf_pmf[of "mk_lossless p", symmetric])
    apply (unfold pmf_of_spmf_mk_lossless)
   subgoal using lossless_mk_lossless .
   subgoal ..
   done
 
 lemma rel_scale_spmf_cond_UNIV:
   "rel_scale_spmf s (cond_spmf s UNIV)"
   unfolding cond_spmf_UNIV
   by (rule rel_scale_spmf_mk_lossless) (rule rel_scale_spmf_refl)
 
 lemma "set_pmf p \<inter> g \<noteq> {} \<Longrightarrow> pmf_prob p (f \<inter> g) = pmf_prob (cond_pmf p g) f * pmf_prob p g"
   using measure_cond_pmf
   unfolding pmf_prob_def
   by (metis Int_commute divide_eq_eq measure_measure_pmf_not_zero)
 
 lemma bayes:
   "set_pmf p \<inter> A \<noteq> {} \<Longrightarrow> set_pmf p \<inter> B \<noteq> {} \<Longrightarrow>
    measure_pmf.prob (cond_pmf p A) B
  = measure_pmf.prob (cond_pmf p B) A * measure_pmf.prob p B / measure_pmf.prob p A"
   unfolding measure_cond_pmf
   by (subst inf_commute) (simp add: measure_pmf_zero_iff)
 
 definition spmf_prob :: "'a spmf \<Rightarrow> 'a set \<Rightarrow> real" where
   "spmf_prob p = Sigma_Algebra.measure (measure_spmf p)"
 
 lemma "spmf_prob = measure_measure_spmf"
   unfolding spmf_prob_def measure_measure_spmf_def ..
 
 lemma spmf_prob_pmf:
   "spmf_prob p A = pmf_prob p (Some ` A)"
   unfolding spmf_prob_def pmf_prob_def
   unfolding measure_measure_spmf_conv_measure_pmf
   ..
 
 lemma bayes_spmf:
   "spmf_prob (cond_spmf p A) B
  = spmf_prob (cond_spmf p B) A * spmf_prob p B / spmf_prob p A"
   unfolding spmf_prob_def
   unfolding measure_cond_spmf
   by (subst inf_commute) (auto simp: measure_spmf_zero_iff)
 
 lemma spmf_prob_pmf_of_spmf:
   "spmf_prob p A = weight_spmf p * pmf_prob (pmf_of_spmf p) A"
   apply (subst scale_weight_spmf_of_pmf)
   apply (unfold spmf_prob_def)
   apply (subst measure_spmf_scale_spmf')
   subgoal using weight_spmf_le_1 .
   by (simp add: pmf_prob_def)
 
 lemma cond_spmf_Int:
   "cond_spmf (cond_spmf p A) B = cond_spmf p (A \<inter> B)"
   apply (rule spmf_eqI)
   apply (unfold spmf_cond_spmf)
   apply(auto simp add: measure_cond_spmf split: if_split_asm)
   using Int_lower1[THEN measure_spmf.finite_measure_mono[simplified]]  measure_le_0_iff
   by metis
 
 lemma cond_spmf_prob:
   "spmf_prob p (A \<inter> B) = spmf_prob (cond_spmf p A) B * spmf_prob p A"
   unfolding spmf_prob_def measure_cond_spmf
   using Int_lower1[THEN measure_spmf.finite_measure_mono[simplified]]  measure_le_0_iff
   by (metis mult_eq_0_iff nonzero_eq_divide_eq)
 
 definition "empty_spmf = return_pmf None"
 
 lemma spmf_prob_empty:
   "spmf_prob empty_spmf A = 0"
   unfolding spmf_prob_def empty_spmf_def
   by simp
 
 definition le_spmf :: "'a spmf \<Rightarrow> 'a spmf \<Rightarrow> bool" where
   "le_spmf p q \<longleftrightarrow> (\<exists>k\<le>1. p = scale_spmf k q)"
 
 definition lt_spmf :: "'a spmf \<Rightarrow> 'a spmf \<Rightarrow> bool" where
   "lt_spmf p q \<longleftrightarrow> (\<exists>k<1. p = scale_spmf k q)"
 
 lemma "class.order_bot empty_spmf le_spmf lt_spmf"
   oops
 
 lemma spmf_prob_cond_Int:
   "spmf_prob (cond_spmf p C) (A \<inter> B)
    = spmf_prob (cond_spmf p (B \<inter> C)) A * spmf_prob (cond_spmf p C) B"
   apply (subst Int_commute[of B C])
   apply (subst Int_commute[of A B])
   apply (fold cond_spmf_Int)
   using cond_spmf_prob .
 
 lemma cond_spmf_mk_lossless:
   "cond_spmf (mk_lossless p) A = cond_spmf p A"
   apply (fold cond_spmf_UNIV)
   apply (unfold cond_spmf_Int)
   by simp
 
 primrec sequence_spmf :: "'a spmf list \<Rightarrow> 'a list spmf" where
   "sequence_spmf [] = return_spmf []"
 | "sequence_spmf (x#xs) = map_spmf (case_prod Cons) (pair_spmf x (sequence_spmf xs))"
 
 lemma set_sequence_spmf:
   "set_spmf (sequence_spmf xs) = {l. list_all2 (\<lambda>x s. x \<in> set_spmf s) l xs}"
   by (induction xs) (auto simp: list_all2_Cons2)
 
 lemma map_spmf_map_sequence:
   "map_spmf (map f) (sequence_spmf xs) = sequence_spmf (map (map_spmf f) xs)"
   apply (induction xs)
   subgoal by simp
   subgoal premises IH
     unfolding list.map
     unfolding sequence_spmf.simps
     apply (fold IH)
     apply (unfold pair_map_spmf)
     apply (unfold spmf.map_comp)
     by (simp add: comp_def case_prod_map_prod prod.case_distrib)
   done
 
 lemma sequence_map_return_spmf:
   "sequence_spmf (map return_spmf xs) = return_spmf xs"
   by (induction xs) auto
 
 lemma sequence_bind_cong:
   "\<lbrakk>xs=ys; \<And>y. length y = length ys \<Longrightarrow> f y = g y\<rbrakk> \<Longrightarrow> bind_spmf (sequence_spmf xs) f = bind_spmf (sequence_spmf ys) g"
   apply (rule bind_spmf_cong)
   subgoal by simp
   subgoal unfolding set_sequence_spmf list_all2_iff by simp
   done
 
 lemma bind_spmf_sequence_replicate_cong:
   "(\<And>l. length l = n \<Longrightarrow> f l = g l)
     \<Longrightarrow> bind_spmf (sequence_spmf (replicate n x)) f = bind_spmf (sequence_spmf (replicate n x)) g"
   by (rule bind_spmf_cong[OF refl]) (simp add: set_spmf_of_set finite_permutations set_sequence_spmf[unfolded list_all2_iff])
 
 lemma bind_spmf_sequence_map_cong:
   "(\<And>l. length l = length x \<Longrightarrow> f l = g l)
     \<Longrightarrow> bind_spmf (sequence_spmf (map m x)) f = bind_spmf (sequence_spmf (map m x)) g"
   by (rule bind_spmf_cong[OF refl]) (simp add: set_spmf_of_set finite_permutations set_sequence_spmf[unfolded list_all2_iff])
 
 lemma lossless_pair_spmf_iff:
   "lossless_spmf (pair_spmf a b) \<longleftrightarrow> lossless_spmf a \<and> lossless_spmf b"
   unfolding pair_spmf_alt_def
   by (auto simp: set_spmf_eq_empty)
 
 lemma lossless_sequence_spmf:
   "(\<And>x. x\<in>set xs \<Longrightarrow> lossless_spmf x) \<Longrightarrow> lossless_spmf (sequence_spmf xs)"
   by (induction xs) (auto simp: lossless_pair_spmf_iff)
 
 end
\ No newline at end of file
diff --git a/thys/Approximation_Algorithms/Approx_BP_Hoare.thy b/thys/Approximation_Algorithms/Approx_BP_Hoare.thy
--- a/thys/Approximation_Algorithms/Approx_BP_Hoare.thy
+++ b/thys/Approximation_Algorithms/Approx_BP_Hoare.thy
@@ -1,1708 +1,1708 @@
 section \<open>Bin Packing\<close>
 
 theory Approx_BP_Hoare
   imports Complex_Main "HOL-Hoare.Hoare_Logic" "HOL-Library.Disjoint_Sets"
 begin
 
 text \<open>The algorithm and proofs are based on the work by Berghammer and Reuter \<^cite>\<open>BerghammerR03\<close>.\<close>
 
 subsection \<open>Formalization of a Correct Bin Packing\<close>
 
 text \<open>Definition of the unary operator \<open>\<lbrakk>\<cdot>\<rbrakk>\<close> from the article.
       \<open>B\<close> will only be wrapped into a set if it is non-empty.\<close>
 definition wrap :: "'a set \<Rightarrow> 'a set set" where
   "wrap B = (if B = {} then {} else {B})"
 
 lemma wrap_card:
   "card (wrap B) \<le> 1"
   unfolding wrap_def by auto
 
 text \<open>If \<open>M\<close> and \<open>N\<close> are pairwise disjoint with \<open>V\<close> and not yet contained in V,
       then the union of \<open>M\<close> and \<open>N\<close> is also pairwise disjoint with \<open>V\<close>.\<close>
 lemma pairwise_disjnt_Un:
   assumes "pairwise disjnt ({M} \<union> {N} \<union> V)" "M \<notin> V" "N \<notin> V"
   shows "pairwise disjnt ({M \<union> N} \<union> V)"
   using assms unfolding pairwise_def by auto
 
 text \<open>A Bin Packing Problem is defined like in the article:\<close>
 locale BinPacking =
   fixes U :: "'a set" \<comment> \<open>A finite, non-empty set of objects\<close>
     and w :: "'a \<Rightarrow> real" \<comment> \<open>A mapping from objects to their respective weights (positive real numbers)\<close>
     and c :: nat \<comment> \<open>The maximum capacity of a bin (a natural number)\<close>
     and S :: "'a set" \<comment> \<open>The set of \<open>small\<close> objects (weight no larger than \<open>1/2\<close> of \<open>c\<close>)\<close>
     and L :: "'a set" \<comment> \<open>The set of \<open>large\<close> objects (weight larger than \<open>1/2\<close> of \<open>c\<close>)\<close>
   assumes weight: "\<forall>u \<in> U. 0 < w(u) \<and> w(u) \<le> c"
       and U_Finite: "finite U"
       and U_NE: "U \<noteq> {}"
       and S_def: "S = {u \<in> U. w(u) \<le> c / 2}"
       and L_def: "L = U - S"
 begin
 
 text \<open>In the article, this is defined as \<open>w\<close> as well. However, to avoid ambiguity,
       we will abbreviate the weight of a bin as \<open>W\<close>.\<close>
 abbreviation W :: "'a set \<Rightarrow> real" where
   "W B \<equiv> (\<Sum>u \<in> B. w(u))"
 
 text \<open>\<open>P\<close> constitutes as a correct bin packing if \<open>P\<close> is a partition of \<open>U\<close>
       (as defined in @{thm [source] partition_on_def}) and the weights of
       the bins do not exceed their maximum capacity \<open>c\<close>.\<close>
 definition bp :: "'a set set \<Rightarrow> bool" where
   "bp P \<longleftrightarrow> partition_on U P \<and> (\<forall>B \<in> P. W(B) \<le> c)"
 
 lemma bpE:
   assumes "bp P"
   shows "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
   using assms unfolding bp_def partition_on_def by blast+
 
 lemma bpI:
   assumes "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
   shows "bp P"
   using assms unfolding bp_def partition_on_def by blast
 
 text \<open>Although we assume the \<open>S\<close> and \<open>L\<close> sets as given, manually obtaining them from \<open>U\<close> is trivial
       and can be achieved in linear time. Proposed by the article \<^cite>\<open>"BerghammerR03"\<close>.\<close>
 lemma S_L_set_generation:
 "VARS S L W u
   {True}
   S := {}; L := {}; W := U;
   WHILE W \<noteq> {}
   INV {W \<subseteq> U \<and> S = {v \<in> U - W. w(v) \<le> c / 2} \<and> L = {v \<in> U - W. w(v) > c / 2}} DO
     u := (SOME u. u \<in> W);
     IF 2 * w(u) \<le> c
     THEN S := S \<union> {u}
     ELSE L := L \<union> {u} FI;
     W := W - {u}
   OD
   {S = {v \<in> U. w(v) \<le> c / 2} \<and> L = {v \<in> U. w(v) > c / 2}}"
   by vcg (auto simp: some_in_eq)
 
 subsection \<open>The Proposed Approximation Algorithm\<close>
 
 subsubsection \<open>Functional Correctness\<close>
 
 text \<open>According to the article, \<open>inv\<^sub>1\<close> holds if \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}\<close>
       is a correct solution for the bin packing problem \<^cite>\<open>BerghammerR03\<close>. However, various
       assumptions made in the article seem to suggest that more information is demanded from this
       invariant and, indeed, mere correctness (as defined in @{thm [source] bp_def}) does not appear to suffice.
       To amend this, four additional conjuncts have been added to this invariant, whose necessity
       will be explained in the following proofs. It should be noted that there may be other (shorter) ways to amend this invariant.
       This approach, however, makes for rather straight-forward proofs, as these conjuncts can be utilized and proved in relatively few steps.\<close>
 definition inv\<^sub>1 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}) \<comment> \<open>A correct solution to the bin packing problem\<close>
                        \<and> \<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V \<comment> \<open>The partial solution does not contain objects that have not yet been assigned\<close>
                        \<and> B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<comment> \<open>\<open>B\<^sub>1\<close> is distinct from all the other bins\<close>
                        \<and> B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2) \<comment> \<open>\<open>B\<^sub>2\<close> is distinct from all the other bins\<close>
                        \<and> (P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {} \<comment> \<open>The first and second partial solutions are disjoint from each other.\<close>"
 (*
 lemma "partition_on U (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}) \<Longrightarrow> u \<in> V \<Longrightarrow>
 partition_on U (P\<^sub>1 \<union> wrap (insert u B\<^sub>1) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> (V-{u})})"
   nitpick*)
 lemma inv\<^sub>1E:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   shows "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V})"
     and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
     and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
     and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
     and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
   using assms unfolding inv\<^sub>1_def by auto
 
 lemma inv\<^sub>1I:
   assumes "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V})"
     and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
     and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
     and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
     and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
   shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   using assms unfolding inv\<^sub>1_def by blast
 
 lemma wrap_Un [simp]: "wrap (M \<union> {x}) = {M \<union> {x}}" unfolding wrap_def by simp
 lemma wrap_empty [simp]: "wrap {} = {}" unfolding wrap_def by simp
 lemma wrap_not_empty [simp]: "M \<noteq> {} \<longleftrightarrow> wrap M = {M}" unfolding wrap_def by simp
 
 text \<open>If \<open>inv\<^sub>1\<close> holds for the current partial solution, and the weight of an object \<open>u \<in> V\<close> added to \<open>B\<^sub>1\<close> does
       not exceed its capacity, then \<open>inv\<^sub>1\<close> also holds if \<open>B\<^sub>1\<close> and \<open>{u}\<close> are replaced by \<open>B\<^sub>1 \<union> {u}\<close>.\<close>
 lemma inv\<^sub>1_stepA:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W(B\<^sub>1) + w(u) \<le> c"
   shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
 
   text \<open>In the proof for \<open>Theorem 3.2\<close> of the article it is erroneously argued that
         if \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}\<close> is a partition of \<open>U\<close>,
         then the same holds if \<open>B\<^sub>1\<close> is replaced by \<open>B\<^sub>1 \<union> {u}\<close>.
         This is, however, not necessarily the case if \<open>B\<^sub>1\<close> or \<open>{u}\<close> are already contained in the partial solution.
         Suppose \<open>P\<^sub>1\<close> contains the non-empty bin \<open>B\<^sub>1\<close>, then \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close> would still be pairwise disjoint, provided \<open>P\<^sub>1\<close> was pairwise disjoint before, as the union simply ignores the duplicate \<open>B\<^sub>1\<close>. Now, if the algorithm modifies \<open>B\<^sub>1\<close> by adding an element from \<open>V\<close> such that \<open>B\<^sub>1\<close> becomes some non-empty \<open>B\<^sub>1'\<close> with \<open>B\<^sub>1 \<inter> B\<^sub>1' \<noteq> \<emptyset>\<close> and \<open>B\<^sub>1' \<notin> P\<^sub>1\<close>, one can see that this property would no longer be preserved.
         To avoid such a situation, we will use the first additional conjunct in \<open>inv\<^sub>1\<close> to ensure that \<open>{u}\<close>
         is not yet contained in the partial solution, and the second additional conjunct to ensure that \<open>B\<^sub>1\<close>
         is not yet contained in the partial solution.\<close>
 
   \<comment> \<open>Rule 1: Pairwise Disjoint\<close>
   have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. u \<notin> M"
     using invrules(2) assms(2) by blast
   have "{{v} |v. v \<in> V} = {{u}} \<union> {{v} |v. v \<in> V - {u}}"
     using assms(2) by blast
   then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> ({{u}} \<union> {{v} |v. v \<in> V - {u}}))"
     using bprules(1) assms(2) by simp
   then have "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}})" by (simp add: Un_commute)
   then have assm: "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))" by (simp add: Un_assoc)
   have "pairwise disjnt ({B\<^sub>1 \<union> {u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))"
   proof (cases \<open>B\<^sub>1 = {}\<close>)
     case True with assm show ?thesis by simp
   next
     case False
     with assm have assm: "pairwise disjnt ({B\<^sub>1} \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))" by simp
     from NOTIN have "{u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}" by blast
     from pairwise_disjnt_Un[OF assm _ this] invrules(2,3) show ?thesis
       using False by auto
   qed
   then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}})"
     unfolding wrap_Un by simp
 
   \<comment> \<open>Rule 2: No empty sets\<close>
   from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}"
     unfolding wrap_def by simp
 
   \<comment> \<open>Rule 3: Union preserved\<close>
   from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}}) = U"
     using assms(2) by blast
   then have 3: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}) = U"
     unfolding wrap_def by force
 
   \<comment> \<open>Rule 4: Weights below capacity\<close>
   have "0 < w u" using weight assms(2) bprules(3) by blast
   have "finite B\<^sub>1" using bprules(3) U_Finite by (cases \<open>B\<^sub>1 = {}\<close>) auto
   then have "W (B\<^sub>1 \<union> {u}) \<le> W B\<^sub>1 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>1\<close>) (auto simp: insert_absorb)
   also have "... \<le> c" using assms(3) .
   finally have "W (B\<^sub>1 \<union> {u}) \<le> c" .
   then have "\<forall>B \<in> wrap (B\<^sub>1 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
   moreover have "\<forall>B\<in>P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c"
     using bprules(4) by blast
   ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c" by blast
   from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}})" .
 
   \<comment> \<open>Auxiliary information is preserved\<close>
   have "u \<in> U" using assms(2) bprules(3) by blast
   then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
   have L: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
     unfolding wrap_def using NOTIN by auto
   have 2: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - (V - {u})"
     unfolding L R invrules(2) ..
   have 3: "B\<^sub>1 \<union> {u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2"
     using NOTIN by auto
   have 4: "B\<^sub>2 \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2"
     using invrules(4) NOTIN unfolding wrap_def by fastforce
   have 5: "(P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u})) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
     using invrules(5) NOTIN unfolding wrap_Un by auto
 
   from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
 qed
 
 text \<open>If \<open>inv\<^sub>1\<close> holds for the current partial solution, and the weight of an object \<open>u \<in> V\<close> added to \<open>B\<^sub>2\<close> does
       not exceed its capacity, then \<open>inv\<^sub>1\<close> also holds if \<open>B\<^sub>2\<close> and \<open>{u}\<close> are replaced by \<open>B\<^sub>2 \<union> {u}\<close>.\<close>
 lemma inv\<^sub>1_stepB:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W B\<^sub>2 + w u \<le> c"
   shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
 
 text \<open>The argumentation here is similar to the one in @{thm [source] inv\<^sub>1_stepA} with
       \<open>B\<^sub>1\<close> replaced with \<open>B\<^sub>2\<close> and using the first and third additional conjuncts of \<open>inv\<^sub>1\<close>
       to amend the issue, instead of the first and second.\<close>
   \<comment> \<open>Rule 1: Pairwise Disjoint\<close>
   have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. u \<notin> M"
     using invrules(2) assms(2) by blast
   have "{{v} |v. v \<in> V} = {{u}} \<union> {{v} |v. v \<in> V - {u}}"
     using assms(2) by blast
   then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}})"
     using bprules(1) assms(2) by simp
   then have assm: "pairwise disjnt (wrap B\<^sub>2 \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))"
     by (simp add: Un_assoc Un_commute)
   have "pairwise disjnt ({B\<^sub>2 \<union> {u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))"
   proof (cases \<open>B\<^sub>2 = {}\<close>)
     case True with assm show ?thesis by simp
   next
     case False
     with assm have assm: "pairwise disjnt ({B\<^sub>2} \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))" by simp
     from NOTIN have "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}" by blast
     from pairwise_disjnt_Un[OF assm _ this] invrules(2,4) show ?thesis
       using False by auto
   qed
   then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}})"
     unfolding wrap_Un by simp
 
   \<comment> \<open>Rule 2: No empty sets\<close>
   from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}}"
     unfolding wrap_def by simp
 
   \<comment> \<open>Rule 3: Union preserved\<close>
   from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}}) = U"
     using assms(2) by blast
   then have 3: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}}) = U"
     unfolding wrap_def by force
 
   \<comment> \<open>Rule 4: Weights below capacity\<close>
   have "0 < w u" using weight assms(2) bprules(3) by blast
   have "finite B\<^sub>2" using bprules(3) U_Finite by (cases \<open>B\<^sub>2 = {}\<close>) auto
   then have "W (B\<^sub>2 \<union> {u}) \<le> W B\<^sub>2 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>2\<close>) (auto simp: insert_absorb)
   also have "... \<le> c" using assms(3) .
   finally have "W (B\<^sub>2 \<union> {u}) \<le> c" .
   then have "\<forall>B \<in> wrap (B\<^sub>2 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
   moreover have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c"
     using bprules(4) by blast
   ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c"
     by auto
   from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}})" .
 
   \<comment> \<open>Auxiliary information is preserved\<close>
   have "u \<in> U" using assms(2) bprules(3) by blast
   then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
   have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
     unfolding wrap_def using NOTIN by auto
   have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = U - (V - {u})"
     unfolding L R using invrules(2) by simp
   have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})"
     using bpE(2)[OF 1] by simp
   have 4: "B\<^sub>2 \<union> {u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2"
     using NOTIN by auto
   have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = {}"
     using invrules(5) NOTIN unfolding wrap_empty wrap_Un by auto
 
   from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
 qed
 
 text \<open>If \<open>inv\<^sub>1\<close> holds for the current partial solution, then \<open>inv\<^sub>1\<close> also holds if \<open>B\<^sub>1\<close> and \<open>B\<^sub>2\<close> are
       added to \<open>P\<^sub>1\<close> and \<open>P\<^sub>2\<close> respectively, \<open>B\<^sub>1\<close> is emptied and \<open>B\<^sub>2\<close> initialized with \<open>u \<in> V\<close>.\<close>
 lemma inv\<^sub>1_stepC:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V"
   shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)]
   \<comment> \<open>Rule 1-4: Correct Bin Packing\<close>
   have "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} |v. v \<in> V - {u}}
       = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}}"
     by (metis (no_types, lifting) Un_assoc Un_empty_right insert_not_empty wrap_empty wrap_not_empty)
   also have "... = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}"
     using assms(2) by auto
   finally have EQ: "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} |v. v \<in> V - {u}}
                   = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}" .
   from invrules(1) have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} |v. v \<in> V - {u}})"
     unfolding EQ .
 
   \<comment> \<open>Auxiliary information is preserved\<close>
   have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. u \<notin> M"
     using invrules(2) assms(2) by blast
   have "u \<in> U" using assms(2) bpE(3)[OF invrules(1)] by blast
   then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
   have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}"
     unfolding wrap_def using NOTIN by auto
   have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = U - (V - {u})"
     unfolding L R using invrules(2) by auto
   have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}"
     using bpE(2)[OF 1] by simp
   have 4: "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using NOTIN by auto
   have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}) = {}"
     using invrules(5) NOTIN unfolding wrap_def by force
 
   from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
 qed
 
 text \<open>A simplified version of the bin packing algorithm proposed in the article.
       It serves as an introduction into the approach taken, and, while it does not provide the desired
       approximation factor, it does ensure that \<open>P\<close> is a correct solution of the bin packing problem.\<close>
 lemma simple_bp_correct:
 "VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u
   {True}
   P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; V := U;
   WHILE V \<inter> S \<noteq> {} INV {inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V} DO
     u := (SOME u. u \<in> V); V := V - {u};
     IF W(B\<^sub>1) + w(u) \<le> c
     THEN B\<^sub>1 := B\<^sub>1 \<union> {u}
     ELSE IF W(B\<^sub>2) + w(u) \<le> c
          THEN B\<^sub>2 := B\<^sub>2 \<union> {u}
          ELSE P\<^sub>2 := P\<^sub>2 \<union> wrap B\<^sub>2; B\<^sub>2 := {u} FI;
          P\<^sub>1 := P\<^sub>1 \<union> wrap B\<^sub>1; B\<^sub>1 := {} FI
   OD;
   P := P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} | v. v \<in> V}
   {bp P}"
 proof (vcg, goal_cases)
   case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
   show ?case
     unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def
     using weight by auto
 next
   case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
   then have INV: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" ..
   from 2 have "V \<noteq> {}" by blast
   then have IN: "(SOME u. u \<in> V) \<in> V" by (simp add: some_in_eq)
   from inv\<^sub>1_stepA[OF INV IN] inv\<^sub>1_stepB[OF INV IN] inv\<^sub>1_stepC[OF INV IN]
   show ?case by blast
 next
   case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
   then show ?case unfolding inv\<^sub>1_def by blast
 qed
 
 subsubsection \<open>Lower Bounds for the Bin Packing Problem\<close>
 
 lemma bp_bins_finite [simp]:
   assumes "bp P"
   shows "\<forall>B \<in> P. finite B"
   using bpE(3)[OF assms] U_Finite by (meson Sup_upper finite_subset)
 
 lemma bp_sol_finite [simp]:
   assumes "bp P"
   shows "finite P"
   using bpE(3)[OF assms] U_Finite by (simp add: finite_UnionD)
 
 text \<open>If \<open>P\<close> is a solution of the bin packing problem, then no bin in \<open>P\<close> may contain more than
       one large object.\<close>
 lemma only_one_L_per_bin:
   assumes "bp P" "B \<in> P"
   shows "\<forall>x \<in> B. \<forall>y \<in> B. x \<noteq> y \<longrightarrow> x \<notin> L \<or> y \<notin> L"
 proof (rule ccontr, simp)
   assume "\<exists>x\<in>B. \<exists>y\<in>B. x \<noteq> y \<and> x \<in> L \<and> y \<in> L"
   then obtain x y where *: "x \<in> B" "y \<in> B" "x \<noteq> y" "x \<in> L" "y \<in> L" by blast
   then have "c < w x + w y" using L_def S_def by force
   have "finite B" using assms by simp
   have "y \<in> B - {x}" using *(2,3) by blast
   have "W B = W (B - {x}) + w x"
     using *(1) \<open>finite B\<close> by (simp add: sum.remove)
   also have "... = W (B - {x} - {y}) + w x + w y"
     using \<open>y \<in> B - {x}\<close> \<open>finite B\<close> by (simp add: sum.remove)
   finally have *: "W B = W (B - {x} - {y}) + w x + w y" .
   have "\<forall>u \<in> B. 0 < w u" using bpE(3)[OF assms(1)] assms(2) weight by blast
-  then have "0 \<le> W (B - {x} - {y})" by (smt DiffD1 sum_nonneg)
+  then have "0 \<le> W (B - {x} - {y})" by (smt (verit) DiffD1 sum_nonneg)
   with * have "c < W B" using \<open>c < w x + w y\<close> by simp
   then show False using bpE(4)[OF assms(1)] assms(2) by fastforce
 qed
 
 text \<open>If \<open>P\<close> is a solution of the bin packing problem, then the amount of large objects
       is a lower bound for the amount of bins in P.\<close>
 lemma L_lower_bound_card:
   assumes "bp P"
   shows "card L \<le> card P"
 proof -
   have "\<forall>x \<in> L. \<exists>B \<in> P. x \<in> B"
     using bpE(3)[OF assms] L_def by blast
   then obtain f where f_def: "\<forall>u \<in> L. u \<in> f u \<and> f u \<in> P" by metis
   then have "inj_on f L"
     unfolding inj_on_def using only_one_L_per_bin[OF assms] by blast
   then have card_eq: "card L = card (f ` L)" by (simp add: card_image)
   have "f ` L \<subseteq> P" using f_def by blast
   moreover have "finite P" using assms by simp
   ultimately have "card (f ` L) \<le> card P" by (simp add: card_mono)
   then show ?thesis unfolding card_eq .
 qed
 
 text \<open>If \<open>P\<close> is a solution of the bin packing problem, then the amount of bins of a subset of P
       in which every bin contains a large object is a lower bound on the amount of large objects.\<close>
 lemma subset_bp_card:
   assumes "bp P" "M \<subseteq> P" "\<forall>B \<in> M. B \<inter> L \<noteq> {}"
   shows "card M \<le> card L"
 proof -
   have "\<forall>B \<in> M. \<exists>u \<in> L. u \<in> B" using assms(3) by fast
   then have "\<exists>f. \<forall>B \<in> M. f B \<in> L \<and> f B \<in> B" by metis
   then obtain f where f_def: "\<forall>B \<in> M. f B \<in> L \<and> f B \<in> B" ..
   have "inj_on f M"
   proof (rule ccontr)
     assume "\<not> inj_on f M"
     then have "\<exists>x \<in> M. \<exists>y \<in> M. x \<noteq> y \<and> f x = f y" unfolding inj_on_def by blast
     then obtain x y where *: "x \<in> M" "y \<in> M" "x \<noteq> y" "f x = f y" by blast
     then have "\<exists>u. u \<in> x \<and> u \<in> y" using f_def by metis
     then have "x \<inter> y \<noteq> {}" by blast
     moreover have "pairwise disjnt M" using pairwise_subset[OF bpE(1)[OF assms(1)] assms(2)] .
     ultimately show False using * unfolding pairwise_def disjnt_def by simp
   qed
   moreover have "finite L" using L_def U_Finite by blast
   moreover have "f ` M \<subseteq> L" using f_def by blast
   ultimately show ?thesis using card_inj_on_le by blast
 qed
 
 text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, \<open>inv\<^sub>1\<close> holds for the partial solution,
       and every bin in \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close> contains a large object, then the amount of bins in
       \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L}\<close> is a lower bound for the amount of bins in \<open>P\<close>.\<close>
 lemma L_bins_lower_bound_card:
   assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}"
   shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L}) \<le> card P"
 proof -
   note invrules = inv\<^sub>1E[OF assms(2)]
   have "\<forall>B \<in> {{v} |v. v \<in> V \<inter> L}. B \<inter> L \<noteq> {}" by blast
   with assms(3) have
     "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L} \<subseteq> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}"
     "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L}. B \<inter> L \<noteq> {}" by blast+
   from subset_bp_card[OF invrules(1) this] show ?thesis
     using L_lower_bound_card[OF assms(1)] by linarith
 qed
 
 text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, then the sum of the weights of the
       objects is equal to the sum of the weights of the bins in \<open>P\<close>.\<close>
 lemma sum_Un_eq_sum_sum:
   assumes "bp P"
   shows "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
 proof -
   have FINITE: "\<forall>B \<in> P. finite B" using assms by simp
   have DISJNT: "\<forall>A \<in> P. \<forall>B \<in> P. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
     using bpE(1)[OF assms] unfolding pairwise_def disjnt_def .
   have "(\<Sum>u \<in> (\<Union>P). w u) = (\<Sum>B \<in> P. W B)"
     using sum.Union_disjoint[OF FINITE DISJNT] by auto
   then show ?thesis unfolding bpE(3)[OF assms] .
 qed
 
 text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, then the sum of the weights of the items
       is a lower bound of amount of bins in \<open>P\<close> multiplied by their maximum capacity.\<close>
 lemma sum_lower_bound_card:
   assumes "bp P"
   shows "(\<Sum>u \<in> U. w u) \<le> c * card P"
 proof -
   have *: "\<forall>B \<in> P. 0 < W B \<and> W B \<le> c"
     using bpE(2-4)[OF assms] weight by (metis UnionI assms bp_bins_finite sum_pos)
   have "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
     using sum_Un_eq_sum_sum[OF assms] .
   also have "... \<le> (\<Sum>B \<in> P. c)" using sum_mono * by fastforce
   also have "... = c * card P" by simp
   finally show ?thesis .
 qed
 
 lemma bp_NE:
   assumes "bp P"
   shows "P \<noteq> {}"
   using U_NE bpE(3)[OF assms] by blast
 
 lemma sum_Un_ge:
   fixes f :: "_ \<Rightarrow> real"
   assumes "finite M" "finite N" "\<forall>B \<in> M \<union> N. 0 < f B"
   shows "sum f M \<le> sum f (M \<union> N)"
 proof -
   have "0 \<le> sum f N - sum f (M \<inter> N)"
-    using assms by (smt DiffD1 inf.cobounded2 UnCI sum_mono2)
+    using assms by (smt (verit) DiffD1 inf.cobounded2 UnCI sum_mono2)
   then have "sum f M \<le> sum f M + sum f N - sum f (M \<inter> N)"
     by simp
   also have "... = sum f (M \<union> N)"
     using sum_Un[OF assms(1,2), symmetric] .
   finally show ?thesis .
 qed
 
 text \<open>If \<open>bij_exists\<close> holds, one can obtain a function which is bijective between the bins in \<open>P\<close>
 and the objects in \<open>V\<close> such that an object returned by the function would cause the bin to
 exceed its capacity.\<close>
 definition bij_exists :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "bij_exists P V = (\<exists>f. bij_betw f P V \<and> (\<forall>B \<in> P. W B + w (f B) > c))"
 
 text \<open>If \<open>P\<close> is a functionally correct solution of the bin packing problem, \<open>inv\<^sub>1\<close> holds for the
 partial solution, and such a bijective function exists between the bins in \<open>P\<^sub>1\<close> and the objects in
 @{term "P\<^sub>2 \<union> wrap B\<^sub>2"}, the following strict lower bound can be shown:\<close>
 lemma P\<^sub>1_lower_bound_card:
   assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
   shows "card P\<^sub>1 + 1 \<le> card P"
 proof (cases \<open>P\<^sub>1 = {}\<close>)
   case True
   have "finite P" using assms(1) by simp
   then have "1 \<le> card P" using bp_NE[OF assms(1)]
     by (metis Nat.add_0_right Suc_diff_1 Suc_le_mono card_gt_0_iff le0 mult_Suc_right nat_mult_1)
   then show ?thesis unfolding True by simp
 next
   note invrules = inv\<^sub>1E[OF assms(2)]
   case False
   obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B \<in> P\<^sub>1. W B + w (f B) > c"
     using assms(3) unfolding bij_exists_def by blast
   have FINITE: "finite P\<^sub>1" "finite (P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (wrap B\<^sub>1 \<union> {{v} |v. v \<in> V})"
     using inv\<^sub>1E(1)[OF assms(2)] bp_sol_finite by blast+
 
   have F: "\<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. finite B" using invrules(1) by simp
   have D: "\<forall>A \<in> P\<^sub>2 \<union> wrap B\<^sub>2. \<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
     using bpE(1)[OF invrules(1)] unfolding pairwise_def disjnt_def by auto
   have sum_eq: "W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) = (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)"
     using sum.Union_disjoint[OF F D] by auto
 
   have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}. 0 < W B"
     using bpE(2,3)[OF invrules(1)] weight by (metis (no_types, lifting) UnionI bp_bins_finite invrules(1) sum_pos)
   then have "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> (wrap B\<^sub>1 \<union> {{v} |v. v \<in> V}). W B)"
     using sum_Un_ge[OF FINITE(3,4), of W] by blast
-  also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}. W B)" by (smt Un_assoc Un_commute) 
+  also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}. W B)" by (smt (verit) Un_assoc Un_commute) 
   also have "... = W U" using sum_Un_eq_sum_sum[OF invrules(1), symmetric] .
   finally have *: "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> W U" .
 
   \<comment> \<open>This follows from the fourth and final additional conjunct of \<open>inv\<^sub>1\<close> and is necessary to combine the sums of the bins
       of the two partial solutions. This does not inherently follow from the union being a correct solution,
       as this need not be the case if \<open>P\<^sub>1\<close> and \<open>P\<^sub>2 \<union> wrap B\<^sub>2\<close> happened to be equal.\<close>
   have DISJNT: "P\<^sub>1 \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}" using invrules(5) by blast
 
   \<comment> \<open>This part of the proof is based on the proof on page 72 of the article \<^cite>\<open>BerghammerR03\<close>.\<close>
   have "c * card P\<^sub>1 = (\<Sum>B \<in> P\<^sub>1. c)" by simp
   also have "... < (\<Sum>B \<in> P\<^sub>1. W B + w (f B))"
     using f_def(2) sum_strict_mono[OF FINITE(1) False] by fastforce
   also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>1. w (f B))"
     by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib)
   also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" unfolding sum.reindex_bij_betw[OF f_def(1), of w] ..
   also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" unfolding sum_eq ..
   also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" using sum.union_disjoint[OF FINITE(1,2) DISJNT, of W] by (simp add: Un_assoc)
   also have "... \<le> (\<Sum>u \<in> U. w u)" using * .
   also have "... \<le> c * card P" using sum_lower_bound_card[OF assms(1)] .
   finally show ?thesis
     by (simp flip: of_nat_mult)
 qed
 
 text \<open>As @{thm wrap_card} holds, it follows that the amount of bins in \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close>
       are a lower bound for the amount of bins in \<open>P\<close>.\<close>
 lemma P\<^sub>1_B\<^sub>1_lower_bound_card:
   assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
   shows "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P"
 proof -
   have "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P\<^sub>1 + card (wrap B\<^sub>1)"
     using card_Un_le by blast
   also have "... \<le> card P\<^sub>1 + 1" using wrap_card by simp
   also have "... \<le> card P" using P\<^sub>1_lower_bound_card[OF assms] .
   finally show ?thesis .
 qed
 
 text \<open>If \<open>inv\<^sub>1\<close> holds, there are at most half as many bins in \<open>P\<^sub>2\<close> as there are objects in \<open>P\<^sub>2\<close>, and we can again
       obtain a bijective function between the bins in \<open>P\<^sub>1\<close> and the objects of the second partial solution,
       then the amount of bins in the second partial solution are a strict lower bound for half the bins of
       the first partial solution.\<close>
 lemma P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
   shows "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card P\<^sub>1 + 1"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
 
   have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using bprules(1) pairwise_subset by blast
   moreover have "B\<^sub>2 \<notin> P\<^sub>2" using invrules(4) by simp
   ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
     by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
 
   have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
   have "finite B\<^sub>2" using bp_bins_finite[OF invrules(1)] wrap_not_empty by blast
   have "finite P\<^sub>2" "finite (wrap B\<^sub>2)" using bp_sol_finite[OF invrules(1)] by blast+
   have DISJNT2: "P\<^sub>2 \<inter> wrap B\<^sub>2 = {}" unfolding wrap_def using \<open>B\<^sub>2 \<notin> P\<^sub>2\<close> by auto
   have "card (wrap B\<^sub>2) \<le> card B\<^sub>2"
   proof (cases \<open>B\<^sub>2 = {}\<close>)
     case False
     then have "1 \<le> card B\<^sub>2" by (simp add: leI \<open>finite B\<^sub>2\<close>)
     then show ?thesis using wrap_card[of B\<^sub>2] by linarith
   qed simp
 
   \<comment> \<open>This part of the proof is based on the proof on page 73 of the article \<^cite>\<open>BerghammerR03\<close>.\<close>
   from assms(2) have "2 * card P\<^sub>2 + 2 * card (wrap B\<^sub>2) \<le> card (\<Union>P\<^sub>2) + card (wrap B\<^sub>2) + 1"
     using wrap_card[of B\<^sub>2] by linarith
   then have "2 * (card P\<^sub>2 + card (wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2) + card B\<^sub>2 + 1"
     using \<open>card (wrap B\<^sub>2) \<le> card B\<^sub>2\<close> by simp
   then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2 \<union> B\<^sub>2) + 1"
     using card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close> DISJNT]
       and card_Un_disjoint[OF \<open>finite P\<^sub>2\<close> \<open>finite (wrap B\<^sub>2)\<close> DISJNT2] by argo
   then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) + 1"
     by (cases \<open>B\<^sub>2 = {}\<close>) (auto simp: Un_commute)
   then show "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card P\<^sub>1 + 1"
     using assms(3) bij_betw_same_card unfolding bij_exists_def by metis
 qed
 
 subsubsection \<open>Proving the Approximation Factor\<close>
 
 text \<open>We define \<open>inv\<^sub>2\<close> as it is defined in the article.
       These conjuncts allow us to prove the desired approximation factor.\<close>
 definition inv\<^sub>2 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<comment> \<open>\<open>inv\<^sub>1\<close> holds for the partial solution\<close>
                        \<and> (V \<inter> L \<noteq> {} \<longrightarrow> (\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {})) \<comment> \<open>If there are still large objects left, then every bin of the first partial solution must contain a large object\<close>
                        \<and> bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) \<comment> \<open>There exists a bijective function between the bins of the first partial solution and the objects of the second one\<close>
                        \<and> (2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)) \<comment> \<open>There are at most twice as many bins in \<open>P\<^sub>2\<close> as there are objects in \<open>P\<^sub>2\<close>\<close>"
 
 lemma inv\<^sub>2E:
   assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
     and "V \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}"
     and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
     and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
   using assms unfolding inv\<^sub>2_def by blast+
 
 lemma inv\<^sub>2I:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
     and "V \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}"
     and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
     and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
   shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   using assms unfolding inv\<^sub>2_def by blast
 
 text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, \<open>inv\<^sub>2\<close> holds for the partial solution,
       and there are no more small objects left to be distributed, then the amount of bins of the partial solution
       is no larger than \<open>3 / 2\<close> of the amount of bins in \<open>P\<close>. This proof strongly follows the proof in
       \<open>Theorem 4.1\<close> of the article \<^cite>\<open>BerghammerR03\<close>.\<close>
 lemma bin_packing_lower_bound_card:
   assumes "V \<inter> S = {}" "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bp P"
   shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}) \<le> 3 / 2 * card P"
 proof (cases \<open>V = {}\<close>)
   note invrules = inv\<^sub>2E[OF assms(2)]
   case True
   then have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V})
            = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" by simp
   also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close>] by (simp add: Un_assoc)
   also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using P\<^sub>1_B\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by simp
   also have "... \<le> card P + card P / 2"
     using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
       and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
   finally show ?thesis by linarith
 next
   note invrules = inv\<^sub>2E[OF assms(2)]
   case False
   have "U = S \<union> L" using S_def L_def by blast
   then have *: "V = V \<inter> L"
     using bpE(3)[OF inv\<^sub>1E(1)[OF invrules(1)]]
       and assms(1) by blast
   with False have NE: "V \<inter> L \<noteq> {}" by simp
   have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V})
       = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L} \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
     using * by (simp add: Un_commute Un_assoc)
   also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L}) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> V \<inter> L}\<close>] by (simp add: Un_assoc)
   also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using L_bins_lower_bound_card[OF assms(3) invrules(1) invrules(2)[OF NE]] by linarith
   also have "... \<le> card P + card P / 2"
     using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
       and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
   finally show ?thesis by linarith
 qed
 
 text \<open>We define \<open>inv\<^sub>3\<close> as it is defined in the article.
       This final conjunct allows us to prove that the invariant will be maintained by the algorithm.\<close>
 definition inv\<^sub>3 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<and> B\<^sub>2 \<subseteq> S"
 
 lemma inv\<^sub>3E:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "B\<^sub>2 \<subseteq> S"
   using assms unfolding inv\<^sub>3_def by blast+
 
 lemma inv\<^sub>3I:
   assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "B\<^sub>2 \<subseteq> S"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   using assms unfolding inv\<^sub>3_def by blast
 
 lemma loop_init:
   "inv\<^sub>3 {} {} {} {} U"
 proof -
   have *: "inv\<^sub>1 {} {} {} {} U"
     unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def
     using weight by auto
   have "bij_exists {} (\<Union> ({} \<union> wrap {}))"
     using bij_betwI' unfolding bij_exists_def by fastforce
   from inv\<^sub>2I[OF * _ this] have "inv\<^sub>2 {} {} {} {} U" by auto
   from inv\<^sub>3I[OF this] show ?thesis by blast
 qed
 
 text \<open>If \<open>B\<^sub>1\<close> is empty and there are no large objects left, then \<open>inv\<^sub>3\<close> will be maintained
       if \<open>B\<^sub>1\<close> is initialized with \<open>u \<in> V \<inter> S\<close>.\<close>
 lemma loop_stepA:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 = {}" "V \<inter> L = {}" "u \<in> V \<inter> S"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   have WEIGHT: "W B\<^sub>1 + w u \<le> c" using S_def assms(2,4) by simp
   from assms(4) have "u \<in> V" by blast
   from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by simp
   have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L \<noteq> {}" using assms(3) by blast
   from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by blast
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
 qed
 
 text \<open>If \<open>B\<^sub>1\<close> is empty and there are large objects left, then \<open>inv\<^sub>3\<close> will be maintained
       if \<open>B\<^sub>1\<close> is initialized with \<open>u \<in> V \<inter> L\<close>.\<close>
 lemma loop_stepB:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 = {}" "u \<in> V \<inter> L"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   have WEIGHT: "W B\<^sub>1 + w u \<le> c" using L_def weight assms(2,3) by simp
   from assms(3) have "u \<in> V" by blast
   from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by simp
   have "\<forall>B\<in>P\<^sub>1. B \<inter> L \<noteq> {}" using assms(3) invrules(2) by blast
   then have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L \<noteq> {}"
     using assms(3) by (metis Int_iff UnE empty_iff insertE singletonI wrap_not_empty)
   from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by blast
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
 qed
 
 text \<open>If \<open>B\<^sub>1\<close> is not empty and \<open>u \<in> V \<inter> S\<close> does not exceed its maximum capacity, then \<open>inv\<^sub>3\<close>
       will be maintained if \<open>B\<^sub>1\<close> and \<open>{u}\<close> are replaced with \<open>B\<^sub>1 \<union> {u}\<close>.\<close>
 lemma loop_stepC:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \<noteq> {}" "u \<in> V \<inter> S" "W B\<^sub>1 + w(u) \<le> c"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   from assms(3) have "u \<in> V" by blast
   from inv\<^sub>1_stepA[OF invrules(1) this assms(4)] have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})" .
   have "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}" using invrules(2) by blast
   then have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}). B \<inter> L \<noteq> {}"
     by (metis Int_commute Un_empty_right Un_insert_right assms(2) disjoint_insert(2) insert_iff wrap_not_empty)
   from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})" by blast
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
 qed
 
 text \<open>If \<open>B\<^sub>1\<close> is not empty and \<open>u \<in> V \<inter> S\<close> does exceed its maximum capacity but not the capacity of \<open>B\<^sub>2\<close>,
       then \<open>inv\<^sub>3\<close> will be maintained if \<open>B\<^sub>1\<close> is added to \<open>P\<^sub>1\<close> and emptied, and \<open>B\<^sub>2\<close> and \<open>{u}\<close> are replaced with \<open>B\<^sub>2 \<union> {u}\<close>.\<close>
 lemma loop_stepD:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \<noteq> {}" "u \<in> V \<inter> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) \<le> c"
   shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   from assms(3) have "u \<in> V" by blast
   from inv\<^sub>1_stepB[OF invrules(1) this assms(5)] have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})" .
 
   have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L \<noteq> {}"
     using invrules(2) unfolding wrap_empty by blast
 
   from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
   have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
   have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
   then have "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))"
     by (metis Sup_empty Un_assoc Union_Un_distrib ccpo_Sup_singleton wrap_empty wrap_not_empty)
   also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
   finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
   have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
   let ?f = "f (B\<^sub>1 := u)"
   have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
     unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
     by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
   have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
   then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
     unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
   with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))
               \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
   then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
     unfolding bij_exists_def by blast
   from inv\<^sub>2I[OF 1 2 3] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})" using invrules(4) by blast
 
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] assms(3) by blast
 qed
 
 text \<open>If the maximum capacity of \<open>B\<^sub>2\<close> is exceeded by \<open>u \<in> V \<inter> S\<close>,
       then \<open>B\<^sub>2\<close> must contain at least two objects.\<close>
 lemma B\<^sub>2_at_least_two_objects:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V \<inter> S" "W B\<^sub>2 + w(u) > c"
   shows "2 \<le> card B\<^sub>2"
 proof (rule ccontr, simp add: not_le)
   have FINITE: "finite B\<^sub>2" using inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF assms(1)]]]
     by (metis (no_types, lifting) Finite_Set.finite.simps U_Finite Union_Un_distrib bpE(3) ccpo_Sup_singleton finite_Un wrap_not_empty)
   assume "card B\<^sub>2 < 2"
   then consider (0) "card B\<^sub>2 = 0" | (1) "card B\<^sub>2 = 1" by linarith
   then show False proof cases
     case 0 then have "B\<^sub>2 = {}" using FINITE by simp
     then show ?thesis using assms(2,3) S_def by simp
   next
     case 1 then obtain v where "B\<^sub>2 = {v}"
       using card_1_singletonE by auto
     with inv\<^sub>3E(2)[OF assms(1)] have "2 * w v \<le> c" using S_def by simp
     moreover from \<open>B\<^sub>2 = {v}\<close> have "W B\<^sub>2 = w v" by simp
     ultimately show ?thesis using assms(2,3) S_def by simp
   qed
 qed
 
 text \<open>If \<open>B\<^sub>1\<close> is not empty and \<open>u \<in> V \<inter> S\<close> exceeds the maximum capacity of both \<open>B\<^sub>1\<close> and \<open>B\<^sub>2\<close>,
       then \<open>inv\<^sub>3\<close> will be maintained if \<open>B\<^sub>1\<close> and \<open>B\<^sub>2\<close> are added to \<open>P\<^sub>1\<close> and \<open>P\<^sub>2\<close> respectively,
       emptied, and \<open>B\<^sub>2\<close> initialized with \<open>u\<close>.\<close>
 lemma loop_stepE:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \<noteq> {}" "u \<in> V \<inter> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) > c"
   shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   from assms(3) have "u \<in> V" by blast
   from inv\<^sub>1_stepC[OF invrules(1) this] have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})" .
 
   have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L \<noteq> {}"
     using invrules(2) unfolding wrap_empty by blast
 
   from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
   have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
   have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
   have "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))" unfolding wrap_def by simp
   also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
   finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
   have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
   let ?f = "f (B\<^sub>1 := u)"
   have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
     unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
     by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
   have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
   then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
     unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
   with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))
               \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
   then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
     unfolding bij_exists_def by blast
 
   have 4: "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))"
   proof -
     note bprules = bpE[OF inv\<^sub>1E(1)[OF invrules(1)]]
     have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
       using bprules(1) pairwise_subset by blast
     moreover have "B\<^sub>2 \<notin> P\<^sub>2" using inv\<^sub>1E(4)[OF invrules(1)]  by simp
     ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
       by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
     have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
     have "finite B\<^sub>2" using inv\<^sub>1E(1)[OF invrules(1)] bp_bins_finite wrap_not_empty by blast
 
     have "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> 2 * (card P\<^sub>2 + card (wrap B\<^sub>2))"
       using card_Un_le[of P\<^sub>2 \<open>wrap B\<^sub>2\<close>] by simp
     also have "... \<le> 2 * card P\<^sub>2 + 2" using wrap_card by auto
     also have "... \<le> card (\<Union> P\<^sub>2) + 2" using invrules(4) by simp
     also have "... \<le> card (\<Union> P\<^sub>2) + card B\<^sub>2" using B\<^sub>2_at_least_two_objects[OF assms(1,3,5)] by simp
     also have "... = card (\<Union> (P\<^sub>2 \<union> {B\<^sub>2}))" using DISJNT card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close>] by (simp add: Un_commute)
     also have "... = card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" by (cases \<open>B\<^sub>2 = {}\<close>) auto
     finally show ?thesis .
   qed
   from inv\<^sub>2I[OF 1 2 3 4] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})" .
 
   from inv\<^sub>3I[OF this] show ?thesis using assms(3) by blast
 qed
 
 text \<open>The bin packing algorithm as it is proposed in the article \<^cite>\<open>BerghammerR03\<close>.
       \<open>P\<close> will not only be a correct solution of the bin packing problem, but the amount of bins
       will be a lower bound for \<open>3 / 2\<close> of the amount of bins of any correct solution \<open>Q\<close>, and thus
       guarantee an approximation factor of \<open>3 / 2\<close> for the optimum.\<close>
 lemma bp_approx:
 "VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u
   {True}
   P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; V := U;
   WHILE V \<inter> S \<noteq> {} INV {inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V} DO 
     IF B\<^sub>1 \<noteq> {}
     THEN u := (SOME u. u \<in> V \<inter> S)
     ELSE IF V \<inter> L \<noteq> {}
          THEN u := (SOME u. u \<in> V \<inter> L)
          ELSE u := (SOME u. u \<in> V \<inter> S) FI FI;
     V := V - {u};
     IF W(B\<^sub>1) + w(u) \<le> c
     THEN B\<^sub>1 := B\<^sub>1 \<union> {u}
     ELSE IF W(B\<^sub>2) + w(u) \<le> c
          THEN B\<^sub>2 := B\<^sub>2 \<union> {u}
          ELSE P\<^sub>2 := P\<^sub>2 \<union> wrap B\<^sub>2; B\<^sub>2 := {u} FI;
          P\<^sub>1 := P\<^sub>1 \<union> wrap B\<^sub>1; B\<^sub>1 := {} FI
   OD;
   P := P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} | v. v \<in> V}
   {bp P \<and> (\<forall>Q. bp Q \<longrightarrow> card P \<le> 3 / 2 * card Q)}"
 proof (vcg, goal_cases)
 case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
   then show ?case by (simp add: loop_init)
 next
   case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
   then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" ..
   let ?s = "SOME u. u \<in> V \<inter> S"
   let ?l = "SOME u. u \<in> V \<inter> L"
   have LIN: "V \<inter> L \<noteq> {} \<Longrightarrow> ?l \<in> V \<inter> L" using some_in_eq by metis
   then have LWEIGHT: "V \<inter> L \<noteq> {} \<Longrightarrow> w ?l \<le> c" using L_def weight by blast
   from 2 have "V \<inter> S \<noteq> {}" ..
   then have IN: "?s \<in> V \<inter> S" using some_in_eq by metis
   then have "w ?s \<le> c" using S_def by simp
 
   then show ?case
     using LWEIGHT loop_stepA[OF INV _ _ IN] loop_stepB[OF INV _ LIN] loop_stepC[OF INV _ IN]
       and loop_stepD[OF INV _ IN] loop_stepE[OF INV _ IN] by (cases \<open>B\<^sub>1 = {}\<close>, cases \<open>V \<inter> L = {}\<close>) auto
 next
   case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
   then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and EMPTY: "V \<inter> S = {}" by blast+
   from inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF INV]]] and bin_packing_lower_bound_card[OF EMPTY inv\<^sub>3E(1)[OF INV]]
     show ?case by blast
 qed
 
 end (* BinPacking *)
 
 subsection \<open>The Full Linear Time Version of the Proposed Algorithm\<close>
 
 text \<open>Finally, we prove the Algorithm proposed on page 78 of the article \<^cite>\<open>BerghammerR03\<close>.
       This version generates the S and L sets beforehand and uses them directly to calculate the solution,
       thus removing the need for intersection operations, and ensuring linear time if we can
       perform \<open>insertion, removal, and selection of an element, the union of two sets,
       and the emptiness test in constant time\<close> \<^cite>\<open>BerghammerR03\<close>.\<close>
 
 locale BinPacking_Complete =
   fixes U :: "'a set" \<comment> \<open>A finite, non-empty set of objects\<close>
     and w :: "'a \<Rightarrow> real" \<comment> \<open>A mapping from objects to their respective weights (positive real numbers)\<close>
     and c :: nat \<comment> \<open>The maximum capacity of a bin (as a natural number)\<close>
   assumes weight: "\<forall>u \<in> U. 0 < w(u) \<and> w(u) \<le> c"
       and U_Finite: "finite U"
       and U_NE: "U \<noteq> {}"
 begin
 
 text \<open>The correctness proofs will be identical to the ones of the simplified algorithm.\<close>
 
 abbreviation W :: "'a set \<Rightarrow> real" where
   "W B \<equiv> (\<Sum>u \<in> B. w(u))"
 
 definition bp :: "'a set set \<Rightarrow> bool" where
   "bp P \<longleftrightarrow> partition_on U P \<and> (\<forall>B \<in> P. W(B) \<le> c)"
 
 lemma bpE:
   assumes "bp P"
   shows "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
   using assms unfolding bp_def partition_on_def by blast+
 
 lemma bpI:
   assumes "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
   shows "bp P"
   using assms unfolding bp_def partition_on_def by blast
 
 definition inv\<^sub>1 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}) \<comment> \<open>A correct solution to the bin packing problem\<close>
                        \<and> \<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V \<comment> \<open>The partial solution does not contain objects that have not yet been assigned\<close>
                        \<and> B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<comment> \<open>\<open>B\<^sub>1\<close> is distinct from all the other bins\<close>
                        \<and> B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2) \<comment> \<open>\<open>B\<^sub>2\<close> is distinct from all the other bins\<close>
                        \<and> (P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {} \<comment> \<open>The first and second partial solutions are disjoint from each other.\<close>"
 
 lemma inv\<^sub>1E:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   shows "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V})"
     and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
     and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
     and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
     and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
   using assms unfolding inv\<^sub>1_def by auto
 
 lemma inv\<^sub>1I:
   assumes "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V})"
     and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
     and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
     and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
     and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
   shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
   using assms unfolding inv\<^sub>1_def by blast
 
 lemma wrap_Un [simp]: "wrap (M \<union> {x}) = {M \<union> {x}}" unfolding wrap_def by simp
 lemma wrap_empty [simp]: "wrap {} = {}" unfolding wrap_def by simp
 lemma wrap_not_empty [simp]: "M \<noteq> {} \<longleftrightarrow> wrap M = {M}" unfolding wrap_def by simp
 
 lemma inv\<^sub>1_stepA:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W(B\<^sub>1) + w(u) \<le> c"
   shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
 
   \<comment> \<open>Rule 1: Pairwise Disjoint\<close>
   have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. u \<notin> M"
     using invrules(2) assms(2) by blast
   have "{{v} |v. v \<in> V} = {{u}} \<union> {{v} |v. v \<in> V - {u}}"
     using assms(2) by blast
   then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> ({{u}} \<union> {{v} |v. v \<in> V - {u}}))"
     using bprules(1) assms(2) by simp
   then have "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}})" by (simp add: Un_commute)
   then have assm: "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))" by (simp add: Un_assoc)
   have "pairwise disjnt ({B\<^sub>1 \<union> {u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))"
   proof (cases \<open>B\<^sub>1 = {}\<close>)
     case True with assm show ?thesis by simp
   next
     case False
     with assm have assm: "pairwise disjnt ({B\<^sub>1} \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))" by simp
     from NOTIN have "{u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}" by blast
     from pairwise_disjnt_Un[OF assm _ this] invrules(2,3) show ?thesis
       using False by auto
   qed
   then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}})"
     unfolding wrap_Un by simp
 
   \<comment> \<open>Rule 2: No empty sets\<close>
   from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}"
     unfolding wrap_def by simp
 
   \<comment> \<open>Rule 3: Union preserved\<close>
   from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}}) = U"
     using assms(2) by blast
   then have 3: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}) = U"
     unfolding wrap_def by force
 
   \<comment> \<open>Rule 4: Weights below capacity\<close>
   have "0 < w u" using weight assms(2) bprules(3) by blast
   have "finite B\<^sub>1" using bprules(3) U_Finite by (cases \<open>B\<^sub>1 = {}\<close>) auto
   then have "W (B\<^sub>1 \<union> {u}) \<le> W B\<^sub>1 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>1\<close>) (auto simp: insert_absorb)
   also have "... \<le> c" using assms(3) .
   finally have "W (B\<^sub>1 \<union> {u}) \<le> c" .
   then have "\<forall>B \<in> wrap (B\<^sub>1 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
   moreover have "\<forall>B\<in>P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c"
     using bprules(4) by blast
   ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c" by blast
   from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}})" .
 
   \<comment> \<open>Auxiliary information is preserved\<close>
   have "u \<in> U" using assms(2) bprules(3) by blast
   then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
   have L: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
     unfolding wrap_def using NOTIN by auto
   have 2: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - (V - {u})"
     unfolding L R invrules(2) ..
   have 3: "B\<^sub>1 \<union> {u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2"
     using NOTIN by auto
   have 4: "B\<^sub>2 \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2"
     using invrules(4) NOTIN unfolding wrap_def by fastforce
   have 5: "(P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u})) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
     using invrules(5) NOTIN unfolding wrap_Un by auto
 
   from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
 qed
 
 lemma inv\<^sub>1_stepB:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W B\<^sub>2 + w u \<le> c"
   shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
 
   have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. u \<notin> M"
     using invrules(2) assms(2) by blast
   have "{{v} |v. v \<in> V} = {{u}} \<union> {{v} |v. v \<in> V - {u}}"
     using assms(2) by blast
   then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}})"
     using bprules(1) assms(2) by simp
   then have assm: "pairwise disjnt (wrap B\<^sub>2 \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))"
     by (simp add: Un_assoc Un_commute)
   have "pairwise disjnt ({B\<^sub>2 \<union> {u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))"
   proof (cases \<open>B\<^sub>2 = {}\<close>)
     case True with assm show ?thesis by simp
   next
     case False
     with assm have assm: "pairwise disjnt ({B\<^sub>2} \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}))" by simp
     from NOTIN have "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}" by blast
     from pairwise_disjnt_Un[OF assm _ this] invrules(2,4) show ?thesis
       using False by auto
   qed
   then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}})"
     unfolding wrap_Un by simp
 
   \<comment> \<open>Rule 2: No empty sets\<close>
   from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}}"
     unfolding wrap_def by simp
 
   \<comment> \<open>Rule 3: Union preserved\<close>
   from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}}) = U"
     using assms(2) by blast
   then have 3: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}}) = U"
     unfolding wrap_def by force
 
   \<comment> \<open>Rule 4: Weights below capacity\<close>
   have "0 < w u" using weight assms(2) bprules(3) by blast
   have "finite B\<^sub>2" using bprules(3) U_Finite by (cases \<open>B\<^sub>2 = {}\<close>) auto
   then have "W (B\<^sub>2 \<union> {u}) \<le> W B\<^sub>2 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>2\<close>) (auto simp: insert_absorb)
   also have "... \<le> c" using assms(3) .
   finally have "W (B\<^sub>2 \<union> {u}) \<le> c" .
   then have "\<forall>B \<in> wrap (B\<^sub>2 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
   moreover have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c"
     using bprules(4) by blast
   ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}}. W B \<le> c"
     by auto
   from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} |v. v \<in> V - {u}})" .
 
   \<comment> \<open>Auxiliary information is preserved\<close>
   have "u \<in> U" using assms(2) bprules(3) by blast
   then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
   have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
     unfolding wrap_def using NOTIN by auto
   have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = U - (V - {u})"
     unfolding L R using invrules(2) by simp
   have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})"
     using bpE(2)[OF 1] by simp
   have 4: "B\<^sub>2 \<union> {u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2"
     using NOTIN by auto
   have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = {}"
     using invrules(5) NOTIN unfolding wrap_empty wrap_Un by auto
 
   from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
 qed
 
 lemma inv\<^sub>1_stepC:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V"
   shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)]
   \<comment> \<open>Rule 1-4: Correct Bin Packing\<close>
   have "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} |v. v \<in> V - {u}}
       = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} |v. v \<in> V - {u}}"
     by (metis (no_types, lifting) Un_assoc Un_empty_right insert_not_empty wrap_empty wrap_not_empty)
   also have "... = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}"
     using assms(2) by auto
   finally have EQ: "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} |v. v \<in> V - {u}}
                   = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V}" .
   from invrules(1) have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} |v. v \<in> V - {u}})"
     unfolding EQ .
 
   \<comment> \<open>Auxiliary information is preserved\<close>
   have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> V - {u}}. u \<notin> M"
     using invrules(2) assms(2) by blast
   have "u \<in> U" using assms(2) bpE(3)[OF invrules(1)] by blast
   then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
   have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}"
     unfolding wrap_def using NOTIN by auto
   have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = U - (V - {u})"
     unfolding L R using invrules(2) by auto
   have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}"
     using bpE(2)[OF 1] by simp
   have 4: "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using NOTIN by auto
   have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}) = {}"
     using invrules(5) NOTIN unfolding wrap_def by force
 
   from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
 qed
 
 text \<open>From this point onward, we will require a different approach for proving lower bounds.
       Instead of fixing and assuming the definitions of the \<open>S\<close> and \<open>L\<close> sets, we will introduce
       the abbreviations \<open>S\<^sub>U\<close> and \<open>L\<^sub>U\<close> for any occurrences of the original \<open>S\<close> and \<open>L\<close> sets.
       The union of \<open>S\<close> and \<open>L\<close> can be interpreted as \<open>V\<close>. As a result, occurrences of \<open>V \<inter> S\<close>
       become \<open>(S \<union> L) \<inter> S = S\<close>, and \<open>V \<inter> L\<close> become \<open>(S \<union> L) \<inter> L = L\<close>.
       Occurrences of these sets will have to be replaced appropriately.\<close>
 abbreviation S\<^sub>U where
   "S\<^sub>U \<equiv> {u \<in> U. w u \<le> c / 2}"
 
 abbreviation L\<^sub>U where
   "L\<^sub>U \<equiv> {u \<in> U. c / 2 < w u}"
 
 text \<open>As we will remove elements from \<open>S\<close> and \<open>L\<close>, we will only be able to show that they remain
       subsets of \<open>S\<^sub>U\<close> and \<open>L\<^sub>U\<close> respectively.\<close>
 abbreviation SL where
   "SL S L \<equiv> S \<subseteq> S\<^sub>U \<and> L \<subseteq> L\<^sub>U"
 
 lemma bp_bins_finite [simp]:
   assumes "bp P"
   shows "\<forall>B \<in> P. finite B"
   using bpE(3)[OF assms] U_Finite by (meson Sup_upper finite_subset)
 
 lemma bp_sol_finite [simp]:
   assumes "bp P"
   shows "finite P"
   using bpE(3)[OF assms] U_Finite by (simp add: finite_UnionD)
 
 lemma only_one_L_per_bin:
   assumes "bp P" "B \<in> P"
   shows "\<forall>x \<in> B. \<forall>y \<in> B. x \<noteq> y \<longrightarrow> x \<notin> L\<^sub>U \<or> y \<notin> L\<^sub>U"
 proof (rule ccontr, simp)
   assume "\<exists>x\<in>B. \<exists>y\<in>B. x \<noteq> y \<and> y \<in> U \<and> x \<in> U \<and> real c < w x * 2 \<and> real c < w y * 2"
   then obtain x y where *: "x \<in> B" "y \<in> B" "x \<noteq> y" "x \<in> L\<^sub>U" "y \<in> L\<^sub>U" by auto
   then have "c < w x + w y" by force
   have "finite B" using assms by simp
   have "y \<in> B - {x}" using *(2,3) by blast
   have "W B = W (B - {x}) + w x"
     using *(1) \<open>finite B\<close> by (simp add: sum.remove)
   also have "... = W (B - {x} - {y}) + w x + w y"
     using \<open>y \<in> B - {x}\<close> \<open>finite B\<close> by (simp add: sum.remove)
   finally have *: "W B = W (B - {x} - {y}) + w x + w y" .
   have "\<forall>u \<in> B. 0 < w u" using bpE(3)[OF assms(1)] assms(2) weight by blast
-  then have "0 \<le> W (B - {x} - {y})" by (smt DiffD1 sum_nonneg)
+  then have "0 \<le> W (B - {x} - {y})" by (smt (verit) DiffD1 sum_nonneg)
   with * have "c < W B" using \<open>c < w x + w y\<close> by simp
   then show False using bpE(4)[OF assms(1)] assms(2) by fastforce
 qed
 
 lemma L_lower_bound_card:
   assumes "bp P"
   shows "card L\<^sub>U \<le> card P"
 proof -
   have "\<forall>x \<in> L\<^sub>U. \<exists>B \<in> P. x \<in> B"
     using bpE(3)[OF assms] by blast
   then obtain f where f_def: "\<forall>u \<in> L\<^sub>U. u \<in> f u \<and> f u \<in> P" by metis
   then have "inj_on f L\<^sub>U"
     unfolding inj_on_def using only_one_L_per_bin[OF assms] by blast
   then have card_eq: "card L\<^sub>U = card (f ` L\<^sub>U)" by (simp add: card_image)
   have "f ` L\<^sub>U \<subseteq> P" using f_def by blast
   moreover have "finite P" using assms by simp
   ultimately have "card (f ` L\<^sub>U) \<le> card P" by (simp add: card_mono)
   then show ?thesis unfolding card_eq .
 qed
 
 lemma subset_bp_card:
   assumes "bp P" "M \<subseteq> P" "\<forall>B \<in> M. B \<inter> L\<^sub>U \<noteq> {}"
   shows "card M \<le> card L\<^sub>U"
 proof -
   have "\<forall>B \<in> M. \<exists>u \<in> L\<^sub>U. u \<in> B" using assms(3) by fast
   then have "\<exists>f. \<forall>B \<in> M. f B \<in> L\<^sub>U \<and> f B \<in> B" by metis
   then obtain f where f_def: "\<forall>B \<in> M. f B \<in> L\<^sub>U \<and> f B \<in> B" ..
   have "inj_on f M"
   proof (rule ccontr)
     assume "\<not> inj_on f M"
     then have "\<exists>x \<in> M. \<exists>y \<in> M. x \<noteq> y \<and> f x = f y" unfolding inj_on_def by blast
     then obtain x y where *: "x \<in> M" "y \<in> M" "x \<noteq> y" "f x = f y" by blast
     then have "\<exists>u. u \<in> x \<and> u \<in> y" using f_def by metis
     then have "x \<inter> y \<noteq> {}" by blast
     moreover have "pairwise disjnt M" using pairwise_subset[OF bpE(1)[OF assms(1)] assms(2)] .
     ultimately show False using * unfolding pairwise_def disjnt_def by simp
   qed
   moreover have "finite L\<^sub>U" using U_Finite by auto
   moreover have "f ` M \<subseteq> L\<^sub>U" using f_def by blast
   ultimately show ?thesis using card_inj_on_le by blast
 qed
 
 lemma L_bins_lower_bound_card:
   assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}"
       and SL_def: "SL S L"
   shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> L}) \<le> card P"
 proof -
   note invrules = inv\<^sub>1E[OF assms(2)]
   have "\<forall>B \<in> {{v} |v. v \<in> L}. B \<inter> L\<^sub>U \<noteq> {}" using SL_def by blast
   with assms(3) have
     "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> L} \<subseteq> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L}"
     "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> L}. B \<inter> L\<^sub>U \<noteq> {}" by blast+
   from subset_bp_card[OF invrules(1) this] show ?thesis
     using L_lower_bound_card[OF assms(1)] by linarith
 qed
 
 lemma sum_Un_eq_sum_sum:
   assumes "bp P"
   shows "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
 proof -
   have FINITE: "\<forall>B \<in> P. finite B" using assms by simp
   have DISJNT: "\<forall>A \<in> P. \<forall>B \<in> P. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
     using bpE(1)[OF assms] unfolding pairwise_def disjnt_def .
   have "(\<Sum>u \<in> (\<Union>P). w u) = (\<Sum>B \<in> P. W B)"
     using sum.Union_disjoint[OF FINITE DISJNT] by auto
   then show ?thesis unfolding bpE(3)[OF assms] .
 qed
 
 lemma sum_lower_bound_card:
   assumes "bp P"
   shows "(\<Sum>u \<in> U. w u) \<le> c * card P"
 proof -
   have *: "\<forall>B \<in> P. 0 < W B \<and> W B \<le> c"
     using bpE(2-4)[OF assms] weight by (metis UnionI assms bp_bins_finite sum_pos)
   have "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
     using sum_Un_eq_sum_sum[OF assms] .
   also have "... \<le> (\<Sum>B \<in> P. c)" using sum_mono * by fastforce
   also have "... = c * card P" by simp
   finally show ?thesis .
 qed
 
 lemma bp_NE:
   assumes "bp P"
   shows "P \<noteq> {}"
   using U_NE bpE(3)[OF assms] by blast
 
 lemma sum_Un_ge:
   fixes f :: "_ \<Rightarrow> real"
   assumes "finite M" "finite N" "\<forall>B \<in> M \<union> N. 0 < f B"
   shows "sum f M \<le> sum f (M \<union> N)"
 proof -
   have "0 \<le> sum f N - sum f (M \<inter> N)"
-    using assms by (smt DiffD1 inf.cobounded2 UnCI sum_mono2)
+    using assms by (smt (verit) DiffD1 inf.cobounded2 UnCI sum_mono2)
   then have "sum f M \<le> sum f M + sum f N - sum f (M \<inter> N)"
     by simp
   also have "... = sum f (M \<union> N)"
     using sum_Un[OF assms(1,2), symmetric] .
   finally show ?thesis .
 qed
 
 definition bij_exists :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "bij_exists P V = (\<exists>f. bij_betw f P V \<and> (\<forall>B \<in> P. W B + w (f B) > c))"
 
 lemma P\<^sub>1_lower_bound_card:
   assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
   shows "card P\<^sub>1 + 1 \<le> card P"
 proof (cases \<open>P\<^sub>1 = {}\<close>)
   case True
   have "finite P" using assms(1) by simp
   then have "1 \<le> card P" using bp_NE[OF assms(1)]
     by (metis Nat.add_0_right Suc_diff_1 Suc_le_mono card_gt_0_iff le0 mult_Suc_right nat_mult_1)
   then show ?thesis unfolding True by simp
 next
   note invrules = inv\<^sub>1E[OF assms(2)]
   case False
   obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B \<in> P\<^sub>1. W B + w (f B) > c"
     using assms(3) unfolding bij_exists_def by blast
   have FINITE: "finite P\<^sub>1" "finite (P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (wrap B\<^sub>1 \<union> {{v} |v. v \<in> S \<union> L})"
     using inv\<^sub>1E(1)[OF assms(2)] bp_sol_finite by blast+
 
   have F: "\<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. finite B" using invrules(1) by simp
   have D: "\<forall>A \<in> P\<^sub>2 \<union> wrap B\<^sub>2. \<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
     using bpE(1)[OF invrules(1)] unfolding pairwise_def disjnt_def by auto
   have sum_eq: "W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) = (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)"
     using sum.Union_disjoint[OF F D] by auto
 
   have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L}. 0 < W B"
     using bpE(2,3)[OF invrules(1)] weight by (metis (no_types, lifting) UnionI bp_bins_finite invrules(1) sum_pos)
   then have "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> (wrap B\<^sub>1 \<union> {{v} |v. v \<in> S \<union> L}). W B)"
     using sum_Un_ge[OF FINITE(3,4), of W] by blast
-  also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L}. W B)" by (smt Un_assoc Un_commute) 
+  also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L}. W B)" by (smt (verit) Un_assoc Un_commute) 
   also have "... = W U" using sum_Un_eq_sum_sum[OF invrules(1), symmetric] .
   finally have *: "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> W U" .
   have DISJNT: "P\<^sub>1 \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}" using invrules(5) by blast
 
   \<comment> \<open>This part of the proof is based on the proof on page 72 of the article \<^cite>\<open>BerghammerR03\<close>.\<close>
   have "c * card P\<^sub>1 = (\<Sum>B \<in> P\<^sub>1. c)" by simp
   also have "... < (\<Sum>B \<in> P\<^sub>1. W B + w (f B))"
     using f_def(2) sum_strict_mono[OF FINITE(1) False] by fastforce
   also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>1. w (f B))"
     by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib)
   also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" unfolding sum.reindex_bij_betw[OF f_def(1), of w] ..
   also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" unfolding sum_eq ..
   also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" using sum.union_disjoint[OF FINITE(1,2) DISJNT, of W] by (simp add: Un_assoc)
   also have "... \<le> (\<Sum>u \<in> U. w u)" using * .
   also have "... \<le> c * card P" using sum_lower_bound_card[OF assms(1)] .
   finally show ?thesis
     by (simp flip: of_nat_mult)
 qed
 
 lemma P\<^sub>1_B\<^sub>1_lower_bound_card:
   assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
   shows "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P"
 proof -
   have "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P\<^sub>1 + card (wrap B\<^sub>1)"
     using card_Un_le by blast
   also have "... \<le> card P\<^sub>1 + 1" using wrap_card by simp
   also have "... \<le> card P" using P\<^sub>1_lower_bound_card[OF assms] .
   finally show ?thesis .
 qed
 
 lemma P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
   shows "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card P\<^sub>1 + 1"
 proof -
   note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
 
   have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using bprules(1) pairwise_subset by blast
   moreover have "B\<^sub>2 \<notin> P\<^sub>2" using invrules(4) by simp
   ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
     by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
 
   have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
   have "finite B\<^sub>2" using bp_bins_finite[OF invrules(1)] wrap_not_empty by blast
   have "finite P\<^sub>2" "finite (wrap B\<^sub>2)" using bp_sol_finite[OF invrules(1)] by blast+
   have DISJNT2: "P\<^sub>2 \<inter> wrap B\<^sub>2 = {}" unfolding wrap_def using \<open>B\<^sub>2 \<notin> P\<^sub>2\<close> by auto
   have "card (wrap B\<^sub>2) \<le> card B\<^sub>2"
   proof (cases \<open>B\<^sub>2 = {}\<close>)
     case False
     then have "1 \<le> card B\<^sub>2" by (simp add: leI \<open>finite B\<^sub>2\<close>)
     then show ?thesis using wrap_card[of B\<^sub>2] by linarith
   qed simp
 
   \<comment> \<open>This part of the proof is based on the proof on page 73 of the article \<^cite>\<open>BerghammerR03\<close>.\<close>
   from assms(2) have "2 * card P\<^sub>2 + 2 * card (wrap B\<^sub>2) \<le> card (\<Union>P\<^sub>2) + card (wrap B\<^sub>2) + 1"
     using wrap_card[of B\<^sub>2] by linarith
   then have "2 * (card P\<^sub>2 + card (wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2) + card B\<^sub>2 + 1"
     using \<open>card (wrap B\<^sub>2) \<le> card B\<^sub>2\<close> by simp
   then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2 \<union> B\<^sub>2) + 1"
     using card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close> DISJNT]
       and card_Un_disjoint[OF \<open>finite P\<^sub>2\<close> \<open>finite (wrap B\<^sub>2)\<close> DISJNT2] by argo
   then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) + 1"
     by (cases \<open>B\<^sub>2 = {}\<close>) (auto simp: Un_commute)
   then show "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card P\<^sub>1 + 1"
     using assms(3) bij_betw_same_card unfolding bij_exists_def by metis
 qed
 
 text \<open>We add \<open>SL S L\<close> to \<open>inv\<^sub>2\<close> to ensure that the \<open>S\<close> and \<open>L\<close> sets only contain objects with correct weights.\<close>
 definition inv\<^sub>2 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<longleftrightarrow> inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L) \<comment> \<open>\<open>inv\<^sub>1\<close> holds for the partial solution\<close>
                        \<and> (L \<noteq> {} \<longrightarrow> (\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {})) \<comment> \<open>If there are still large objects left, then every bin of the first partial solution must contain a large object\<close>
                        \<and> bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) \<comment> \<open>There exists a bijective function between the bins of the first partial solution and the objects of the second one\<close>
                        \<and> (2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)) \<comment> \<open>There are at most twice as many bins in \<open>P\<^sub>2\<close> as there are objects in \<open>P\<^sub>2\<close>\<close>
                        \<and> SL S L \<comment> \<open>\<open>S\<close> and \<open>L\<close> are subsets of \<open>S\<^sub>U\<close> and \<open>L\<^sub>U\<close>\<close>"
 
 lemma inv\<^sub>2E:
   assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
   shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)"
     and "L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}"
     and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
     and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
     and "SL S L"
   using assms unfolding inv\<^sub>2_def by blast+
 
 lemma inv\<^sub>2I:
   assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)"
     and "L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}"
     and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
     and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
     and "SL S L"
   shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
   using assms unfolding inv\<^sub>2_def by blast
 
 lemma bin_packing_lower_bound_card:
   assumes "S = {}" "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "bp P"
   shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L}) \<le> 3 / 2 * card P"
 proof (cases \<open>L = {}\<close>)
   note invrules = inv\<^sub>2E[OF assms(2)]
   case True
   then have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L})
            = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" using assms(1) by simp
   also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close>] by (simp add: Un_assoc)
   also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using P\<^sub>1_B\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by simp
   also have "... \<le> card P + card P / 2"
     using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
       and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
   finally show ?thesis by linarith
 next
   note invrules = inv\<^sub>2E[OF assms(2)]
   case False
   have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> S \<union> L})
       = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> L} \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
     using assms(1) by (simp add: Un_commute Un_assoc)
   also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> L}) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} |v. v \<in> L}\<close>] by (simp add: Un_assoc)
   also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
     using L_bins_lower_bound_card[OF assms(3) invrules(1) invrules(2)[OF False] invrules(5)] by linarith
   also have "... \<le> card P + card P / 2"
     using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
       and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
   finally show ?thesis by linarith
 qed
 
 definition inv\<^sub>3 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<longleftrightarrow> inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<and> B\<^sub>2 \<subseteq> S\<^sub>U"
 
 lemma inv\<^sub>3E:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
   shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" and "B\<^sub>2 \<subseteq> S\<^sub>U"
   using assms unfolding inv\<^sub>3_def by blast+
 
 lemma inv\<^sub>3I:
   assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" and "B\<^sub>2 \<subseteq> S\<^sub>U"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
   using assms unfolding inv\<^sub>3_def by blast
 
 lemma loop_init:
   "inv\<^sub>3 {} {} {} {} S\<^sub>U L\<^sub>U"
 proof -
   have "S\<^sub>U \<union> L\<^sub>U = U" by auto
   then have *: "inv\<^sub>1 {} {} {} {} (S\<^sub>U \<union> L\<^sub>U)"
     unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def
     using weight by auto
   have "bij_exists {} (\<Union> ({} \<union> wrap {}))"
     using bij_betwI' unfolding bij_exists_def by fastforce
   from inv\<^sub>2I[OF * _ this] have "inv\<^sub>2 {} {} {} {} S\<^sub>U L\<^sub>U" by auto
   from inv\<^sub>3I[OF this] show ?thesis by blast
 qed
 
 lemma loop_stepA:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 = {}" "L = {}" "u \<in> S"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u}) L"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   have WEIGHT: "W B\<^sub>1 + w u \<le> c" using invrules(5) assms(2,4) by fastforce
   from assms(4) have "u \<in> S \<union> L" by blast
   from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2,3) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u} \<union> L)" by simp
   have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L\<^sub>U \<noteq> {}" using assms(3) by blast
   from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u}) L" by blast
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
 qed
 
 lemma loop_stepB:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 = {}" "u \<in> L"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 S (L - {u})"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   have WEIGHT: "W B\<^sub>1 + w u \<le> c" using weight invrules(5) assms(2,3) by fastforce
 
   \<comment> \<open>This observation follows from the fact that the \<open>S\<close> and \<open>L\<close> sets have to be disjoint from each other,
       and allows us to reuse our proofs of the preservation of \<open>inv\<^sub>1\<close> by simply replacing \<open>V\<close> with \<open>S \<union> L\<close>\<close>
   have *: "S \<union> L - {u} = S \<union> (L - {u})" using invrules(5) assms(3) by force
   from assms(3) have "u \<in> S \<union> L" by blast
   from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) * have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S \<union> (L - {u}))" by simp
   have "\<forall>B\<in>P\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}" "{u} \<inter> L\<^sub>U \<noteq> {}" using assms(3) invrules(2,5) by blast+
   then have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L\<^sub>U \<noteq> {}"
     using assms(3) by (metis (full_types) Un_iff empty_iff insert_iff wrap_not_empty)
   from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 S (L - {u})" by blast
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
 qed
 
 lemma loop_stepC:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \<noteq> {}" "u \<in> S" "W B\<^sub>1 + w(u) \<le> c"
   shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (S - {u}) L"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
 
   \<comment> \<open>Same approach, but removing \<open>{u}\<close> from \<open>S\<close> instead of \<open>L\<close>\<close>
   have *: "S \<union> L - {u} = (S - {u}) \<union> L" using invrules(5) assms(3) by force
   from assms(3) have "u \<in> S \<union> L" by blast
   from inv\<^sub>1_stepA[OF invrules(1) this assms(4)] * have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (S - {u} \<union> L)" by simp
   have "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}" using invrules(2) by blast
   then have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}). B \<inter> L\<^sub>U \<noteq> {}"
-    by (smt Int_insert_left Un_empty_right Un_iff Un_insert_right assms(2) insert_not_empty singletonD singletonI wrap_def)
+    by (smt (verit) Int_insert_left Un_empty_right Un_iff Un_insert_right assms(2) insert_not_empty singletonD singletonI wrap_def)
   from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (S - {u}) L" by blast
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
 qed
 
 lemma loop_stepD:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \<noteq> {}" "u \<in> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) \<le> c"
   shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (S - {u}) L"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   have *: "S \<union> L - {u} = (S - {u}) \<union> L" using invrules(5) assms(3) by force
   from assms(3) have "u \<in> S \<union> L" by blast
   from inv\<^sub>1_stepB[OF invrules(1) this assms(5)] * have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (S - {u} \<union> L)" by simp
 
   have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L\<^sub>U \<noteq> {}"
     using invrules(2) unfolding wrap_empty by blast
 
   from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
   have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
   have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
   then have "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))"
     by (metis Sup_empty Un_assoc Union_Un_distrib ccpo_Sup_singleton wrap_empty wrap_not_empty)
   also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
   finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
   have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
   let ?f = "f (B\<^sub>1 := u)"
   have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
     unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
     by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
   have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
   then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
     unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
   with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))
               \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
   then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
     unfolding bij_exists_def by blast
   from inv\<^sub>2I[OF 1 2 3] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (S - {u}) L" using invrules(4,5) by blast
 
   from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] assms(3) invrules(5) by blast
 qed
 
 lemma B\<^sub>2_at_least_two_objects:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "u \<in> S" "W B\<^sub>2 + w(u) > c"
   shows "2 \<le> card B\<^sub>2"
 proof (rule ccontr, simp add: not_le)
   have FINITE: "finite B\<^sub>2" using inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF assms(1)]]]
     by (metis (no_types, lifting) Finite_Set.finite.simps U_Finite Union_Un_distrib bpE(3) ccpo_Sup_singleton finite_Un wrap_not_empty)
   assume "card B\<^sub>2 < 2"
   then consider (0) "card B\<^sub>2 = 0" | (1) "card B\<^sub>2 = 1" by linarith
   then show False proof cases
     case 0 then have "B\<^sub>2 = {}" using FINITE by simp
     then show ?thesis using assms(2,3) inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by force
   next
     case 1 then obtain v where "B\<^sub>2 = {v}"
       using card_1_singletonE by auto
     with inv\<^sub>3E(2)[OF assms(1)] have "2 * w v \<le> c" using inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by simp
     moreover from \<open>B\<^sub>2 = {v}\<close> have "W B\<^sub>2 = w v" by simp
     ultimately show ?thesis using assms(2,3) inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by force
   qed
 qed
 
 lemma loop_stepE:
   assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \<noteq> {}" "u \<in> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) > c"
   shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (S - {u}) L"
 proof -
   note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
   have *: "S \<union> L - {u} = (S - {u}) \<union> L" using invrules(5) assms(3) by force
   from assms(3) have "u \<in> S \<union> L" by blast
   from inv\<^sub>1_stepC[OF invrules(1) this] * have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (S - {u} \<union> L)" by simp
 
   have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L\<^sub>U \<noteq> {}"
     using invrules(2) unfolding wrap_empty by blast
 
   from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
   have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
   have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
   have "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))" unfolding wrap_def by simp
   also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
   finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
   have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
   let ?f = "f (B\<^sub>1 := u)"
   have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
     unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
     by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
   have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
   then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
     unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
   with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))
               \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
   then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
     unfolding bij_exists_def by blast
 
   have 4: "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))"
   proof -
     note bprules = bpE[OF inv\<^sub>1E(1)[OF invrules(1)]]
     have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
       using bprules(1) pairwise_subset by blast
     moreover have "B\<^sub>2 \<notin> P\<^sub>2" using inv\<^sub>1E(4)[OF invrules(1)]  by simp
     ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
       by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
     have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
     have "finite B\<^sub>2" using inv\<^sub>1E(1)[OF invrules(1)] bp_bins_finite wrap_not_empty by blast
 
     have "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> 2 * (card P\<^sub>2 + card (wrap B\<^sub>2))"
       using card_Un_le[of P\<^sub>2 \<open>wrap B\<^sub>2\<close>] by simp
     also have "... \<le> 2 * card P\<^sub>2 + 2" using wrap_card by auto
     also have "... \<le> card (\<Union> P\<^sub>2) + 2" using invrules(4) by simp
     also have "... \<le> card (\<Union> P\<^sub>2) + card B\<^sub>2" using B\<^sub>2_at_least_two_objects[OF assms(1,3,5)] by simp
     also have "... = card (\<Union> (P\<^sub>2 \<union> {B\<^sub>2}))" using DISJNT card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close>] by (simp add: Un_commute)
     also have "... = card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" by (cases \<open>B\<^sub>2 = {}\<close>) auto
     finally show ?thesis .
   qed
   from inv\<^sub>2I[OF 1 2 3 4] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (S - {u}) L"
     using invrules(5) by blast
 
   from inv\<^sub>3I[OF this] show ?thesis using assms(3) invrules(5) by blast
 qed
 
 text \<open>The bin packing algorithm as it is proposed on page 78 of the article \<^cite>\<open>BerghammerR03\<close>.
       \<open>P\<close> will not only be a correct solution of the bin packing problem, but the amount of bins
       will be a lower bound for \<open>3 / 2\<close> of the amount of bins of any correct solution \<open>Q\<close>, and thus
       guarantee an approximation factor of \<open>3 / 2\<close> for the optimum.\<close>
 lemma bp_approx:
 "VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u
   {True}
   S := {}; L:= {}; V := U;
   WHILE V \<noteq> {} INV {V \<subseteq> U \<and> S = {u \<in> U - V. w(u) \<le> c / 2} \<and> L = {u \<in> U - V. c / 2 < w(u)}} DO
     u := (SOME u. u \<in> V);
     IF w(u) \<le> c / 2
     THEN S := S \<union> {u}
     ELSE L := L \<union> {u} FI;
     V := V - {u}
   OD;
   P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {};
   WHILE S \<noteq> {} INV {inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L} DO 
     IF B\<^sub>1 \<noteq> {}
     THEN u := (SOME u. u \<in> S); S := S - {u}
     ELSE IF L \<noteq> {}
          THEN u := (SOME u. u \<in> L); L := L - {u}
          ELSE u := (SOME u. u \<in> S); S := S - {u} FI FI;
     IF W(B\<^sub>1) + w(u) \<le> c
     THEN B\<^sub>1 := B\<^sub>1 \<union> {u}
     ELSE IF W(B\<^sub>2) + w(u) \<le> c
          THEN B\<^sub>2 := B\<^sub>2 \<union> {u}
          ELSE P\<^sub>2 := P\<^sub>2 \<union> wrap B\<^sub>2; B\<^sub>2 := {u} FI;
          P\<^sub>1 := P\<^sub>1 \<union> wrap B\<^sub>1; B\<^sub>1 := {} FI
   OD;
   P := P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2; V := L;
   WHILE V \<noteq> {}
   INV {S = {} \<and> inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<and> V \<subseteq> L \<and> P = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v}|v. v \<in> L - V}} DO
     u := (SOME u. u \<in> V); P := P \<union> {{u}}; V := V - {u}
   OD
   {bp P \<and> (\<forall>Q. bp Q \<longrightarrow> card P \<le> 3 / 2 * card Q)}"
 proof (vcg, goal_cases)
   case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then show ?case by blast
 next
   case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then show ?case by (auto simp: some_in_eq)
 next
   case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then show ?case using loop_init by force
 next
   case (4 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" ..
   let ?s = "SOME u. u \<in> S"
   let ?l = "SOME u. u \<in> L"
   note SL_def = inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF INV]]
   have LIN: "L \<noteq> {} \<Longrightarrow> ?l \<in> L" using some_in_eq by metis
   then have LWEIGHT: "L \<noteq> {} \<Longrightarrow> w ?l \<le> c" using weight SL_def by blast
   from 4 have "S \<noteq> {}" ..
   then have IN: "?s \<in> S" using some_in_eq by metis
   then have "w ?s \<le> c" using SL_def by auto
   then show ?case
     using LWEIGHT loop_stepA[OF INV _ _ IN] loop_stepB[OF INV _ LIN] loop_stepC[OF INV _ IN]
       and loop_stepD[OF INV _ IN] loop_stepE[OF INV _ IN] by (cases \<open>B\<^sub>1 = {}\<close>, cases \<open>L = {}\<close>) auto
 next
   case (5 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then show ?case by blast
 next
   case (6 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then have *: "(SOME u. u \<in> V) \<in> V" "(SOME u. u \<in> V) \<in> L" by (auto simp add: some_in_eq)
   then have "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> L - (V - {SOME u. u \<in> V})}
            = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} |v. v \<in> L - V \<union> {SOME u. u \<in> V}}"
     by blast
   with 6 * show ?case by blast
 next
   case (7 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
   then have *: "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
     using inv\<^sub>3E(1) by blast
   from inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF *]] 7
   have "bp P" by fastforce
   with bin_packing_lower_bound_card[OF _ *] 7
   show ?case by fastforce
 qed
 
 end (* BinPacking_Complete *)
 
 end (* Theory *)
\ No newline at end of file
diff --git a/thys/Approximation_Algorithms/Center_Selection.thy b/thys/Approximation_Algorithms/Center_Selection.thy
--- a/thys/Approximation_Algorithms/Center_Selection.thy
+++ b/thys/Approximation_Algorithms/Center_Selection.thy
@@ -1,457 +1,457 @@
 (* Author: Ujkan Sulejmani *)
 
 section \<open>Center Selection\<close>
 
 theory Center_Selection
   imports Complex_Main "HOL-Hoare.Hoare_Logic"
 begin
 
 text \<open>The Center Selection (or metric k-center) problem. Given a set of \textit{sites} \<open>S\<close>
 in a metric space, find a subset \<open>C \<subseteq> S\<close> that minimizes the maximal distance from any \<open>s \<in> S\<close>
 to some \<open>c \<in> C\<close>. This theory presents a verified 2-approximation algorithm.
 It is based on Section 11.2 in the book by Kleinberg and Tardos \<^cite>\<open>"KleinbergT06"\<close>.
 In contrast to the proof in the book, our proof is a standard invariant proof.\<close>
 
 locale Center_Selection =
   fixes S :: "('a :: metric_space) set"
     and k :: nat
   assumes finite_sites: "finite S"
   and     non_empty_sites: "S \<noteq> {}"
 and       non_zero_k: "k > 0"
 begin
 
 definition distance :: "('a::metric_space) set \<Rightarrow> ('a::metric_space) \<Rightarrow> real" where
 "distance C s = Min (dist s ` C)"
 
 definition radius :: "('a :: metric_space) set \<Rightarrow> real" where
 "radius C = Max (distance C ` S)"
 
 lemma distance_mono:
 assumes "C\<^sub>1 \<subseteq> C\<^sub>2" and "C\<^sub>1 \<noteq> {}" and "finite C\<^sub>2"
 shows "distance C\<^sub>1 s \<ge> distance C\<^sub>2 s"
 by (simp add: Min.subset_imp assms distance_def image_mono)
 
 lemma finite_distances: "finite (distance C ` S)"
   using finite_sites by simp
 
 lemma non_empty_distances: "distance C ` S \<noteq> {}"
   using non_empty_sites by simp
 
 lemma radius_contained: "radius C \<in> distance C ` S"
   using finite_distances non_empty_distances Max_in radius_def by simp
 
 lemma radius_def2: "\<exists>s \<in> S. distance C s = radius C"
   using radius_contained image_iff by metis
 
 lemma dist_lemmas_aux:
   assumes  "finite C"
       and  "C \<noteq> {}"
   shows  "finite (dist s ` C)"
     and "finite (dist s ` C) \<Longrightarrow> distance C s \<in> dist s ` C"
     and "distance C s \<in> dist s ` C \<Longrightarrow> \<exists>c \<in> C. dist s c = distance C s"
 and "\<exists>c \<in> C. dist s c = distance C s \<Longrightarrow> distance C s \<ge> 0"
 proof
   show "finite C" using assms(1) by simp
 next
   assume "finite (dist s ` C)"
   then show "distance C s \<in> dist s ` C" using distance_def eq_Min_iff assms(2) by blast
 next
   assume "distance C s \<in> dist s ` C" 
   then show "\<exists>c \<in> C. dist s c = distance C s" by auto
 next
   assume "\<exists>c \<in> C. dist s c = distance C s"
   then show "distance C s \<ge> 0" by (metis zero_le_dist)
 qed
 
 lemma dist_lemmas:
   assumes "finite C"
       and "C \<noteq> {}"
   shows "finite (dist s ` C)"
     and "distance C s \<in> dist s ` C"
     and "\<exists>c \<in> C. dist s c = distance C s"
     and "distance C s \<ge> 0"
   using dist_lemmas_aux assms by auto
 
 lemma radius_max_prop: "(\<forall>s \<in> S. distance C s \<le> r) \<Longrightarrow> (radius C \<le> r)"
   by (metis image_iff radius_contained)
 
 lemma dist_ins:
 assumes "\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> x < dist c\<^sub>1 c\<^sub>2"
 and "distance C s > x"
 and "finite C"
 and "C \<noteq> {}"
 shows "\<forall>c\<^sub>1 \<in> (C \<union> {s}). \<forall>c\<^sub>2 \<in> (C \<union> {s}). c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> x < dist c\<^sub>1 c\<^sub>2"
 proof (rule+)
   fix c\<^sub>1 c\<^sub>2
   assume local_assms: "c\<^sub>1\<in>C \<union> {s}" "c\<^sub>2\<in>C \<union> {s}" "c\<^sub>1 \<noteq> c\<^sub>2"
   then have "c\<^sub>1 \<in> C  \<and> c\<^sub>2 \<in> C  \<or> c\<^sub>1 \<in>C  \<and> c\<^sub>2\<in> {s} \<or> c\<^sub>2\<in>C  \<and> c\<^sub>1 \<in> {s} \<or> c\<^sub>1 \<in> {s} \<and> c\<^sub>2\<in> {s}" by auto
   then show "x < dist c\<^sub>1 c\<^sub>2"
   proof (elim disjE)
     assume "c\<^sub>1 \<in>C  \<and> c\<^sub>2\<in>C"
     then show ?thesis using assms(1) local_assms(3) by simp
   next
     assume case_assm: "c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> {s}"
     have "x < distance C c\<^sub>2" using assms(2) case_assm by simp
     also have " ... \<le> dist c\<^sub>2 c\<^sub>1"
       using Min.coboundedI distance_def assms(3,4) dist_lemmas(1, 2) case_assm by simp
     also have " ... = dist c\<^sub>1 c\<^sub>2" using dist_commute by metis
     finally show ?thesis .
   next
     assume case_assm: "c\<^sub>2 \<in> C \<and> c\<^sub>1 \<in> {s}"
     have "x < distance C c\<^sub>1" using assms(2) case_assm by simp
     also have " ... \<le> dist c\<^sub>1 c\<^sub>2"
       using Min.coboundedI distance_def assms(3,4) dist_lemmas(1, 2) case_assm by simp
     finally show ?thesis .
   next
     assume "c\<^sub>1 \<in> {s} \<and> c\<^sub>2 \<in> {s}" 
     then have False using local_assms by simp
     then show ?thesis by simp
   qed
 qed
 
 subsection \<open>A Preliminary Algorithm and Proof\<close>
 
 text \<open>This subsection verifies an auxiliary algorithm by Kleinberg and Tardos.
 Our proof of the main algorithm does not does not rely on this auxiliary algorithm at all
 but we do reuse part off its invariant proof later on.\<close>
 
 definition inv :: "('a :: metric_space) set \<Rightarrow> ('a :: metric_space set) \<Rightarrow> real \<Rightarrow> bool" where
 "inv S' C r =
   ((\<forall>s \<in> (S - S'). distance C s \<le> 2*r) \<and> S' \<subseteq> S \<and> C \<subseteq> S \<and>
    (\<forall>c \<in> C. \<forall>s \<in> S'. S' \<noteq> {} \<longrightarrow> dist c s > 2 * r) \<and> (S' = S \<or> C \<noteq> {}) \<and>
    (\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2 * r))" 
 
 lemma inv_init: "inv S {} r"
   unfolding inv_def non_empty_sites by simp
 lemma inv_step:
   assumes "S' \<noteq> {}"
 and IH: "inv S' C r"
 defines[simp]: "s \<equiv> (SOME s. s \<in> S')"
 shows "inv (S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}) (C \<union> {s}) r"
 proof -
   have s_def: "s \<in> S'" using assms(1) some_in_eq by auto
 
   have "finite (C \<union> {s})" using IH finite_subset[OF _ finite_sites] by (simp add: inv_def)
 
   moreover
 
   have "(\<forall>s' \<in> (S - (S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r})). distance (C \<union> {s}) s' \<le> 2*r)"
   proof 
     fix s''
     assume "s'' \<in> S - (S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r})"
     then have "s'' \<in> S - S' \<or> s'' \<in> {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}" by simp
     then show "distance (C \<union> {s}) s'' \<le> 2 * r"
     proof (elim disjE)
       assume local_assm: "s'' \<in> S - S'"
       have "S' = S \<or> C \<noteq> {}" using IH by (simp add: inv_def)
       then show ?thesis
       proof (elim disjE)
         assume "S' = S"
         then have "s'' \<in> {}" using local_assm by simp
         then show ?thesis by simp
       next
         assume C_not_empty: "C \<noteq> {}"
         have "finite C" using IH finite_subset[OF _ finite_sites] by (simp add: inv_def)
         then have "distance (C \<union> {s}) s'' \<le> distance C s''"
           using distance_mono C_not_empty by (meson Un_upper1 calculation)
         also have " ...  \<le> 2 * r" using IH local_assm inv_def by simp
         finally show ?thesis .
       qed
     next
       assume local_assm: "s'' \<in> {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}"
       then have "distance (C \<union> {s}) s'' \<le> dist s'' s"
         using Min.coboundedI distance_def dist_lemmas calculation by auto
-      also have " ... \<le> 2 * r" using local_assm by (smt dist_self dist_triangle2 mem_Collect_eq)
+      also have " ... \<le> 2 * r" using local_assm by (smt (verit) dist_self dist_triangle2 mem_Collect_eq)
       finally show ?thesis .
     qed
   qed
 
   moreover
 
   have "S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r} \<subseteq> S" using IH by (auto simp: inv_def)
 
   moreover
   {
     have "s \<in> S" using IH inv_def s_def by auto
     then have "C \<union> {s} \<subseteq> S" using IH by (simp add: inv_def)
   }
   moreover
 
   have "(\<forall>c\<in>C \<union> {s}. \<forall>c\<^sub>2\<in>C \<union> {s}. c \<noteq> c\<^sub>2 \<longrightarrow> 2 * r < dist c c\<^sub>2)"
   proof (rule+)
     fix c\<^sub>1 c\<^sub>2
     assume local_assms: "c\<^sub>1 \<in> C \<union> {s}" "c\<^sub>2 \<in> C \<union> {s}" "c\<^sub>1 \<noteq> c\<^sub>2"
     then have "(c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C) \<or> (c\<^sub>1 = s \<and> c\<^sub>2 \<in> C) \<or> (c\<^sub>1 \<in> C \<and> c\<^sub>2 = s) \<or> (c\<^sub>1 = s \<and> c\<^sub>2 = s)"
       using assms by auto
     then show "2 * r < dist c\<^sub>1 c\<^sub>2"
     proof (elim disjE)
       assume "c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C"
       then show "2 * r < dist c\<^sub>1 c\<^sub>2" using IH inv_def local_assms by simp
     next
       assume case_assm: "c\<^sub>1 = s \<and> c\<^sub>2 \<in> C"
       have "(\<forall>c \<in> C. \<forall>s\<in>S'. S' \<noteq> {} \<longrightarrow> 2 * r < dist c s)" using IH inv_def by simp
-      then show ?thesis by (smt case_assm s_def assms(1) dist_self dist_triangle3 singletonD)
+      then show ?thesis by (smt (verit) case_assm s_def assms(1) dist_self dist_triangle3 singletonD)
     next
       assume case_assm: "c\<^sub>1 \<in> C \<and> c\<^sub>2 = s"
       have "(\<forall>c \<in> C. \<forall>s\<in>S'. S' \<noteq> {} \<longrightarrow> 2 * r < dist c s)" using IH inv_def by simp
-      then show ?thesis by (smt case_assm s_def assms(1) dist_self dist_triangle3 singletonD)
+      then show ?thesis by (smt (verit) case_assm s_def assms(1) dist_self dist_triangle3 singletonD)
     next
       assume "c\<^sub>1 = s \<and> c\<^sub>2 = s"
       then have False using local_assms(3) by simp
       then show ?thesis by simp
     qed
   qed
 
   moreover
 
   have "(\<forall>c\<in>C \<union> {s}. \<forall>s'' \<in> S' - {s' \<in> S'. dist s s' \<le> 2 * r}.
            S' - {s' \<in> S'. dist s s' \<le> 2 * r} \<noteq> {} \<longrightarrow> 2 * r < dist c s'')"
     using IH inv_def by fastforce
 
   moreover
 
   have "(S' - {s' \<in> S'. dist s s' \<le> 2 * r} = S \<or> C \<union> {s} \<noteq> {})" by simp
 
   ultimately show ?thesis unfolding inv_def by blast
 qed
 
 lemma inv_last_1: 
   assumes "\<forall>s \<in> (S - S'). distance C s \<le> 2*r"
     and "S' = {}"
   shows "radius C \<le> 2*r"
   by (metis Diff_empty assms image_iff radius_contained)
 
 lemma inv_last_2: 
   assumes "finite C"
   and "card C > n"
   and "C \<subseteq> S"
   and "\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2*r"
   shows "\<forall>C'. card C' \<le> n \<and> card C' > 0 \<longrightarrow> radius C' > r" (is ?P)
 proof (rule ccontr)
   assume "\<not> ?P"
   then obtain C' where card_C': "card C' \<le> n \<and> card C' > 0" and radius_C': "radius C' \<le> r" by auto
   have "\<forall>c \<in> C. (\<exists>c'. c' \<in> C' \<and> dist c c' \<le> r)"
   proof
     fix c
     assume "c \<in> C"
     then have "c \<in> S" using assms(3) by blast
     then have "distance C' c \<le> radius C'" using finite_distances by (simp add: radius_def)
     then have "distance C' c \<le> r" using radius_C' by simp
     then show "\<exists>c'. c' \<in> C' \<and> dist c c' \<le> r" using dist_lemmas
       by (metis card_C' card_gt_0_iff)
   qed
   then obtain f where f: "\<forall>c\<in>C. f c \<in> C' \<and> dist c (f c) \<le> r" by metis
   have "\<not>inj_on f C"
   proof
     assume "inj_on f C"
     then have "card C' \<ge> card C" using \<open>inj_on f C\<close> card_inj_on_le card_ge_0_finite card_C' f by blast
     then show False using card_C' \<open>n < card C\<close> by linarith
   qed
   then obtain c1 c2 where defs: "c1 \<in> C \<and> c2 \<in> C \<and> c1 \<noteq> c2 \<and> f c1 = f c2" using inj_on_def by blast
   then have *: "dist c1 (f c1) \<le> r \<and> dist c2 (f c1) \<le> r" using f by auto
 
   have "2 * r < dist c1 c2" using assms defs by simp
   also have " ... \<le> dist c1 (f c1) + dist (f c1) c2" by(rule dist_triangle)
   also have " ... = dist c1 (f c1) + dist c2 (f c1)" using dist_commute by simp
   also have " ... \<le> 2 * r" using * by simp
   finally show False by simp
 qed
 
 lemma inv_last:
   assumes "inv {} C r"
   shows "(card C \<le> k \<longrightarrow> radius C \<le> 2*r) \<and> (card C > k \<longrightarrow> (\<forall>C'. card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C' > r))"
   using assms inv_def inv_last_1 inv_last_2 finite_subset[OF _ finite_sites] by auto
 
 theorem Center_Selection_r:
   "VARS (S' :: ('a :: metric_space) set) (C :: ('a :: metric_space) set) (r :: real) (s :: 'a)
   {True}
   S' := S;
   C := {};
   WHILE S' \<noteq> {} INV {inv S' C r} DO
     s := (SOME s. s \<in> S');
     C := C \<union> {s};
     S' := S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}
     OD
   {(card C \<le> k \<longrightarrow> radius C \<le> 2*r) \<and> (card C > k \<longrightarrow> (\<forall>C'. card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C' > r))}"
 proof (vcg, goal_cases)
   case (1 S' C r)
   then show ?case using inv_init by simp
 next
   case (2 S' C r)
   then show ?case using inv_step by simp
 next
   case (3 S' C r)
   then show ?case using inv_last by blast
 qed
 
 
 subsection \<open>The Main Algorithm\<close>
 
 definition invar :: "('a :: metric_space) set \<Rightarrow> bool" where
 "invar C = (C \<noteq> {} \<and> card C \<le> k \<and> C \<subseteq> S \<and>
   (\<forall>C'. (\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2 * radius C')
         \<or> (\<forall>s \<in> S. distance C s \<le> 2 * radius C')))"
 
 abbreviation some where "some A \<equiv> (SOME s. s \<in> A)"
 
 lemma invar_init: "invar {some S}"
 proof -
   let ?s = "some S"
   have s_in_S: "?s \<in> S" using some_in_eq non_empty_sites by blast
 
   have "{?s} \<noteq> {}" by simp
 
   moreover
 
   have "{SOME s. s \<in> S} \<subseteq> S" using s_in_S by simp
 
   moreover
 
   have "card {SOME s. s \<in> S} \<le> k" using non_zero_k by simp
 
   ultimately show ?thesis by (auto simp: invar_def)
 qed
 
 abbreviation furthest_from where
 "furthest_from C \<equiv> (SOME s. s \<in> S \<and> distance C s = Max (distance C ` S))" 
 
 lemma invar_step:
 assumes "invar C"
 and "card C < k"
 shows "invar (C \<union> {furthest_from C})"
 proof -
   have furthest_from_C_props: "furthest_from C \<in> S \<and> distance C (furthest_from C) = radius C "
     using someI_ex[of "\<lambda>x. x \<in> S \<and> distance C x = radius C"] radius_def2 radius_def by auto
   have C_props: "finite C \<and> C \<noteq> {}"
     using finite_subset[OF _ finite_sites] assms(1) unfolding invar_def by blast
   {
     have "card (C \<union> {furthest_from C}) \<le> card C + 1"
       using assms(1) C_props unfolding invar_def by (simp add: card_insert_if)
     then have "card (C \<union> {furthest_from C}) < k + 1" using assms(2) by simp
     then have "card (C \<union> {furthest_from C}) \<le> k" by simp
   }
   moreover
 
   have "C \<union> {furthest_from C} \<noteq> {}" by simp
 
   moreover
 
   have "(C \<union> {furthest_from C}) \<subseteq> S" using assms(1) furthest_from_C_props unfolding invar_def by simp
 
   moreover
 
   have "\<forall>C'. (\<forall>s \<in> S. distance (C \<union> {furthest_from C}) s \<le> 2 * radius C')
           \<or> (\<forall>c\<^sub>1 \<in> C \<union> {furthest_from C}. \<forall>c\<^sub>2 \<in> C \<union> {furthest_from C}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2)"
   proof 
     fix C'
     have "distance C (furthest_from C) > 2 * radius C' \<or> distance C (furthest_from C) \<le> 2 * radius C'" by auto
     then show "(\<forall>s \<in> S. distance (C \<union> {furthest_from C}) s \<le> 2 * radius C')
                \<or> (\<forall>c\<^sub>1 \<in> C \<union> {furthest_from C}. \<forall>c\<^sub>2 \<in> C \<union> {furthest_from C}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2)"
     proof (elim disjE)
       assume asm: "distance C (furthest_from C) > 2 * radius C'"
       then have "\<not>(\<forall>s \<in> S. distance C s \<le> 2 * radius C')" using furthest_from_C_props by force
       then have IH: "\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2"
         using assms(1) unfolding invar_def by blast
       have "(\<forall>c\<^sub>1 \<in> C \<union> {furthest_from C}. (\<forall>c\<^sub>2 \<in> C \<union> {furthest_from C}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2))"
         using dist_ins[of "C" "2 * radius C'" "furthest_from C"] IH C_props asm by simp
       then show ?thesis by simp
     next
       assume main_assm: "2 * radius C' \<ge> distance C (furthest_from C)"
       have "(\<forall>s \<in> S. distance (C \<union> {furthest_from C}) s \<le> 2 * radius C')"
       proof
         fix s
         assume local_assm: "s \<in> S"
         then show "distance (C \<union> {furthest_from C}) s \<le> 2 * radius C'"
         proof -
           have "distance (C \<union> {furthest_from C}) s \<le> distance C s"
             using distance_mono[of C "C \<union> {furthest_from C}"] C_props by auto
           also have " ... \<le> distance C (furthest_from C)"
             using Max.coboundedI local_assm finite_distances radius_def furthest_from_C_props by auto
           also have " ... \<le> 2 * radius C'" using main_assm by simp
           finally show ?thesis .
         qed
       qed
       then show ?thesis by blast
     qed
   qed
 
   ultimately show ?thesis unfolding invar_def by blast
 qed
 
 lemma invar_last:
 assumes "invar C" and "\<not>card C < k"
 shows "card C = k" and "card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C \<le> 2 * radius C'"
 proof -
   show "card C = k" using assms(1, 2) unfolding invar_def by simp
 next
   have C_props: "finite C \<and> C \<noteq> {}" using finite_sites assms(1) unfolding invar_def by (meson finite_subset)
   show "card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C \<le> 2 * radius C'"
   proof (rule impI)
     assume C'_assms: "0 < card (C' :: 'a set) \<and> card C' \<le> k"
     let ?r = "radius C'"
     have "(\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * ?r < dist c\<^sub>1 c\<^sub>2) \<or> (\<forall>s \<in> S. distance C s \<le> 2 * ?r)"
       using assms(1) unfolding invar_def by simp
     then show "radius C \<le> 2 * ?r"
     proof
       assume case_assm: "\<forall>c\<^sub>1\<in>C. \<forall>c\<^sub>2\<in>C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * ?r < dist c\<^sub>1 c\<^sub>2"
       obtain s where s_def: "radius C = distance C s \<and> s \<in> S" using radius_def2 by metis
       show ?thesis
       proof (rule ccontr)
         assume contr_assm: "\<not> radius C \<le> 2 * ?r"
         then have s_prop: "distance C s > 2 * ?r" using s_def by simp
         then have \<open>\<forall>c\<^sub>1 \<in> C \<union> {s}. \<forall>c\<^sub>2 \<in> C \<union> {s}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2 * ?r\<close>
           using C_props dist_ins[of "C" "2*?r" "s"] case_assm by blast
         moreover
         {
           have "s \<notin> C"
           proof
             assume "s \<in> C"
             then have "distance C s \<le> dist s s" using Min.coboundedI[of "distance C ` S" "dist s s"] 
               by (simp add: distance_def C_props)
             also have " ... = 0" by simp
-            finally have "distance C s = 0" using dist_lemmas(4) by (smt C_props)
+            finally have "distance C s = 0" using dist_lemmas(4) by (smt (verit) C_props)
             then have radius_le_zero: "2 * ?r < 0" using contr_assm s_def by simp
             obtain x where x_def: "?r = distance C' x" using radius_def2 by metis
             obtain l where l_def: "distance C' x = dist x l" using dist_lemmas(3) by (metis C'_assms card_gt_0_iff)
             then have "dist x l = ?r" by (simp add: x_def)
             also have "...  < 0" using C'_assms radius_le_zero by simp
             finally show False by simp
           qed
           then have "card (C \<union> {s}) > k" using assms(1,2) C_props unfolding invar_def by simp
         }
         moreover
           have "C \<union> {s} \<subseteq> S" using assms(1) s_def unfolding invar_def by simp
         moreover
           have "finite (C \<union> {s})" using calculation(3) finite_subset finite_sites by auto
         ultimately have "\<forall>C. card C \<le> k \<and> card C > 0 \<longrightarrow> radius C > ?r" using inv_last_2 by metis
         then have "?r > ?r" using C'_assms by blast
         then show False by simp
       qed
     next
       assume "\<forall>s\<in>S. distance C s \<le> 2 * radius C'"
       then show ?thesis by (metis image_iff radius_contained)
     qed
   qed
 qed
 
 theorem Center_Selection: 
 "VARS (C :: ('a :: metric_space) set) (s :: ('a :: metric_space))
   {k \<le> card S}
   C := {some S};
   WHILE card C < k INV {invar C} DO
     C := C \<union> {furthest_from C}
   OD
   {card C = k \<and> (\<forall>C'. card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C \<le> 2 * radius C')}"
 proof (vcg, goal_cases)
   case (1 C s)
   show ?case using invar_init by simp
 next
   case (2 C s)
   then show ?case using invar_step by blast
 next
   case (3 C s)
   then show ?case using invar_last by blast
 qed
 
 end
 end
\ No newline at end of file
diff --git a/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy b/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy
--- a/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy
+++ b/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy
@@ -1,955 +1,955 @@
 (*
   File:   Arith_Prog_Rel_Primes.thy
   Author: Jose Manuel Rodriguez Caballero, University of Tartu
 *)
 section \<open>Problem ARITHMETIC PROGRESSIONS (Putnam exam problems 2002)\<close>
 theory Arith_Prog_Rel_Primes
   imports
     Complex_Main 
     "HOL-Number_Theory.Number_Theory"
 begin
 
 text \<open>
  Statement of the problem (from ~\<^cite>\<open>"putnam"\<close>): For which integers $n>1$ does the set of positive 
  integers less than and relatively prime to $n$ constitute an arithmetic progression?
  
  The solution of the above problem is theorem @{text arith_prog_rel_primes_solution}.
 
  First, we will require some auxiliary material before we get started with the actual
  solution.
 \<close>
 
 subsection \<open>Auxiliary results\<close>
 
 lemma even_and_odd_parts:
   fixes n::nat
   assumes \<open>n \<noteq> 0\<close>
   shows \<open>\<exists> k q::nat. n = (2::nat)^k*q \<and> odd q\<close>
 proof-
   have \<open>prime (2::nat)\<close>
     by simp    
   thus ?thesis
     using prime_power_canonical[where p = "2" and m = "n"]
       assms semiring_normalization_rules(7) by auto    
 qed
 
 lemma only_one_odd_div_power2:
   fixes n::nat
   assumes \<open>n \<noteq> 0\<close> and  \<open>\<And> x. x dvd n \<Longrightarrow> odd x \<Longrightarrow> x = 1\<close>
   shows \<open>\<exists> k. n = (2::nat)^k\<close>
   by (metis even_and_odd_parts assms(1) assms(2) dvd_triv_left semiring_normalization_rules(11)
       semiring_normalization_rules(7))
 
 lemma coprime_power2:
   fixes n::nat
   assumes \<open>n \<noteq> 0\<close> and \<open>\<And> x. x < n \<Longrightarrow> (coprime x n \<longleftrightarrow> odd x)\<close>
   shows \<open>\<exists> k. n = (2::nat)^k\<close>
 proof-
   have \<open>x dvd n \<Longrightarrow> odd x \<Longrightarrow> x = 1\<close>
     for x
     by (metis neq0_conv One_nat_def Suc_1 Suc_lessI assms(1) assms(2) coprime_left_2_iff_odd
         dvd_refl linorder_neqE_nat nat_dvd_1_iff_1 nat_dvd_not_less not_coprimeI)
   thus ?thesis
     using assms(1) only_one_odd_div_power2 
     by auto 
 qed
 
 subsection \<open>Main result\<close>
 
 text \<open>
   The solution to the problem  ARITHMETIC PROGRESSIONS (Putnam exam problems 2002)
 \<close>
 
 theorem arith_prog_rel_primes_solution:
   fixes n :: nat
   assumes \<open>n > 1\<close>
   shows \<open>(prime n \<or> (\<exists> k. n = 2^k) \<or> n = 6) \<longleftrightarrow>  
 (\<exists> a b m. m \<noteq> 0 \<and> {x | x. x < n \<and> coprime x n} = {a+j*b| j::nat. j < m})\<close>
 proof-
   have \<open> (prime n \<or> (\<exists> k. n = 2^k) \<or>  n = 6) \<longleftrightarrow>
  (\<exists> b m. m \<noteq> 0 \<and> {x | x :: nat. x < n \<and> coprime x n} = {1+j*b| j::nat. j < m})\<close>
   proof
     show "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
       if "prime n \<or> (\<exists>k. n = 2 ^ k) \<or> n = 6"
     proof-
       have "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
         if "prime n"
       proof-
         have \<open>\<exists>m.   m \<noteq> 0 \<and> {x | x :: nat. x < n \<and> coprime x n} = {1+j| j::nat. j < m}\<close>
         proof-
           have \<open>{x | x :: nat. x < n \<and> coprime x n} =  {x | x :: nat. x \<noteq> 0 \<and> x < n}\<close> 
           proof
             show "{x |x. x < n \<and> coprime x n} \<subseteq> {x |x. x \<noteq> 0 \<and> x < n}"
-              by (smt Collect_mono not_le ord_0_nat ord_eq_0 order_refl prime_gt_1_nat that zero_neq_one)
+              using prime_nat_iff'' that by fastforce
             show "{x |x. x \<noteq> 0 \<and> x < n} \<subseteq> {x |x. x < n \<and> coprime x n}"
               using coprime_commute prime_nat_iff'' that 
               by fastforce              
           qed
           obtain m where \<open>m+1 = n\<close>
             using add.commute assms less_imp_add_positive by blast
           have \<open>{1+j| j::nat. j < (m::nat)} =  {x | x :: nat. x \<noteq> 0 \<and> x < m+1}\<close> 
             by (metis Suc_eq_plus1   \<open>m + 1 = n\<close> gr0_implies_Suc le_simps(3)   less_nat_zero_code   linorder_not_less nat.simps(3) nat_neq_iff  plus_1_eq_Suc )
           hence  \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j| j::nat. j < (m::nat)}\<close>
             using \<open>{x | x :: nat. x < n \<and> coprime x n} =  {x | x :: nat. x \<noteq> 0 \<and> x < n}\<close>  \<open>m+1 = n\<close> 
             by auto
           from \<open>n > 1\<close> have \<open>m \<noteq> 0\<close> 
             using \<open>m + 1 = n\<close> by linarith
           have \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j| j::nat. j < m}\<close> 
             using Suc_eq_plus1 \<open>1 < n\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j |j. j < m}\<close> 
             by auto
           hence \<open>(\<exists> m.  m \<noteq> 0 \<and> {x | x :: nat. x < n \<and> coprime x n} = {1+j| j::nat. j < m})\<close>
             using \<open>m \<noteq> 0\<close> 
             by blast
           thus ?thesis by blast
         qed
         hence \<open>\<exists>m.  m \<noteq> 0 \<and> {x | x :: nat. x < n \<and> coprime x n} = {1+j*1| j::nat. j < m}\<close>
           by auto
         thus ?thesis
           by blast 
       qed
       moreover have "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
         if "\<exists>k. n = 2 ^ k"
       proof-
         obtain k where \<open>n = 2 ^ k\<close>
           using \<open>\<exists>k. n = 2 ^ k\<close> by auto
         have \<open>k \<noteq> 0\<close> 
           by (metis \<open>1 < n\<close> \<open>n = 2 ^ k\<close> nat_less_le power.simps(1))
         obtain t where \<open>Suc t = k\<close> 
           by (metis \<open>k \<noteq> 0\<close> fib.cases)
         have \<open>n = 2^(Suc t)\<close> 
           by (simp add: \<open>Suc t = k\<close> \<open>n = 2 ^ k\<close>)
         have \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j*2| j::nat. j < 2^t}\<close>
         proof
           show "{x |x. x < n \<and> coprime x n} \<subseteq> {1 + j * 2 |j. j < 2^t}"
           proof
             fix x
             assume \<open>x \<in> {x |x. x < n \<and> coprime x n}\<close>
             hence \<open>x < n\<close>
               by blast
             have \<open>coprime x n\<close>
               using \<open>x \<in> {x |x. x < n \<and> coprime x n}\<close>
               by blast
             hence \<open>coprime x (2^(Suc k))\<close>
               by (simp add: \<open>k \<noteq> 0\<close> \<open>n = 2 ^ k\<close>)              
             have \<open>odd x\<close>
               using \<open>coprime x n\<close> \<open>k \<noteq> 0\<close> \<open>n = 2 ^ k\<close> 
               by auto 
             then obtain j where \<open>x = 1+j*2\<close>
               by (metis add.commute add.left_commute left_add_twice mult_2_right oddE)
             have \<open>x < 2^k\<close>
               using \<open>n = 2 ^ k\<close> \<open>x < n\<close> \<open>x = 1+j*2\<close> 
               by linarith
             hence \<open>1+j*2 < 2^k\<close>
               using \<open>x = 1+j*2\<close>
               by blast
             hence \<open>j < 2^t\<close>
               using \<open>Suc t = k\<close> by auto              
             thus \<open>x \<in> {1 + j * 2 |j. j < 2^t}\<close>
               using \<open>x = 1+j*2\<close>
               by blast
           qed
           show "{1 + j * 2 |j. j < 2 ^ t} \<subseteq> {x |x. x < n \<and> coprime x n}"
           proof
             fix x::nat
             assume \<open>x \<in> {1 + j * 2 |j. j < 2 ^ t}\<close>
             then obtain j where \<open>x = 1 + j * 2\<close> and \<open>j < 2 ^ t\<close>
               by blast
             have \<open>x < 2*(2^t)\<close>
               using  \<open>x = 1 + j * 2\<close>  \<open>j < 2 ^ t\<close>
               by linarith              
             hence \<open>x < n\<close>
               by (simp add: \<open>n = 2 ^ Suc t\<close>)
             moreover have \<open>coprime x n\<close>
               by (metis (no_types) \<open>\<And>thesis. (\<And>j. \<lbrakk>x = 1 + j * 2; j < 2 ^ t\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>n = 2 ^ k\<close> coprime_Suc_left_nat coprime_mult_right_iff coprime_power_right_iff plus_1_eq_Suc)              
             ultimately show \<open>x \<in> {x |x. x < n \<and> coprime x n}\<close>
               by blast
           qed
         qed
         have \<open>(2::nat)^(t::nat) \<noteq> 0\<close> 
           by simp
         obtain m where \<open>m = (2::nat)^t\<close> by blast
         have \<open>m \<noteq> 0\<close> 
           using \<open>m = 2 ^ t\<close> 
           by auto
         have \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j*2| j::nat. j < m}\<close>
           using \<open>m = 2 ^ t\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * 2 |j. j < 2 ^ t}\<close> 
           by auto
         from  \<open>m \<noteq> 0\<close>  \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j*2| j::nat. j < m}\<close>
         show ?thesis by blast
       qed
       moreover have "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
         if "n = 6"
       proof-
         have  \<open>{x | x. x < 6 \<and> coprime x 6} = {1+j*4| j::nat. j < 2}\<close>
         proof-
           have \<open>{x | x::nat. x < 6 \<and> coprime x 6} = {1, 5}\<close>
           proof
             show "{u. \<exists>x. u = (x::nat) \<and> x < 6 \<and> coprime x 6} \<subseteq> {1, 5}"
             proof
               fix u::nat
               assume \<open>u \<in> {u. \<exists>x. u = x \<and> x < 6 \<and> coprime x 6}\<close>
               hence \<open>coprime u 6\<close>
                 by blast
               have \<open>u < 6\<close>
                 using \<open>u \<in> {u. \<exists>x. u = x \<and> x < 6 \<and> coprime x 6}\<close>
                 by blast
               moreover have \<open>u \<noteq> 0\<close>
                 using \<open>coprime u 6\<close> ord_eq_0 
                 by fastforce
               moreover have \<open>u \<noteq> 2\<close>
                 using \<open>coprime u 6\<close>
                 by auto
               moreover have \<open>u \<noteq> 3\<close>
               proof-
                 have \<open>gcd (3::nat) 6 = 3\<close>
                   by auto
                 thus ?thesis 
                   by (metis (no_types) \<open>coprime u 6\<close> \<open>gcd 3 6 = 3\<close> coprime_iff_gcd_eq_1 
                       numeral_eq_one_iff semiring_norm(86))
               qed
               moreover have \<open>u \<noteq> 4\<close>
               proof-
                 have \<open>gcd (4::nat) 6 = 2\<close>
                   by (metis (no_types, lifting) add_numeral_left gcd_add1 gcd_add2 gcd_nat.idem
                       numeral_Bit0 numeral_One one_plus_numeral semiring_norm(4) semiring_norm(5))
                 thus ?thesis
                   using \<open>coprime u 6\<close> coprime_iff_gcd_eq_1 
                   by auto 
               qed
               ultimately have \<open>u = 1 \<or> u = 5\<close>
                 by auto
               thus \<open>u \<in> {1, 5}\<close>
                 by blast
             qed
             show "{1::nat, 5} \<subseteq> {x |x. x < 6 \<and> coprime x 6}"
             proof-
               have \<open>(1::nat) \<in> {x |x. x < 6 \<and> coprime x 6}\<close>
                 by simp                
               moreover have \<open>(5::nat) \<in> {x |x. x < 6 \<and> coprime x 6}\<close>
                 by (metis Suc_numeral coprime_Suc_right_nat less_add_one mem_Collect_eq
                     numeral_plus_one semiring_norm(5) semiring_norm(8))                
               ultimately show ?thesis 
                 by blast
             qed
           qed
           moreover have \<open>{1+j*4| j::nat. j < 2} = {1, 5}\<close>
             by auto
           ultimately show ?thesis by auto
         qed
         moreover have \<open>(2::nat) \<noteq> 0\<close>
           by simp          
         ultimately have \<open>\<exists> m.  m \<noteq> 0 \<and> {x | x :: nat. x < 6 \<and> coprime x 6} = {1+j*4| j::nat. j < m}\<close>
           by blast
         thus ?thesis
           using that 
           by auto 
       qed
       ultimately show ?thesis
         using that 
         by blast 
     qed
     show "prime n \<or> (\<exists>k. n = 2 ^ k) \<or> n = 6"
       if "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
     proof-
       obtain b m where \<open>m \<noteq> 0\<close> and \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close>
         using \<open>\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
         by auto
       show ?thesis
       proof(cases \<open>n = 2\<close>)
         case True
         thus ?thesis
           by auto 
       next
         case False
         have \<open>b \<le> 4\<close>
         proof(cases \<open>odd b\<close>)
           case True
           show ?thesis
           proof(rule classical)
             assume \<open>\<not>(b \<le> 4)\<close>
             hence \<open>b > 4\<close> 
               using le_less_linear 
               by blast
             obtain m where \<open>m \<noteq> 0\<close> 
               and \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j*b| j::nat. j < m}\<close>
               using \<open>m \<noteq> 0\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             have \<open>b \<noteq> 0\<close> 
               using \<open>4 < b\<close> 
               by linarith
             have \<open>n = 2 + (m-1)*b\<close> 
             proof-
               have \<open>n-1 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                 using \<open>1 < n\<close> coprime_diff_one_left_nat 
                 by auto
               have \<open>n-1 \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> 
                   \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast
               then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close> 
                 by blast
               have \<open>i \<le> m-1\<close> 
                 using \<open>i < m\<close> 
                 by linarith
               have \<open>1 + (m-1)*b \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>m \<noteq> 0\<close> 
                 by auto
               hence \<open>1 + (m-1)*b \<in> {x | x::nat. x < n \<and> coprime x n}\<close> 
                 using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast
               hence \<open>1 + (m-1)*b < n\<close> 
                 by blast
               hence \<open>1 + (m-1)*b \<le> n-1\<close> 
                 by linarith
               hence \<open>1 + (m-1)*b \<le> 1+i*b\<close> 
                 using \<open>n - 1 = 1 + i * b\<close> 
                 by linarith
               hence \<open>(m-1)*b \<le> i*b\<close> 
                 by linarith
               hence \<open>m-1 \<le> i\<close> 
                 using \<open>b \<noteq> 0\<close> 
                 by auto
               hence \<open>m-1 = i\<close> 
                 using \<open>i \<le> m - 1\<close> le_antisym 
                 by blast
               thus ?thesis 
                 using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close> 
                 by auto
             qed
             have \<open>m \<ge> 2\<close> 
               using \<open>n = 2 + (m - 1)*b\<close> \<open>n \<noteq> 2\<close> 
               by auto
             hence \<open>1+b \<in> {1+j*b| j. j < m}\<close> 
               by fastforce
             hence  \<open>1+b \<in> {x | x::nat. x < n \<and> coprime x n}\<close>
               using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             hence \<open>coprime (1+b) n\<close> 
               by blast
             have \<open>(2::nat) dvd (1+b)\<close> 
               using \<open>odd b\<close> 
               by simp
             hence \<open>coprime (2::nat) n\<close> 
               using \<open>coprime (1 + b) n\<close> coprime_common_divisor coprime_left_2_iff_odd odd_one 
               by blast
             have \<open>(2::nat) < n\<close> 
               using \<open>1 < n\<close> \<open>n \<noteq> 2\<close> 
               by linarith
             have \<open>2 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
               using \<open>2 < n\<close> \<open>coprime 2 n\<close> 
               by blast 
             hence  \<open>2 \<in> {1+j*b| j::nat. j < m}\<close> 
               using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             then obtain j::nat where \<open>2 = 1+j*b\<close> 
               by blast 
             have  \<open>1 = j*b\<close> 
               using \<open>2 = 1+j*b\<close>
               by linarith
             thus ?thesis 
               by simp
           qed
         next
           case False
           hence \<open>even b\<close>
             by simp
           show ?thesis
           proof(rule classical)
             assume \<open>\<not>(b \<le> 4)\<close>
             hence \<open>b > 4\<close> 
               using le_less_linear 
               by blast
             obtain m where  \<open> m \<noteq> 0\<close>
               and \<open>{x | x::nat. x < n \<and> coprime x n} = {1+j*b| j::nat. j < m}\<close>
               using \<open>m \<noteq> 0\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             have \<open>b \<noteq> 0\<close> 
               using \<open>4 < b\<close> 
               by linarith
             have \<open>n = 2 + (m-1)*b\<close> 
             proof-
               have \<open>n-1 \<in> {x | x::nat. x < n \<and> coprime x n}\<close> 
                 using \<open>1 < n\<close> coprime_diff_one_left_nat 
                 by auto
               have \<open>n-1 \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> 
                   \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast
               then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close> 
                 by blast
               have \<open>i \<le> m-1\<close> 
                 using \<open>i < m\<close> 
                 by linarith
               have \<open>1 + (m-1)*b \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>m \<noteq> 0\<close> 
                 by auto
               hence \<open>1 + (m-1)*b \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                 using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast
               hence \<open>1 + (m-1)*b < n\<close> 
                 by blast
               hence \<open>1 + (m-1)*b \<le> n-1\<close> 
                 by linarith
               hence \<open>1 + (m-1)*b \<le> 1+i*b\<close> 
                 using \<open>n - 1 = 1 + i * b\<close> 
                 by linarith
               hence \<open>(m-1)*b \<le> i*b\<close> 
                 by linarith
               hence \<open>m-1 \<le> i\<close> 
                 using \<open>b \<noteq> 0\<close> 
                 by auto
               hence \<open>m-1 = i\<close> 
                 using \<open>i \<le> m - 1\<close> le_antisym 
                 by blast
               thus ?thesis 
                 using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close> 
                 by auto
             qed
             obtain k :: nat where \<open>b = 2*k\<close> 
               using \<open>even b\<close>
               by blast
             have \<open>n = 2*(1 + (m-1)*k)\<close>
               using  \<open>n = 2 + (m-1)*b\<close>  \<open>b = 2*k\<close> 
               by simp
             show ?thesis
             proof (cases \<open>odd m\<close>)
               case True
               hence \<open>odd m\<close> by blast
               then obtain t::nat where \<open>m-1 = 2*t\<close> 
                 by (metis odd_two_times_div_two_nat)
               have  \<open>n = 2*(1 + b*t)\<close> 
                 using \<open>m - 1 = 2 * t\<close> \<open>n = 2 + (m - 1) * b\<close> 
                 by auto
               have \<open>t < m\<close> 
                 using \<open>m - 1 = 2 * t\<close> \<open>m \<noteq> 0\<close> 
                 by linarith
               have \<open>1 + b*t \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>t < m\<close> 
                 by auto 
               hence \<open>1 + b*t \<in> {x | x::nat. x < n \<and> coprime x n}\<close> 
                 using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast 
               hence \<open>coprime (1 + b*t) n\<close> 
                 by auto
               thus ?thesis 
                 by (metis (no_types, lifting) \<open>b = 2 * k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 * (1 + b * t)\<close> \<open>n = 2 + (m - 1) * b\<close> \<open>n \<noteq> 2\<close> add_cancel_right_right coprime_mult_right_iff coprime_self mult_cancel_left mult_is_0 nat_dvd_1_iff_1)
             next
               case False
               thus ?thesis
               proof(cases \<open>odd k\<close>)
                 case True
                 hence \<open>odd k\<close>
                   by blast
                 have \<open>even (1 + (m - 1) * k)\<close> 
                   by (simp add: False True \<open>m \<noteq> 0\<close>)
                 have \<open>coprime (2 + (m - 1) * k) (1 + (m - 1) * k)\<close> 
                   by simp
                 have \<open>coprime (2 + (m - 1) * k) n\<close> 
                   using \<open>coprime (2 + (m - 1) * k) (1 + (m - 1) * k)\<close> \<open>even (1 + (m - 1) * k)\<close> 
                     \<open>n = 2 * (1 + (m - 1) * k)\<close> coprime_common_divisor coprime_mult_right_iff
                     coprime_right_2_iff_odd odd_one 
                   by blast
                 have \<open>2 + (m - 1) * k < n\<close> 
                   by (metis (no_types, lifting) \<open>even (1 + (m - 1) * k)\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close>
                       add_gr_0 add_mono_thms_linordered_semiring(1) dvd_add_left_iff dvd_add_triv_left_iff dvd_imp_le le_add2 le_neq_implies_less less_numeral_extra(1) mult_2 odd_one)
                 have \<open>2 + (m - 1) * k  \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                   using \<open>2 + (m - 1) * k < n\<close> \<open>coprime (2 + (m - 1) * k) n\<close> 
                   by blast
                 hence \<open>2 + (m - 1) * k  \<in> {1 + j * b |j. j < m}\<close> 
                   using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                   by blast
                 then obtain j::nat where  \<open>2 + (m - 1) * k  = 1 + j * b\<close> and \<open>j < m\<close>
                   by blast
                 have  \<open>1 + (m - 1) * k  = j * b\<close>
                   using \<open>2 + (m - 1) * k  = 1 + j * b\<close>
                   by simp
                 hence  \<open>1 + (m - 1) * k  = j * (2*k)\<close> 
                   using \<open>b = 2 * k\<close> by blast
                 thus ?thesis 
                   by (metis \<open>b = 2 * k\<close> \<open>even b\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 + (m - 1) * b\<close> dvd_add_times_triv_right_iff dvd_antisym dvd_imp_le dvd_triv_right even_numeral mult_2 zero_less_numeral)
               next
                 case False
                 hence \<open>even k\<close> by auto
                 have \<open>odd (1 + (m - 1) * k)\<close> 
                   by (simp add: \<open>even k\<close> )
                 hence \<open>coprime (3 + (m - 1) * k) (1 + (m - 1) * k)\<close> 
-                  by (smt add_numeral_left coprime_common_divisor coprime_right_2_iff_odd dvd_add_left_iff not_coprimeE numeral_Bit1 numeral_One numeral_plus_one one_add_one)
+                  by (smt (verit) add_numeral_left coprime_common_divisor coprime_right_2_iff_odd dvd_add_left_iff not_coprimeE numeral_Bit1 numeral_One numeral_plus_one one_add_one)
                 hence \<open>coprime (3 + (m - 1) * k) n\<close> 
                   by (metis \<open>even k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> coprime_mult_right_iff coprime_right_2_iff_odd even_add even_mult_iff odd_numeral)
                 have \<open>3 + (m - 1) * k < n\<close> 
-                  by (smt Groups.add_ac(2) \<open>even k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 + (m - 1) * b\<close> \<open>n \<noteq> 2\<close> add_Suc_right add_cancel_right_right add_mono_thms_linordered_semiring(1) dvd_imp_le even_add even_mult_iff le_add2 le_neq_implies_less left_add_twice mult_2 neq0_conv numeral_Bit1 numeral_One odd_numeral one_add_one plus_1_eq_Suc)
+                  by (smt (verit) Groups.add_ac(2) \<open>even k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 + (m - 1) * b\<close> \<open>n \<noteq> 2\<close> add_Suc_right add_cancel_right_right add_mono_thms_linordered_semiring(1) dvd_imp_le even_add even_mult_iff le_add2 le_neq_implies_less left_add_twice mult_2 neq0_conv numeral_Bit1 numeral_One odd_numeral one_add_one plus_1_eq_Suc)
                 have \<open>3 + (m - 1) * k \<in> {x |x. x < n \<and> coprime x n}\<close> 
                   using \<open>3 + (m - 1) * k < n\<close> \<open>coprime (3 + (m - 1) * k) n\<close> 
                   by blast
                 hence \<open>3 + (m - 1) * k \<in> {1 + j * b |j. j < m}\<close> 
                   using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                   by blast 
                 then obtain j::nat where \<open>3 + (m - 1) * k = 1 + j * b\<close> 
                   by blast  
                 have \<open>2 + (m - 1) * k = j * b\<close> 
                   using \<open>3 + (m - 1) * k = 1 + j * b\<close> 
                   by simp
                 hence  \<open>2 + (m - 1) * k = j * 2*k\<close> 
                   by (simp add: \<open>b = 2 * k\<close>)
                 thus ?thesis 
                   by (metis \<open>4 < b\<close> \<open>b = 2 * k\<close> \<open>even k\<close> dvd_add_times_triv_right_iff dvd_antisym 
                       dvd_triv_right mult_2 nat_neq_iff numeral_Bit0)
               qed
             qed
           qed
         qed
         moreover have \<open>b \<noteq> 3\<close>
         proof (rule classical)
           assume \<open>\<not> (b \<noteq> 3)\<close>
           hence \<open>b = 3\<close> 
             by blast
           obtain m where  \<open>m \<noteq> 0\<close> and 
             \<open>{x | x::nat. x < n \<and> coprime x n} = {1+j*b| j::nat. j < m}\<close>
             using \<open>m \<noteq> 0\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
             by blast
           have \<open>b \<noteq> 0\<close> 
             by (simp add: \<open>b = 3\<close>)
           have \<open>n = 2 + (m-1)*b\<close> 
           proof-
             have \<open>n-1 \<in> {x | x::nat. x < n \<and> coprime x n}\<close> 
               using \<open>1 < n\<close> coprime_diff_one_left_nat 
               by auto
             have \<open>n-1 \<in> {1+j*b| j::nat. j < m}\<close> 
               using \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> 
                 \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close> 
               by blast
             have \<open>i \<le> m-1\<close> 
               using \<open>i < m\<close> 
               by linarith
             have \<open>1 + (m-1)*b \<in> {1+j*b| j::nat. j < m}\<close> 
               using \<open>m \<noteq> 0\<close> 
               by auto
             hence \<open>1 + (m-1)*b \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
               using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             hence \<open>1 + (m-1)*b < n\<close> 
               by blast
             hence \<open>1 + (m-1)*b \<le> n-1\<close> 
               by linarith
             hence \<open>1 + (m-1)*b \<le> 1+i*b\<close> 
               using \<open>n - 1 = 1 + i * b\<close> 
               by linarith
             hence \<open>(m-1)*b \<le> i*b\<close> 
               by linarith
             hence \<open>m-1 \<le> i\<close> 
               using \<open>b \<noteq> 0\<close> 
               by auto
             hence \<open>m-1 = i\<close> 
               using \<open>i \<le> m - 1\<close> le_antisym 
               by blast
             thus ?thesis 
               using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close> 
               by auto
           qed
           have \<open>n > 2\<close> 
             using \<open>1 < n\<close> \<open>n \<noteq> 2\<close> 
             by linarith
           hence \<open> m \<ge> 2 \<close> using  \<open>n = 2 + (m-1)*b\<close> \<open>b = 3\<close> 
             by simp
           have \<open>4 \<in> {1+j*(b::nat)| j::nat. j < m}\<close> 
             using \<open>2 \<le> m\<close> \<open>b = 3\<close> 
             by force
           hence \<open>(4::nat) \<in>  {x | x :: nat. x < n \<and> coprime x n}\<close> 
             using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close>
             by auto
           hence \<open>coprime (4::nat) n\<close> 
             by blast
           have \<open>(2::nat) dvd 4\<close> 
             by auto
           hence \<open>coprime (2::nat) n\<close> 
             using \<open>coprime (4::nat) n\<close> coprime_divisors dvd_refl 
             by blast
           have \<open>4 < n\<close> 
             using \<open>4 \<in> {x |x. x < n \<and> coprime x n}\<close> 
             by blast
           have \<open>2 < (4::nat)\<close> 
             by auto
           have  \<open>2 < n\<close> 
             by (simp add: \<open>2 < n\<close>)
           hence \<open>2 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
             using  \<open>coprime (2::nat) n\<close> 
             by blast
           hence  \<open>2 \<in> {1+j*(b::nat)| j::nat. j < m}\<close> 
             using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
             by blast
           then obtain j::nat where \<open>2 = 1+j*3\<close> 
             using \<open>b = 3\<close> 
             by blast
           from  \<open>2 = 1+j*3\<close>
           have  \<open>1 = j*3\<close> 
             by auto
           hence \<open>3 dvd 1\<close> 
             by auto
           thus ?thesis
             using nat_dvd_1_iff_1 numeral_eq_one_iff 
             by blast
         qed
         ultimately have \<open>b = 0 \<or> b = 1 \<or> b = 2 \<or> b = 4\<close>
           by auto
         moreover have \<open>b = 0 \<Longrightarrow> \<exists>k. n = 2^k\<close>
         proof-
           assume \<open>b = 0\<close>
           have \<open>{1 + j * b |j. j < m} = {1}\<close>
             using \<open>b = 0\<close> \<open>m \<noteq> 0\<close> 
             by auto
           hence \<open>{x |x. x < n \<and> coprime x n} = {1}\<close>
             using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close>
             by blast
           hence \<open>n = 2\<close>
           proof-
             have \<open>n-1 \<in>  {x | x :: nat. x < n \<and> coprime x n}\<close> 
               using \<open>1 < n\<close> coprime_diff_one_left_nat 
               by auto
             have \<open>n-1 \<in> {1}\<close> 
               using \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> \<open>{x |x. x < n \<and> coprime x n} = {1}\<close> 
               by blast
             hence \<open>n-1 = 1\<close> 
               by blast
             hence \<open>n = 2\<close> 
               by simp
             thus ?thesis 
               by blast
           qed
           hence \<open>n = 2^1\<close>
             by auto
           thus ?thesis
             by blast 
         qed
         moreover have \<open>b = 1 \<Longrightarrow> prime n\<close>
         proof-
           assume \<open>b = 1\<close>
           have \<open>x < n \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> coprime x n\<close>
             for x
           proof-
             assume \<open>x < n\<close> and \<open>x \<noteq> 0\<close>
             have \<open>{1+j| j::nat. j < m} = {x | x::nat. x < m+1 \<and> x \<noteq> 0}\<close> 
               by (metis (full_types) Suc_eq_plus1  add_mono1 less_Suc_eq_0_disj  nat.simps(3) plus_1_eq_Suc )
             hence \<open>{x | x :: nat. x < n \<and> coprime x n} = {x | x :: nat. x < m+1 \<and> x \<noteq> 0}\<close>
               using \<open>b = 1\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by auto
             have \<open>coprime (n-1) n\<close> 
               using \<open>1 < n\<close> coprime_diff_one_left_nat 
               by auto
             have \<open>n-1 < n\<close> 
               using \<open>1 < n\<close> 
               by auto
             have \<open>n-1 \<in> {x |x. x < n \<and> coprime x n}\<close> 
               using \<open>coprime (n - 1) n\<close> \<open>n - 1 < n\<close> 
               by blast
             have \<open>n-1 \<le> m\<close> 
               by (metis (no_types, lifting) CollectD Suc_eq_plus1 Suc_less_eq2 \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> \<open>{x |x. x < n \<and> coprime x n} = {x |x. x < m + 1 \<and> x \<noteq> 0}\<close>   leD  le_less_linear not_less_eq_eq )
             have \<open>m \<in>  {x | x :: nat. x < m+1 \<and> x \<noteq> 0}\<close> 
               using \<open>m \<noteq> 0\<close> 
               by auto
             have \<open>m \<in> {x |x. x < n \<and> coprime x n} \<close> 
               using \<open>m \<in> {x |x. x < m + 1 \<and> x \<noteq> 0}\<close> 
                 \<open>{x |x. x < n \<and> coprime x n} = {x |x. x < m + 1 \<and> x \<noteq> 0}\<close> 
               by blast
             have \<open>m < n\<close> 
               using \<open>m \<in> {x |x. x < n \<and> coprime x n}\<close> 
               by blast
             have \<open>m+1 = n\<close> 
               using \<open>m < n\<close> \<open>n - 1 \<le> m\<close> 
               by linarith
             have \<open>x \<in>  {x | x :: nat. x < m+1 \<and> x \<noteq> 0}\<close> 
               using \<open>m + 1 = n\<close> \<open>x < n\<close> \<open>x \<noteq> 0\<close> 
               by blast
             hence \<open>x \<in> {x |x. x < n \<and> coprime x n}\<close> 
               using \<open>{x |x. x < n \<and> coprime x n} = {x |x. x < m + 1 \<and> x \<noteq> 0}\<close> 
               by blast
             thus ?thesis 
               by blast
           qed
           thus ?thesis
             using assms coprime_commute nat_neq_iff prime_nat_iff'' by auto 
         qed
         moreover have \<open>b = 2 \<Longrightarrow> \<exists> k. n = 2^k\<close>
         proof-
           assume \<open>b = 2\<close>
           have \<open>{x | x :: nat. x < n \<and> coprime x n} = {1+j*2| j::nat. j < m}\<close>
             using \<open>b = 2\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
             by auto
           have \<open>x < n \<Longrightarrow> coprime x n \<longleftrightarrow> odd x\<close>
             for x::nat
           proof-
             assume \<open>x < n\<close>
             have \<open>coprime x n \<Longrightarrow> odd x\<close>
             proof-
               assume \<open>coprime x n\<close>
               have \<open>x \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                 by (simp add: \<open>coprime x n\<close> \<open>x < n\<close>)
               hence \<open>x \<in> {1+j*2| j::nat. j < m}\<close> 
                 using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * 2 |j. j < m}\<close> 
                 by blast
               then obtain j where \<open>x = 1+j*2\<close> 
                 by blast
               thus ?thesis
                 by simp
             qed
             moreover have \<open>odd x \<Longrightarrow> coprime x n\<close>
             proof-
               assume \<open>odd x\<close>
               obtain j::nat where \<open>x = 1+j*2\<close> 
                 by (metis \<open>odd x\<close> add.commute mult_2_right odd_two_times_div_two_succ one_add_one semiring_normalization_rules(16)) 
               have \<open>j < (n-1)/2\<close> 
                 using \<open>x < n\<close> \<open>x = 1 + j * 2\<close> 
                 by linarith
               have \<open>n = 2*m\<close>
               proof-
                 have  \<open>(2::nat) \<noteq> 0\<close> 
                   by auto
                 have \<open>n = 2+(m-1)*2\<close> 
                 proof-
                   have \<open>n-1 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                     using \<open>1 < n\<close> coprime_diff_one_left_nat 
                     by auto
                   have \<open>n-1 \<in> {1+j*b| j::nat. j < m}\<close> 
                     using \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> 
                       \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                     by blast
                   then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close> 
                     by blast
                   have \<open>i \<le> m-1\<close> 
                     using \<open>i < m\<close> 
                     by linarith
                   have \<open>1 + (m-1)*b \<in> {1+j*b| j::nat. j < m}\<close> 
                     using \<open>m \<noteq> 0\<close> by auto
                   hence \<open>1 + (m-1)*b \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                     using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                     by blast
                   hence \<open>1 + (m-1)*b < n\<close> 
                     by blast
                   hence \<open>1 + (m-1)*b \<le> n-1\<close> 
                     by linarith
                   hence \<open>1 + (m-1)*b \<le> 1+i*b\<close> 
                     using \<open>n - 1 = 1 + i * b\<close> 
                     by linarith
                   hence \<open>(m-1)*b \<le> i*b\<close> 
                     by linarith
                   hence \<open>m-1 \<le> i\<close> 
                   proof-
                     have \<open>b \<noteq> 0\<close>
                       using \<open>b = 2\<close>
                       by simp
                     thus ?thesis
                       using \<open>(m - 1) * b \<le> i * b\<close> mult_le_cancel2 
                       by blast 
                   qed
                   hence \<open>m-1 = i\<close> 
                     using \<open>i \<le> m - 1\<close> le_antisym 
                     by blast
                   thus ?thesis 
                     using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
                     by (simp add: \<open>b = 2\<close>)
                 qed
                 thus  ?thesis 
                   by (simp add: \<open>m \<noteq> 0\<close> \<open>n = 2 + (m - 1) * 2\<close> mult.commute mult_eq_if)
               qed
               hence \<open>j < m\<close> 
                 using \<open>x < n\<close> \<open>x = 1 + j * 2\<close> 
                 by linarith
               hence \<open>x \<in> {1+j*2| j::nat. j < m}\<close> 
                 using \<open>x = 1 + j * 2\<close> 
                 by blast
               hence \<open>x \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                 using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * 2 |j. j < m}\<close> 
                 by blast
               thus ?thesis 
                 by blast
             qed
             ultimately show ?thesis 
               by blast
           qed
           thus ?thesis 
             using coprime_power2 assms 
             by auto
         qed
         moreover have \<open>b = 4 \<Longrightarrow> n = 6\<close>
         proof-
           assume \<open>b = 4\<close>
           have \<open>n = 2 \<or> n = 6\<close>
           proof(rule classical)
             assume \<open>\<not> (n = 2 \<or> n = 6)\<close>
             have  \<open>(4::nat) \<noteq> 0\<close> 
               by auto
             have \<open>n =  2+(m-1)*4\<close> 
             proof-
               have \<open>n-1 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                 using \<open>1 < n\<close> coprime_diff_one_left_nat 
                 by auto
               have \<open>n-1 \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>n - 1 \<in> {x |x. x < n \<and> coprime x n}\<close> 
                   \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast
               then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close> 
                 by blast
               have \<open>i \<le> m-1\<close> 
                 using \<open>i < m\<close> 
                 by linarith
               have \<open>1 + (m-1)*b \<in> {1+j*b| j::nat. j < m}\<close> 
                 using \<open>m \<noteq> 0\<close> 
                 by auto
               hence \<open>1 + (m-1)*b \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
                 using \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
                 by blast
               hence \<open>1 + (m-1)*b < n\<close> 
                 by blast
               hence \<open>1 + (m-1)*b \<le> n-1\<close> 
                 by linarith
               hence \<open>1 + (m-1)*b \<le> 1+i*b\<close> 
                 using \<open>n - 1 = 1 + i * b\<close> 
                 by linarith
               hence \<open>(m-1)*b \<le> i*b\<close> 
                 by linarith
               hence \<open>m-1 \<le> i\<close> 
               proof-
                 have \<open>b \<noteq> 0\<close>
                   using \<open>b = 4\<close> by auto
                 thus ?thesis
                   using \<open>(m - 1) * b \<le> i * b\<close> mult_le_cancel2 
                   by blast 
               qed
               hence \<open>m-1 = i\<close> 
                 using \<open>i \<le> m - 1\<close> le_antisym 
                 by blast
               thus ?thesis 
                 using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
                 by (simp add: \<open>b = 4\<close>) 
             qed
             hence \<open>n = 4*m - 2\<close> 
               by (simp add: \<open>m \<noteq> 0\<close> mult.commute mult_eq_if)
             have \<open>m \<ge> 3\<close> 
               using \<open>\<not> (n = 2 \<or> n = 6)\<close> \<open>n = 2 + (m - 1) * 4\<close> 
               by auto
             hence \<open> {1+j*4| j::nat. j < 3} \<subseteq> {1+j*4| j::nat. j < m}\<close>
               by force
             hence \<open>9 \<in> {1+j*4| j::nat. j < 3}\<close> 
               by force
             hence \<open>9 \<in> {1+j*4| j::nat. j < m}\<close> 
               using  \<open> {1+j*4| j::nat. j < 3} \<subseteq> {1+j*4| j::nat. j < m}\<close> 
               by blast
             hence \<open>9 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close>
               using \<open>b = 4\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by auto
             hence \<open>coprime (9::nat) n\<close> 
               by blast
             have \<open>(3::nat) dvd 9\<close> 
               by auto
             have  \<open>coprime (3::nat) n\<close> using  \<open>coprime (9::nat) n\<close> \<open>(3::nat) dvd 9\<close>
               by (metis coprime_commute coprime_mult_right_iff dvd_def)
             have \<open>(3::nat) < n\<close> 
               by (metis One_nat_def Suc_lessI \<open>1 < n\<close> \<open>\<not> (n = 2 \<or> n = 6)\<close> \<open>coprime 3 n\<close>
                   coprime_self numeral_2_eq_2 numeral_3_eq_3 less_numeral_extra(1) nat_dvd_not_less)
             have \<open>3 \<in>  {x | x :: nat. x < n \<and> coprime x n}\<close> 
               using \<open>3 < n\<close> \<open>coprime 3 n\<close> 
               by blast
             hence  \<open>(3::nat) \<in> {1+j*4| j::nat. j < m}\<close>
               using \<open>b = 4\<close> \<open>{x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}\<close> 
               by blast
             then obtain j::nat where \<open>(3::nat) = 1 + j*4\<close> 
               by blast  
             have \<open>2 = j*4\<close> 
               using numeral_3_eq_3 \<open>(3::nat) = 1 + j*4\<close>
               by linarith
             hence \<open>1 = j*2\<close> 
               by linarith
             hence \<open>even 1\<close> 
               by simp
             thus ?thesis 
               using odd_one 
               by blast
           qed
           thus ?thesis
             by (simp add: False)            
         qed
         ultimately show ?thesis 
           by blast
       qed
     qed
   qed
   moreover have \<open>(\<exists> b m. m \<noteq> 0 \<and> {x | x :: nat. x < n \<and> coprime x n} = {1+j*b| j::nat. j < m})
   \<longleftrightarrow> (\<exists> a b m. m \<noteq> 0 \<and> {x | x :: nat. x < n \<and> coprime x n} = {a+j*b| j::nat. j < m})\<close>
   proof
     show "\<exists>a b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}"
       if "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
       using that
       by blast 
     show "\<exists>b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {1 + j * b |j. j < m}"
       if "\<exists>a b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}"
     proof-
       obtain a b m::nat where \<open>m \<noteq> 0\<close>
         and \<open>{x | x :: nat. x < n \<and> coprime x n} = {a+j*b| j::nat. j < m}\<close>
         using \<open>\<exists>a b m. m \<noteq> 0 \<and> {x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}\<close> 
         by auto        
       have \<open>a = 1\<close> 
       proof-
         have \<open>{x | x :: nat. x < n \<and> coprime x n} = {(a::nat)+j*(b::nat)| j::nat. j < m} \<Longrightarrow> a = 1\<close>
         proof-
           have \<open>Min {x | x :: nat. x < n \<and> coprime x n} = Min {a+j*b| j::nat. j < m}\<close>
             using \<open>{x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}\<close> 
             by auto            
           have  \<open>Min {x | x :: nat. x < n \<and> coprime x n} = 1\<close>
           proof-
             have \<open>finite {x | x :: nat. x < n \<and> coprime x n}\<close>
               by auto
             have \<open>{x | x :: nat. x < n \<and> coprime x n} \<noteq> {}\<close> 
               using \<open>1 < n\<close> by auto
             have \<open>1 \<in> {x | x :: nat. x < n \<and> coprime x n}\<close> 
               using \<open>1 < n\<close> 
               by auto
             have \<open>\<forall> x. coprime x n \<longrightarrow> x \<ge> 1\<close> 
               using \<open>1 < n\<close> le_less_linear 
               by fastforce
             hence \<open>\<forall> x.  x < n \<and> coprime x n \<longrightarrow> x \<ge> 1\<close> 
               by blast
             hence \<open>\<forall> x \<in> {x | x :: nat. x < n \<and> coprime x n}. x \<ge> 1\<close> 
               by blast
             hence \<open>Min {x | x :: nat. x < n \<and> coprime x n} \<ge> 1\<close> 
               using \<open>finite {x | x :: nat. x < n \<and> coprime x n}\<close> \<open>{x |x. x < n \<and> coprime x n} \<noteq> {}\<close>
               by auto
             thus ?thesis 
               using Min_le \<open>1 \<in> {x |x. x < n \<and> coprime x n}\<close> \<open>finite {x |x. x < n \<and> coprime x n}\<close>
                 antisym by blast
           qed
           have \<open>Min  {a+j*b| j::nat. j < m} = a\<close>
           proof -
             have f1: "\<exists>n. a = a + n * b \<and> n < m"
               using \<open>m \<noteq> 0\<close> 
               by auto
             have f2: "\<exists>n. 1 = a + n * b \<and> n < m"
               using \<open>{x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}\<close> assms coprime_1_left 
               by blast
             have f3: "\<exists>na. a = na \<and> na < n \<and> coprime na n"
               using f1 \<open>{x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}\<close> by blast
             have "n \<noteq> 1"
               by (metis (lifting) assms less_irrefl_nat)
             then have "\<not> coprime 0 n"
               by simp
             then show ?thesis
               using f3 f2 by (metis \<open>Min {x |x. x < n \<and> coprime x n} = 1\<close> \<open>{x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}\<close> less_one linorder_neqE_nat not_add_less1)
           qed
           hence \<open>Min  {a+j*b| j::nat. j < m} = a\<close> by blast
           thus ?thesis 
             using \<open>Min {x | x :: nat. x < n \<and> coprime x n} = 1\<close> \<open>Min {x | x :: nat. x < n \<and> coprime x n} = Min {a+j*b| j::nat. j < m}\<close>
             by linarith
         qed
         thus ?thesis
           using \<open>{x |x. x < n \<and> coprime x n} = {a + j * b |j. j < m}\<close> 
           by blast 
       qed
       thus ?thesis using  \<open>m \<noteq> 0\<close> \<open>{x | x. x < n \<and> coprime x n} = {a+j*b| j::nat. j < m}\<close> 
         by auto
     qed
   qed 
   ultimately show ?thesis
     by simp 
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Arith_Prog_Rel_Primes/ROOT b/thys/Arith_Prog_Rel_Primes/ROOT
--- a/thys/Arith_Prog_Rel_Primes/ROOT
+++ b/thys/Arith_Prog_Rel_Primes/ROOT
@@ -1,10 +1,9 @@
 chapter AFP
 
- 
 session Arith_Prog_Rel_Primes = "HOL-Number_Theory" +
   options [timeout = 300]
   theories
     Arith_Prog_Rel_Primes
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Auto2_HOL/HOL/Arith_Thms.thy b/thys/Auto2_HOL/HOL/Arith_Thms.thy
--- a/thys/Auto2_HOL/HOL/Arith_Thms.thy
+++ b/thys/Auto2_HOL/HOL/Arith_Thms.thy
@@ -1,252 +1,252 @@
 (*
   File: Arith_Thms.thy
   Author: Bohua Zhan
 
   Setup for proof steps related to arithmetic, mostly on natural numbers.
 *)
 
 section \<open>Setup for arithmetic\<close>
 
 theory Arith_Thms
   imports Order_Thms HOL.Binomial
 begin
 
 (* Reducing inequality on natural numbers. *)
 theorem reduce_le_plus_consts: "(x::nat) + n1 \<le> y + n2 \<Longrightarrow> x \<le> y + (n2-n1)" by simp
 theorem reduce_le_plus_consts': "n1 \<ge> n2 \<Longrightarrow> (x::nat) + n1 \<le> y + n2 \<Longrightarrow> x + (n1-n2) \<le> y" by simp
 theorem reduce_less_plus_consts: "(x::nat) + n1 < y + n2 \<Longrightarrow> x < y + (n2-n1)" by simp
 theorem reduce_less_plus_consts': "n1 \<ge> n2 \<Longrightarrow> (x::nat) + n1 < y + n2 \<Longrightarrow> x + (n1-n2) < y" by simp
 
 (* To normal form. *)
 theorem norm_less_lminus: "(x::nat) - n < y \<Longrightarrow> x \<le> y + (n-1)" by simp
 theorem norm_less_lplus:  "(x::nat) + n < y \<Longrightarrow> x + (n+1) \<le> y" by simp
 theorem norm_less_rminus: "(x::nat) < y - n \<Longrightarrow> x + (n+1) \<le> y" by simp
 theorem norm_less_rplus:  "(x::nat) < y + n \<Longrightarrow> x \<le> y + (n-1)" by simp
 theorem norm_less:        "(x::nat) < y     \<Longrightarrow> x + 1 \<le> y"     by simp
 theorem norm_le_lminus: "(x::nat) - n \<le> y \<Longrightarrow> x \<le> y + n"  by simp
 theorem norm_le_rminus: "(x::nat) \<le> y - n \<Longrightarrow> x \<le> y + 0"  by simp
 theorem norm_le: "(x::nat) \<le> y \<Longrightarrow> x \<le> y + 0" by simp
 theorem norm_le_lplus0: "(x::nat) + 0 \<le> y \<Longrightarrow> x \<le> y + 0" by simp
 
 (* Transitive resolve. *)
 theorem trans_resolve1: "n1 > 0 \<Longrightarrow> (x::nat) + n1 \<le> y \<Longrightarrow> (y::nat) + n2 \<le> x \<Longrightarrow> False" by simp
 theorem trans_resolve2: "n1 > n2 \<Longrightarrow> (x::nat) + n1 \<le> y \<Longrightarrow> (y::nat) \<le> x + n2 \<Longrightarrow> False" by simp
 
 (* Transitive. *)
 theorem trans1: "(x::nat) + n1 \<le> y \<Longrightarrow> y + n2 \<le> z \<Longrightarrow> x + (n1+n2) \<le> z" by simp
 theorem trans2: "(x::nat) \<le> y + n1 \<Longrightarrow> y \<le> z + n2 \<Longrightarrow> x \<le> z + (n1+n2)" by simp
 theorem trans3: "(x::nat) + n1 \<le> y \<Longrightarrow> y \<le> z + n2 \<Longrightarrow> x \<le> z + (n2-n1)" by simp
 theorem trans4: "n1 > n2 \<Longrightarrow> (x::nat) + n1 \<le> y \<Longrightarrow> y \<le> z + n2 \<Longrightarrow> x + (n1-n2) \<le> z" by simp
 theorem trans5: "(x::nat) \<le> y + n1 \<Longrightarrow> y + n2 \<le> z \<Longrightarrow> x \<le> z + (n1-n2)" by simp
 theorem trans6: "n2 > n1 \<Longrightarrow> (x::nat) \<le> y + n1 \<Longrightarrow> y + n2 \<le> z \<Longrightarrow> x + (n2-n1) \<le> z" by simp
 
 (* Resolve. *)
 theorem single_resolve: "n > 0 \<Longrightarrow> (x::nat) + n \<le> x \<Longrightarrow> False" by simp
 theorem single_resolve_const: "n > 0 \<Longrightarrow> (x::nat) + n \<le> 0 \<Longrightarrow> False" by simp
 
 (* Comparison with constants. *)
 theorem cv_const1: "(x::nat) + n \<le> y \<Longrightarrow> 0 + (x+n) \<le> y" by simp  (* x is const *)
 theorem cv_const2: "(x::nat) + n \<le> y \<Longrightarrow> x \<le> 0 + (y-n)" by simp  (* y is const *)
 theorem cv_const3: "y < n \<Longrightarrow> (x::nat) + n \<le> y \<Longrightarrow> x + (n-y) \<le> 0" by simp  (* y is const (contradiction with 0 \<le> x) *)
 theorem cv_const4: "(x::nat) \<le> y + n \<Longrightarrow> 0 + (x-n) \<le> y" by simp  (* x is const *)
 theorem cv_const5: "(x::nat) \<le> y + n \<Longrightarrow> 0 \<le> y + (n-x)" by simp  (* x is const (trivial) *)
 theorem cv_const6: "(x::nat) \<le> y + n \<Longrightarrow> x \<le> 0 + (y+n)" by simp  (* y is const *)
 
 (* Misc *)
 theorem nat_eq_to_ineqs: "(x::nat) = y + n \<Longrightarrow> x \<le> y + n \<and> x \<ge> y + n" by simp
 theorem nat_ineq_impl_not_eq: "(x::nat) + n \<le> y \<Longrightarrow> n > 0 \<Longrightarrow> x \<noteq> y" by simp
 theorem eq_to_ineqs: "(x::nat) \<equiv> y \<Longrightarrow> x \<le> y \<and> y \<le> x" by simp
 theorem ineq_to_eqs1: "(x::nat) \<le> y + 0 \<Longrightarrow> y \<le> x + 0 \<Longrightarrow> x = y" by simp
 
 ML_file \<open>arith.ML\<close>
 ML_file \<open>order.ML\<close>
 ML_file \<open>order_test.ML\<close>
 
 setup \<open>register_wellform_data ("(a::nat) - b", ["a \<ge> b"])\<close>
 setup \<open>add_prfstep_check_req ("(a::nat) - b", "(a::nat) \<ge> b")\<close>
 
 (* Normalize any expression to "a - b" form. *)
 lemma nat_sub_norm:
   "(a::nat) = a - 0 \<and> a \<ge> 0" by simp
 
 (* Adding and subtracting two normalized expressions. *)
 lemma nat_sub1:
   "(a::nat) \<ge> b \<Longrightarrow> c \<ge> d \<Longrightarrow> (a - b) + (c - d) = (a + c) - (b + d) \<and> a + c \<ge> b + d" by simp
 
 lemma nat_sub2:
   "(a::nat) \<ge> b \<Longrightarrow> c \<ge> d \<Longrightarrow> a - b \<ge> c - d \<Longrightarrow> (a - b) - (c - d) = (a + d) - (b + c) \<and> a + d \<ge> b + c" by simp
 
 lemma nat_sub3:
   "(a::nat) \<ge> b \<Longrightarrow> c \<ge> d \<Longrightarrow> (a - b) * (c - d) = (a * c + b * d) - (a * d + b * c) \<and> a * c + b * d \<ge> a * d + b * c"
-  by (smt diff_mult_distrib mult.commute mult_le_mono1 nat_sub2)
+  by (smt (verit) diff_mult_distrib mult.commute mult_le_mono1 nat_sub2)
 
 (* Cancel identical terms on two sides, yielding a normalized expression. *)
 lemma nat_sub_combine:
   "(a::nat) + b \<ge> c + b \<Longrightarrow> (a + b) - (c + b) = a - c \<and> a \<ge> c" by simp
 
 lemma nat_sub_combine2:
   "n \<ge> m \<Longrightarrow> (a::nat) + b * n \<ge> c + b * m \<Longrightarrow> (a + b * n) - (c + b * m) = (a + b * (n - m)) - c \<and> a + b * (n - m) \<ge> c \<and> n \<ge> m"
   by (simp add: add.commute right_diff_distrib')
 
 lemma nat_sub_combine3:
   "n \<le> m \<Longrightarrow> (a::nat) + b * n \<ge> c + b * m \<Longrightarrow> (a + b * n) - (c + b * m) = a - (c + b * (m - n)) \<and> a \<ge> c + b * (m - n) \<and> m \<ge> n"
-  by (smt add.commute mult.commute nat_diff_add_eq2 nat_le_add_iff1)
+  by (smt (verit) add.commute mult.commute nat_diff_add_eq2 nat_le_add_iff1)
 
 ML_file \<open>nat_sub.ML\<close>
 ML_file \<open>nat_sub_test.ML\<close>
 
 (* Ordering on Nats. *)
 lemma le_neq_implies_less' [forward]: "(m::nat) \<noteq> n \<Longrightarrow> m \<le> n \<Longrightarrow> m < n" by simp
 lemma le_zero_to_equal_zero [forward]: "(n::nat) \<le> 0 \<Longrightarrow> n = 0" by simp
 lemma less_one_to_equal_zero [forward]: "(n::nat) < 1 \<Longrightarrow> n = 0" by simp
 setup \<open>add_backward_prfstep_cond @{thm Nat.mult_le_mono1} [with_cond "?k \<noteq> 1"]\<close>
 setup \<open>add_resolve_prfstep @{thm Nat.not_add_less1}\<close>
 lemma not_minus_less [resolve]: "\<not>(i::nat) < (i - j)" by simp
 lemma nat_le_prod_with_same [backward]: "m \<noteq> 0 \<Longrightarrow> (n::nat) \<le> m * n" by simp
 lemma nat_le_prod_with_le [backward1]: "k \<noteq> 0 \<Longrightarrow> (n::nat) \<le> m \<Longrightarrow> (n::nat) \<le> k * m"
   using le_trans nat_le_prod_with_same by blast
 lemma nat_plus_le_to_less [backward1]: "b \<noteq> 0 \<Longrightarrow> (a::nat) + b \<le> c \<Longrightarrow> a < c" by simp
 lemma nat_plus_le_to_less2 [backward1]: "a \<noteq> 0 \<Longrightarrow> (a::nat) + b \<le> c \<Longrightarrow> b < c" by simp
 setup \<open>add_forward_prfstep @{thm add_right_imp_eq}\<close>
 setup \<open>add_forward_prfstep @{thm add_left_imp_eq}\<close>
 
 setup \<open>add_rewrite_rule_cond @{thm Nat.le_diff_conv2} [with_term "?i + ?k"]\<close>
 lemma nat_less_diff_conv: "(i::nat) < j - k \<Longrightarrow> i + k < j" by simp
 setup \<open>add_forward_prfstep_cond @{thm nat_less_diff_conv} [with_cond "?k \<noteq> ?NUMC", with_term "?i + ?k"]\<close>
 lemma Nat_le_diff_conv2_same [forward]: "i \<ge> j \<Longrightarrow> (i::nat) \<le> i - j \<Longrightarrow> j = 0" by simp
 lemma nat_gt_zero [forward]: "b - a > 0 \<Longrightarrow> b > (a::nat)" by simp
 lemma n_minus_1_less_n: "(n::nat) \<ge> 1 \<Longrightarrow> n - 1 < n" by simp
 setup \<open>add_forward_prfstep_cond @{thm n_minus_1_less_n} [with_term "?n - 1"]\<close>
 
 (* Monotonicity of ordering *)
 setup \<open>add_backward_prfstep @{thm Nat.diff_le_mono}\<close>
 setup \<open>add_backward2_prfstep @{thm Nat.diff_less_mono}\<close>
 setup \<open>add_backward_prfstep @{thm Nat.mult_le_mono2}\<close>
 setup \<open>add_resolve_prfstep @{thm Nat.le_add1}\<close>
 setup \<open>add_resolve_prfstep @{thm Nat.le_add2}\<close>
 setup \<open>add_backward_prfstep @{thm add_left_mono}\<close>
 setup \<open>add_backward_prfstep @{thm add_right_mono}\<close>
 lemma add_mono_neutr [backward]: "(0::'a::linordered_ring) \<le> b \<Longrightarrow> a \<le> a + b" by simp
 lemma add_mono_neutl [backward]: "(0::'a::linordered_ring) \<le> b \<Longrightarrow> a \<le> b + a" by simp
 setup \<open>add_forward_prfstep @{thm add_less_imp_less_left}\<close>
 lemma sum_le_zero1 [forward]: "(a::'a::linordered_ring) + b < 0 \<Longrightarrow> a \<ge> 0 \<Longrightarrow> b < 0" by (meson add_less_same_cancel1 less_le_trans)
 lemma less_sum1 [backward]: "b > 0 \<Longrightarrow> a < a + (b::nat)" by auto
 setup \<open>add_backward_prfstep @{thm Nat.trans_less_add2}\<close>
 setup \<open>add_backward_prfstep @{thm Nat.add_less_mono1}\<close>
 setup \<open>add_backward1_prfstep @{thm Nat.add_less_mono}\<close>
 setup \<open>add_backward1_prfstep @{thm Nat.add_le_mono}\<close>
 setup \<open>add_backward1_prfstep @{thm add_increasing2}\<close>
 setup \<open>add_backward1_prfstep @{thm add_mono}\<close>
 setup \<open>add_backward_prfstep @{thm add_strict_left_mono}\<close>
 setup \<open>add_backward1_prfstep @{thm Nat.mult_le_mono}\<close>
 
 (* Addition. *)
 theorem nat_add_eq_self_zero [forward]: "(m::nat) = m + n \<Longrightarrow> n = 0" by simp
 theorem nat_add_eq_self_zero' [forward]: "(m::nat) = n + m \<Longrightarrow> n = 0" by simp
 theorem nat_mult_2: "(a::nat) + a = 2 * a" by simp
 setup \<open>add_rewrite_rule_cond @{thm nat_mult_2} [with_cond "?a \<noteq> 0"]\<close>
 theorem plus_one_non_zero [resolve]: "\<not>(n::nat) + 1 = 0" by simp
 
 (* Diff. *)
 lemma nat_same_minus_ge [forward]: "(c::nat) - a \<ge> c - b \<Longrightarrow> a \<le> c \<Longrightarrow> a \<le> b" by arith
 lemma diff_eq_zero [forward]: "(k::nat) \<le> j \<Longrightarrow> j - k = 0 \<Longrightarrow> j = k" by simp
 lemma diff_eq_zero' [forward]: "(k::nat) \<le> j \<Longrightarrow> j - k + i = j \<Longrightarrow> k = i" by simp
 
 (* Divides. *)
 theorem dvd_defD1 [resolve]: "(a::nat) dvd b \<Longrightarrow> \<exists>k. b = a * k" using dvdE by blast
 theorem dvd_defD2 [resolve]: "(a::nat) dvd b \<Longrightarrow> \<exists>k. b = k * a" by (metis dvd_mult_div_cancel mult.commute)
 setup \<open>add_forward_prfstep @{thm Nat.dvd_imp_le}\<close>
 theorem dvd_ineq2 [forward]: "(k::nat) dvd n \<Longrightarrow> n > 0 \<Longrightarrow> k \<ge> 1" by (simp add: Suc_leI dvd_pos_nat)
 
 setup \<open>add_forward_prfstep_cond @{thm dvd_trans} (with_conds ["?a \<noteq> ?b", "?b \<noteq> ?c", "?a \<noteq> ?c"])\<close>
 setup \<open>add_forward_prfstep_cond @{thm Nat.dvd_antisym} [with_cond "?m \<noteq> ?n"]\<close>
 theorem dvd_cancel [backward1]: "c > 0 \<Longrightarrow> (a::nat) * c dvd b * c \<Longrightarrow> a dvd b" by simp
 setup \<open>add_forward_prfstep (equiv_forward_th @{thm dvd_add_right_iff})\<close>
 
 (* Divisibility: existence. *)
 setup \<open>add_resolve_prfstep @{thm dvd_refl}\<close>
 theorem exists_n_dvd_n [backward]: "P (n::nat) \<Longrightarrow> \<exists>k. k dvd n \<and> P k" using dvd_refl by blast
 setup \<open>add_resolve_prfstep @{thm one_dvd}\<close>
 
 theorem any_n_dvd_0 [forward]: "\<not> (\<exists> k. k dvd (0::nat) \<and> P k) \<Longrightarrow> \<not> (\<exists> k. P k)" by simp
 
 theorem n_dvd_one: "(n::nat) dvd 1 \<Longrightarrow> n = 1" by simp
 setup \<open>add_forward_prfstep_cond @{thm n_dvd_one} [with_cond "?n \<noteq> 1"]\<close>
 
 (* Products. *)
 setup \<open>add_rewrite_rule @{thm mult_zero_left}\<close>
 lemma prod_ineqs1 [forward]: "(m::nat) * k > 0 \<Longrightarrow> m > 0 \<and> k > 0" by simp
 lemma prod_ineqs2 [backward]: "(k::nat) > 0 \<Longrightarrow> m \<le> m * k" by simp
 
 theorem prod_cancel: "(a::nat) * b = a * c \<Longrightarrow> a > 0 \<Longrightarrow> b = c" by auto
 setup \<open>add_forward_prfstep_cond @{thm prod_cancel} [with_cond "?b \<noteq> ?c"]\<close>
 
 theorem mult_n1n: "(n::nat) = m * n \<Longrightarrow> n > 0 \<Longrightarrow> m = 1" by auto
 setup \<open>add_forward_prfstep_cond @{thm mult_n1n} [with_cond "?m \<noteq> 1"]\<close>
 
 theorem prod_is_one [forward]: "(x::nat) * y = 1 \<Longrightarrow> x = 1" by simp
 
 theorem prod_dvd_intro [backward]: "(k::nat) dvd m \<or> k dvd n \<Longrightarrow> k dvd m * n"
   using dvd_mult dvd_mult2 by blast
 
 (* Definition of gcd. *)
 setup \<open>add_forward_prfstep_cond @{thm gcd_dvd1} [with_term "gcd ?a ?b"]\<close>
 setup \<open>add_forward_prfstep_cond @{thm gcd_dvd2} [with_term "gcd ?a ?b"]\<close>
 
 (* Coprimality. *)
 setup \<open>add_rewrite_rule_bidir @{thm coprime_iff_gcd_eq_1}\<close>
 lemma coprime_exp [backward]: "coprime d a \<Longrightarrow> coprime (d::nat) (a ^ n)" by simp
 setup \<open>add_backward_prfstep @{thm coprime_exp}\<close>
 setup \<open>add_rewrite_rule @{thm gcd.commute}\<close>
 lemma coprime_dvd_mult [backward1]: "coprime (a::nat) b \<Longrightarrow> a dvd c * b \<Longrightarrow> a dvd c"
   by (metis coprime_dvd_mult_left_iff)
 lemma coprime_dvd_mult' [backward1]: "coprime (a::nat) b \<Longrightarrow> a dvd b * c \<Longrightarrow> a dvd c"
   by (metis coprime_dvd_mult_right_iff)
 
 theorem coprime_dvd [forward]:
   "coprime (a::nat) b \<Longrightarrow> p dvd a \<Longrightarrow> p > 1 \<Longrightarrow> \<not> p dvd b"
   using coprime_common_divisor_nat by blast
 
 (* Powers. *)
 setup \<open>add_rewrite_rule @{thm power_0}\<close>
 theorem power_ge_0 [rewrite]: "m \<noteq> 0 \<Longrightarrow> p ^ m = p * (p ^ (m - 1))" by (simp add: power_eq_if)
 setup \<open>add_rewrite_rule_cond @{thm power_one} [with_cond "?n \<noteq> 0"]\<close>
 setup \<open>add_rewrite_rule_cond @{thm power_one_right} [with_cond "?a \<noteq> 1"]\<close>
 setup \<open>add_gen_prfstep ("power_case_intro",
   [WithTerm @{term_pat "?p ^ (?FREE::nat)"}, CreateCase @{term_pat "(?FREE::nat) = 0"}])\<close>
 
 lemma one_is_power_of_any [resolve]: "\<exists>i. (1::nat) = a ^ i" by (metis power.simps(1))
 
 setup \<open>add_rewrite_rule @{thm power_Suc}\<close>
 
 theorem power_dvd [forward]: "(p::nat)^n dvd a \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> p dvd a" using dvd_power dvd_trans by blast
 
 theorem power_eq_one: "(b::nat) ^ n = 1 \<Longrightarrow> b = 1 \<or> n = 0"
   by (metis One_nat_def Suc_lessI nat_zero_less_power_iff power_0 power_inject_exp)
 setup \<open>add_forward_prfstep_cond @{thm power_eq_one} (with_conds ["?b \<noteq> 1", "?n \<noteq> 0"])\<close>
 
 (* Factorial. *)
 theorem fact_ge_1_nat: "fact (n::nat) \<ge> (1::nat)" by simp
 setup \<open>add_forward_prfstep_cond @{thm fact_ge_1_nat} [with_term "fact ?n"]\<close>
 setup \<open>add_backward1_prfstep @{thm dvd_fact}\<close>
 
 (* Successor function. *)
 setup \<open>add_rewrite_rule @{thm Nat.Suc_eq_plus1}\<close>
 setup \<open>add_backward_prfstep @{thm Nat.gr0_implies_Suc}\<close>
 
 (* Cases *)
 setup \<open>fold add_rewrite_rule @{thms Nat.nat.case}\<close>
 
 (* Induction. *)
 lemma nat_cases: "P 0 \<Longrightarrow> (\<And>n. P (Suc n)) \<Longrightarrow> P n" using nat_induct by auto
 
 (* div *)
 declare times_div_less_eq_dividend [resolve]
 
 setup \<open>
   add_var_induct_rule @{thm nat_induct} #>
   add_strong_induct_rule @{thm nat_less_induct} #>
   add_cases_rule @{thm nat_cases}
 \<close>
 
 end
diff --git a/thys/Banach_Steinhaus/Banach_Steinhaus.thy b/thys/Banach_Steinhaus/Banach_Steinhaus.thy
--- a/thys/Banach_Steinhaus/Banach_Steinhaus.thy
+++ b/thys/Banach_Steinhaus/Banach_Steinhaus.thy
@@ -1,481 +1,482 @@
 (*
   File:   Banach_Steinhaus.thy
   Author: Dominique Unruh, University of Tartu
   Author: Jose Manuel Rodriguez Caballero, University of Tartu
 *)
 section \<open>Banach-Steinhaus theorem\<close>
 
 theory Banach_Steinhaus
   imports Banach_Steinhaus_Missing
 begin
 
 text \<open>
   We formalize Banach-Steinhaus theorem as theorem @{text banach_steinhaus}. This theorem was 
   originally proved in Banach-Steinhaus's paper~\<^cite>\<open>"banach1927principe"\<close>. For the proof, we follow
   Sokal's approach~\<^cite>\<open>"sokal2011really"\<close>. Furthermore, we prove as a corollary a result about
   pointwise convergent sequences of bounded operators whose domain is a Banach space.
 \<close>
 
 subsection \<open>Preliminaries for Sokal's proof of Banach-Steinhaus theorem\<close>
 
 lemma linear_plus_norm:
   includes notation_norm
   assumes \<open>linear f\<close>
   shows \<open>\<parallel>f \<xi>\<parallel> \<le> max \<parallel>f (x + \<xi>)\<parallel> \<parallel>f (x - \<xi>)\<parallel>\<close>
   text \<open>
   Explanation: For arbitrary \<^term>\<open>x\<close> and a linear operator \<^term>\<open>f\<close>,
   \<^term>\<open>norm (f \<xi>)\<close> is upper bounded by the maximum of the norms
   of the shifts of \<^term>\<open>f\<close> (i.e., \<^term>\<open>f (x + \<xi>)\<close> and \<^term>\<open>f (x - \<xi>)\<close>).
 \<close>
 proof-
   have \<open>norm (f \<xi>) = norm ( (inverse (of_nat 2)) *\<^sub>R (f (x + \<xi>) - f (x - \<xi>)) )\<close>
-    by (smt add_diff_cancel_left' assms diff_add_cancel diff_diff_add linear_diff midpoint_def 
-        midpoint_plus_self of_nat_1 of_nat_add one_add_one scaleR_half_double)
+    by (metis (no_types, opaque_lifting) add.commute assms diff_diff_eq2 group_cancel.sub1
+        linear_cmul linear_diff of_nat_numeral real_vector_affinity_eq scaleR_2
+        scaleR_right_diff_distrib zero_neq_numeral)
   also have \<open>\<dots> = inverse (of_nat 2) * norm (f (x + \<xi>) - f (x - \<xi>))\<close>
     using Real_Vector_Spaces.real_normed_vector_class.norm_scaleR by simp
   also have \<open>\<dots> \<le> inverse (of_nat 2) * (norm (f (x + \<xi>)) + norm (f (x - \<xi>)))\<close>
     by (simp add: norm_triangle_ineq4)
   also have \<open>\<dots> \<le>  max (norm (f (x + \<xi>))) (norm (f (x - \<xi>)))\<close>
     by auto
   finally show ?thesis by blast
 qed
 
 lemma onorm_Sup_on_ball:
   includes notation_norm
   assumes \<open>r > 0\<close>
   shows "\<parallel>f\<parallel> \<le> Sup ( (\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball x r) ) / r"
   text \<open>
   Explanation: Let \<^term>\<open>f\<close> be a bounded operator and let \<^term>\<open>x\<close> be a point. For any \<^term>\<open>r > 0\<close>, 
   the operator norm of \<^term>\<open>f\<close> is bounded above by the supremum of $f$ applied to the open ball of 
   radius \<^term>\<open>r\<close> around \<^term>\<open>x\<close>, divided by \<^term>\<open>r\<close>.
 \<close>
 proof-
   have bdd_above_3: \<open>bdd_above ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r))\<close>
   proof -
     obtain M where \<open>\<And> \<xi>.  \<parallel>f *\<^sub>v \<xi>\<parallel> \<le> M * norm \<xi>\<close> and \<open>M \<ge> 0\<close>
       using norm_blinfun norm_ge_zero by blast      
     hence \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v \<xi>\<parallel> \<le> M * r\<close>
-      using \<open>r > 0\<close> by (smt mem_ball_0 mult_left_mono) 
+      using \<open>r > 0\<close> by (smt (verit) mem_ball_0 mult_left_mono) 
     thus ?thesis by (meson bdd_aboveI2)     
   qed
   have bdd_above_2: \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))\<close>
   proof-
     have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r))\<close>
       by auto          
     moreover have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball 0 r))\<close>
       using bdd_above_3 by blast
     ultimately have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v x\<parallel> + \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball 0 r))\<close>
       by (rule bdd_above_plus)
     then obtain M where \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v x\<parallel> + \<parallel>f *\<^sub>v \<xi>\<parallel> \<le> M\<close>
       unfolding bdd_above_def by (meson image_eqI)
     moreover have \<open>\<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<le> \<parallel>f *\<^sub>v x\<parallel> + \<parallel>f *\<^sub>v \<xi>\<parallel>\<close> for \<xi>
       by (simp add: blinfun.add_right norm_triangle_ineq)                
     ultimately have \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<le> M\<close>
       by (simp add: blinfun.add_right norm_triangle_le)
     thus ?thesis by (meson bdd_aboveI2)                          
   qed 
   have bdd_above_4: \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
   proof-
     obtain K where K_def: \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<le> K\<close>
       using  \<open>bdd_above ((\<lambda> \<xi>. norm (f (x + \<xi>))) ` (ball 0 r))\<close> unfolding bdd_above_def 
       by (meson image_eqI)
     have \<open>\<xi> \<in> ball (0::'a) r \<Longrightarrow> -\<xi> \<in> ball 0 r\<close> for \<xi>
       by auto
     thus ?thesis by (metis K_def ab_group_add_class.ab_diff_conv_add_uminus bdd_aboveI2)
   qed
   have bdd_above_1: \<open>bdd_above ((\<lambda> \<xi>. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
   proof-
     have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))\<close>
       using bdd_above_2 by blast
     moreover have \<open>bdd_above ((\<lambda> \<xi>.  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
       using bdd_above_4 by blast
     ultimately show ?thesis
       unfolding max_def apply auto apply (meson bdd_above_Int1 bdd_above_mono image_Int_subset)
       by (meson bdd_above_Int1 bdd_above_mono image_Int_subset)   
   qed 
   have bdd_above_6: \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r)\<close>
   proof-
     have \<open>bounded (ball x r)\<close>
       by simp            
     hence \<open>bounded ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r)\<close>
       by (metis (no_types) add.left_neutral bdd_above_2 bdd_above_norm bounded_norm_comp 
           image_add_ball image_image)
     thus ?thesis
       by (simp add: bounded_imp_bdd_above)
   qed
   have norm_1: \<open>(\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r = (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r\<close>
     by (metis add.right_neutral ball_translation image_image)   
   have bdd_above_5: \<open>bdd_above ((\<lambda>\<xi>. norm (f (x + \<xi>))) ` ball 0 r)\<close>
     by (simp add: bdd_above_2)   
   have norm_2: \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>
   proof-
     assume \<open>\<parallel>\<xi>\<parallel> < r\<close>
     hence \<open>\<xi> \<in> ball (0::'a) r\<close>
       by auto
     hence \<open>-\<xi> \<in> ball (0::'a) r\<close>
       by auto
     thus ?thesis 
       by (metis (no_types, lifting) ab_group_add_class.ab_diff_conv_add_uminus image_iff) 
   qed
   have norm_2': \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>
   proof-
     assume \<open>norm \<xi> < r\<close>
     hence \<open>\<xi> \<in> ball (0::'a) r\<close>
       by auto
     hence \<open>-\<xi> \<in> ball (0::'a) r\<close>
       by auto
     thus ?thesis 
       by (metis (no_types, lifting) diff_minus_eq_add image_iff)          
   qed
   have bdd_above_6: \<open>bdd_above ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r)\<close>
     by (simp add: bdd_above_4)   
   have Sup_2: \<open>(SUP \<xi>\<in>ball 0 r. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) =
                  max (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>)\<close>
   proof-
     have \<open>ball (0::'a) r \<noteq> {}\<close>
       using \<open>r > 0\<close> by auto
     moreover have \<open>bdd_above ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r)\<close>
       using bdd_above_5 by blast
     moreover have \<open>bdd_above ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r)\<close>
       using bdd_above_6 by blast
     ultimately show ?thesis
       using max_Sup
       by (metis (mono_tags, lifting) Banach_Steinhaus_Missing.pointwise_max_def image_cong) 
   qed 
   have Sup_3': \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>::'a
     by (simp add: norm_2')
   have Sup_3'': \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>::'a
     by (simp add: norm_2)  
   have Sup_3: \<open>max (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) (SUP \<xi>\<in>ball 0 r.  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) =
         (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>)\<close>
   proof-
     have \<open>(\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r) = (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r)\<close>
       apply auto using Sup_3' apply auto using Sup_3'' by blast
     hence \<open>Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))=Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
       by simp
     thus ?thesis by simp
   qed
   have Sup_1: \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) \<le> Sup ( (\<lambda>\<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball x r) )\<close> 
   proof-
     have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) \<xi> \<le> max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>\<close> for \<xi>
       apply(rule linear_plus_norm) apply (rule bounded_linear.linear)
       by (simp add: blinfun.bounded_linear_right)
     moreover have \<open>bdd_above ((\<lambda> \<xi>. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close> 
       using bdd_above_1 by blast
     moreover have \<open>ball (0::'a) r \<noteq> {}\<close>
       using \<open>r > 0\<close> by auto      
     ultimately have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) \<le>
                      Sup ((\<lambda>\<xi>. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
-      using cSUP_mono by smt 
+      using cSUP_mono by (smt (verit)) 
     also have \<open>\<dots> = max (Sup ((\<lambda>\<xi>.  \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r)))
                         (Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r)))\<close> 
       using Sup_2 by blast
     also have \<open>\<dots> = Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))\<close>
       using Sup_3 by blast
     also have \<open>\<dots> = Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball x r))\<close>
       by (metis  add.right_neutral ball_translation image_image)      
     finally show ?thesis by blast
   qed
   have \<open>\<parallel>f\<parallel> = (SUP x\<in>ball 0 r. \<parallel>f *\<^sub>v x\<parallel>) / r\<close>
     using \<open>0 < r\<close> onorm_r by blast
   moreover have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) / r \<le> Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball x r)) / r\<close>
     using Sup_1 \<open>0 < r\<close> divide_right_mono by fastforce 
   ultimately have \<open>\<parallel>f\<parallel> \<le> Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r) / r\<close>
     by simp
   thus ?thesis by simp    
 qed
 
 lemma onorm_Sup_on_ball':
   includes notation_norm
   assumes \<open>r > 0\<close> and \<open>\<tau> < 1\<close>
   shows \<open>\<exists>\<xi>\<in>ball x r.  \<tau> * r * \<parallel>f\<parallel> \<le> \<parallel>f *\<^sub>v \<xi>\<parallel>\<close>
   text \<open>                 
   In the proof of Banach-Steinhaus theorem, we will use this variation of the 
   lemma @{text onorm_Sup_on_ball}.
 
   Explanation: Let \<^term>\<open>f\<close> be a bounded operator, let \<^term>\<open>x\<close> be a point and let \<^term>\<open>r\<close> be a 
   positive real number. For any real number \<^term>\<open>\<tau> < 1\<close>, there is a point \<^term>\<open>\<xi>\<close> in the open ball 
   of radius \<^term>\<open>r\<close> around \<^term>\<open>x\<close> such that \<^term>\<open>\<tau> * r * \<parallel>f\<parallel> \<le> \<parallel>f *\<^sub>v \<xi>\<parallel>\<close>.
 \<close>
 proof(cases  \<open>f = 0\<close>)
   case True
   thus ?thesis by (metis assms(1) centre_in_ball mult_zero_right norm_zero order_refl 
         zero_blinfun.rep_eq) 
 next
   case False
   have bdd_above_1: \<open>bdd_above ((\<lambda>t. \<parallel>(*\<^sub>v) f t\<parallel>) ` ball x r)\<close> for f::\<open>'a \<Rightarrow>\<^sub>L 'b\<close>
     using assms(1) bounded_linear_image by (simp add: bounded_linear_image 
         blinfun.bounded_linear_right bounded_imp_bdd_above bounded_norm_comp) 
   have  \<open>norm f > 0\<close>
     using \<open>f \<noteq> 0\<close> by auto
   have \<open>norm f \<le>  Sup ( (\<lambda>\<xi>.  \<parallel>(*\<^sub>v) f \<xi>\<parallel>) ` (ball x r) ) / r\<close>
     using \<open>r > 0\<close> by (simp add: onorm_Sup_on_ball)  
   hence \<open>r * norm f \<le>  Sup ( (\<lambda>\<xi>.  \<parallel>(*\<^sub>v) f \<xi>\<parallel>) ` (ball x r) )\<close>
-    using \<open>0 < r\<close> by (smt divide_strict_right_mono nonzero_mult_div_cancel_left) 
+    using \<open>0 < r\<close> by (smt (verit) divide_strict_right_mono nonzero_mult_div_cancel_left) 
   moreover have \<open>\<tau> * r * norm f < r * norm f\<close>
     using  \<open>\<tau> < 1\<close> using \<open>0 < norm f\<close> \<open>0 < r\<close> by auto
   ultimately have \<open>\<tau> * r * norm f < Sup ( (norm \<circ> ((*\<^sub>v) f)) ` (ball x r) )\<close>
     by simp
   moreover have \<open>(norm \<circ> ( (*\<^sub>v) f)) ` (ball x r) \<noteq> {}\<close>
     using \<open>0 < r\<close> by auto    
   moreover have \<open>bdd_above ((norm \<circ> ( (*\<^sub>v) f)) ` (ball x r))\<close>
     using bdd_above_1 apply transfer by simp
   ultimately have \<open>\<exists>t \<in> (norm \<circ> ( (*\<^sub>v) f)) ` (ball x r). \<tau> * r * norm f < t\<close> 
     by (simp add: less_cSup_iff)    
-  thus ?thesis by (smt comp_def image_iff) 
+  thus ?thesis by (smt (verit) comp_def image_iff) 
 qed
 
 subsection \<open>Banach-Steinhaus theorem\<close>
 
 theorem banach_steinhaus:
   fixes f::\<open>'c \<Rightarrow> ('a::banach \<Rightarrow>\<^sub>L 'b::real_normed_vector)\<close>
   assumes \<open>\<And>x. bounded (range (\<lambda>n. (f n) *\<^sub>v x))\<close>
   shows  \<open>bounded (range f)\<close>
   text\<open>
   This is Banach-Steinhaus Theorem.
 
   Explanation: If a family of bounded operators on a Banach space
   is pointwise bounded, then it is uniformly bounded.
 \<close>
 proof(rule classical)
   assume \<open>\<not>(bounded (range f))\<close>
   have sum_1: \<open>\<exists>K. \<forall>n. sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> K\<close>
   proof-
     have \<open>summable (\<lambda>n. inverse ((3::real) ^ n))\<close>
       by (simp flip: power_inverse)
     hence \<open>bounded (range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n}))\<close>
       using summable_imp_sums_bounded[where f = "(\<lambda>n. inverse (real_of_nat 3^n))"]
         lessThan_atLeast0 by auto
     hence \<open>\<exists>M. \<forall>h\<in>(range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n})). norm h \<le> M\<close>
       using bounded_iff by blast
     then obtain M where \<open>h\<in>range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n}) \<Longrightarrow> norm h \<le> M\<close> 
       for h
       by blast      
     have sum_2: \<open>sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> M\<close> for n
     proof-
       have  \<open>norm (sum (\<lambda> k. inverse (real 3 ^ k)) {0..< Suc n}) \<le> M\<close>
         using \<open>\<And>h. h\<in>(range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n})) \<Longrightarrow> norm h \<le> M\<close> 
         by blast
       hence  \<open>norm (sum (\<lambda> k. inverse (real 3 ^ k)) {0..n}) \<le> M\<close>
         by (simp add: atLeastLessThanSuc_atLeastAtMost)        
       hence  \<open>(sum (\<lambda> k. inverse (real 3 ^ k)) {0..n}) \<le> M\<close>
         by auto
       thus ?thesis  by blast
     qed
     have \<open>sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> M\<close> for n 
       using sum_2 by blast
     thus ?thesis  by blast
   qed
   have \<open>of_rat 2/3 < (1::real)\<close>
     by auto
   hence \<open>\<forall>g::'a \<Rightarrow>\<^sub>L 'b. \<forall>x. \<forall>r. \<exists>\<xi>. g \<noteq> 0 \<and> r > 0
                \<longrightarrow> (\<xi>\<in>ball x r \<and> (of_rat 2/3) * r * norm g \<le> norm ((*\<^sub>v) g \<xi>))\<close> 
     using onorm_Sup_on_ball' by blast
   hence \<open>\<exists>\<xi>. \<forall>g::'a \<Rightarrow>\<^sub>L 'b. \<forall>x. \<forall>r. g \<noteq> 0 \<and> r > 0
            \<longrightarrow> ((\<xi> g x r)\<in>ball x r \<and> (of_rat 2/3) * r * norm g \<le> norm ((*\<^sub>v) g (\<xi> g x r)))\<close> 
     by metis
   then obtain \<xi> where f1: \<open>\<lbrakk>g \<noteq> 0; r > 0\<rbrakk> \<Longrightarrow> 
         \<xi> g x r \<in> ball x r \<and>  (of_rat 2/3) * r * norm g \<le> norm ((*\<^sub>v) g (\<xi> g x r))\<close>
     for g::\<open>'a \<Rightarrow>\<^sub>L 'b\<close> and x and r
     by blast
   have \<open>\<forall>n. \<exists>k. norm (f k) \<ge> 4^n\<close>
     using \<open>\<not>(bounded (range f))\<close> by (metis (mono_tags, opaque_lifting) boundedI image_iff linear)
   hence  \<open>\<exists>k. \<forall>n. norm (f (k n)) \<ge> 4^n\<close>
     by metis
   hence  \<open>\<exists>k. \<forall>n. norm ((f \<circ> k) n) \<ge> 4^n\<close>
     by simp
   then obtain k where \<open>norm ((f \<circ> k) n) \<ge> 4^n\<close> for n
     by blast
   define T where \<open>T = f \<circ> k\<close>
   have \<open>T n \<in> range f\<close> for n
     unfolding T_def by simp        
   have \<open>norm (T n) \<ge> of_nat (4^n)\<close> for n
     unfolding T_def using \<open>\<And> n. norm ((f \<circ> k) n) \<ge> 4^n\<close> by auto
   hence \<open>T n \<noteq> 0\<close> for n
-    by (smt T_def \<open>\<And>n. 4 ^ n \<le> norm ((f \<circ> k) n)\<close> norm_zero power_not_zero zero_le_power)
+    by (smt (verit) T_def \<open>\<And>n. 4 ^ n \<le> norm ((f \<circ> k) n)\<close> norm_zero power_not_zero zero_le_power)
   have \<open>inverse (of_nat 3^n) > (0::real)\<close> for n
     by auto
   define y::\<open>nat \<Rightarrow> 'a\<close> where \<open>y = rec_nat 0 (\<lambda>n x. \<xi> (T n) x (inverse (of_nat 3^n)))\<close>
   have \<open>y (Suc n) \<in> ball (y n) (inverse (of_nat 3^n))\<close> for n
     using f1 \<open>\<And> n. T n \<noteq> 0\<close> \<open>\<And> n. inverse (of_nat 3^n) > 0\<close> unfolding y_def by auto
   hence \<open>norm (y (Suc n) - y n) \<le> inverse (of_nat 3^n)\<close> for n
-    unfolding ball_def apply auto using dist_norm by (smt norm_minus_commute) 
+    unfolding ball_def apply auto using dist_norm by (smt (verit) norm_minus_commute) 
   moreover have \<open>\<exists>K. \<forall>n. sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> K\<close>
     using sum_1 by blast
   moreover have \<open>Cauchy y\<close>
     using convergent_series_Cauchy[where a = "\<lambda>n. inverse (of_nat 3^n)" and \<phi> = y] dist_norm
     by (metis calculation(1) calculation(2))
   hence \<open>\<exists> x. y \<longlonglongrightarrow> x\<close>
     by (simp add: convergent_eq_Cauchy)
   then obtain x where \<open>y \<longlonglongrightarrow> x\<close>
     by blast
   have norm_2: \<open>norm (x - y (Suc n)) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close> for n
   proof-
     have \<open>inverse (real_of_nat 3) < 1\<close>
       by simp        
     moreover have \<open>y 0 = 0\<close>
       using y_def by auto
     ultimately have \<open>norm (x - y (Suc n)) 
     \<le> (inverse (of_nat 3)) * inverse (1 - (inverse (of_nat 3))) * ((inverse (of_nat 3)) ^ n)\<close>
       using bound_Cauchy_to_lim[where c = "inverse (of_nat 3)" and y = y and x = x]
         power_inverse semiring_norm(77)  \<open>y \<longlonglongrightarrow> x\<close>
         \<open>\<And> n. norm (y (Suc n) - y n) \<le> inverse (of_nat 3^n)\<close> by (metis divide_inverse)
     moreover have \<open>inverse (real_of_nat 3) * inverse (1 - (inverse (of_nat 3)))
                    = inverse (of_nat 2)\<close>
       by auto
     ultimately show ?thesis 
       by (metis power_inverse) 
   qed
   have \<open>norm (x - y (Suc n)) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close> for n
     using norm_2 by blast
   have \<open>\<exists> M. \<forall> n. norm ((*\<^sub>v) (T n) x) \<le> M\<close>
     unfolding T_def apply auto
     by (metis \<open>\<And>x. bounded (range (\<lambda>n. (*\<^sub>v) (f n) x))\<close> bounded_iff rangeI)
   then obtain M where \<open>norm ((*\<^sub>v) (T n) x) \<le> M\<close> for n
     by blast
   have norm_1: \<open>norm (T n) * norm (y (Suc n) - x) + norm ((*\<^sub>v) (T n) x)
        \<le> inverse (real 2) * inverse (real 3 ^ n) * norm (T n) + norm ((*\<^sub>v) (T n) x)\<close> for n
   proof-   
     have \<open>norm (y (Suc n) - x) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close>
       using \<open>norm (x - y (Suc n)) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close> 
       by (simp add: norm_minus_commute)
     moreover have \<open>norm (T n) \<ge> 0\<close>
       by auto
     ultimately have \<open>norm (T n) * norm (y (Suc n) - x) 
                      \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))*norm (T n)\<close>
       by (simp add: \<open>\<And>n. T n \<noteq> 0\<close>)
     thus ?thesis by simp      
   qed 
   have inverse_2: \<open>(inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n) 
                   \<le> norm ((*\<^sub>v) (T n) x)\<close> for n
   proof-
     have \<open>(of_rat 2/3)*(inverse (of_nat 3^n))*norm (T n) \<le> norm ((*\<^sub>v) (T n) (y (Suc n)))\<close> 
       using f1 \<open>\<And> n. T n \<noteq> 0\<close> \<open>\<And> n. inverse (of_nat 3^n) > 0\<close> unfolding y_def by auto
     also have \<open>\<dots> = norm ((*\<^sub>v) (T n) ((y (Suc n) - x) + x))\<close>
       by auto
     also have \<open>\<dots> = norm ((*\<^sub>v) (T n) (y (Suc n) - x) + (*\<^sub>v) (T n) x)\<close>
       apply transfer apply auto by (metis diff_add_cancel linear_simps(1))
     also have \<open>\<dots> \<le> norm ((*\<^sub>v) (T n) (y (Suc n) - x)) + norm ((*\<^sub>v) (T n) x)\<close>
       by (simp add: norm_triangle_ineq)
     also have \<open>\<dots> \<le> norm (T n) * norm (y (Suc n) - x) + norm ((*\<^sub>v) (T n) x)\<close>
       apply transfer apply auto using onorm by auto 
     also have \<open>\<dots> \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))*norm (T n) 
                 + norm ((*\<^sub>v) (T n) x)\<close>
       using norm_1 by blast
     finally have \<open>(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n)
                 \<le> inverse (real 2) * inverse (real 3 ^ n) * norm (T n) 
                 + norm ((*\<^sub>v) (T n) x)\<close>
       by blast
     hence \<open>(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n) 
              - inverse (real 2) * inverse (real 3 ^ n) * norm (T n) \<le> norm ((*\<^sub>v) (T n) x)\<close>
       by linarith
     moreover have \<open>(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n) 
              - inverse (real 2) * inverse (real 3 ^ n) * norm (T n)
              = (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\<close>
       by fastforce
     ultimately show \<open>(inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n) \<le> norm ((*\<^sub>v) (T n) x)\<close>
       by linarith      
   qed
   have inverse_3: \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) 
                     \<le> (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\<close> for n
   proof-
     have \<open>of_rat (4/3)^n = inverse (real 3 ^ n) * (of_nat 4^n)\<close>
       apply auto by (metis divide_inverse_commute of_rat_divide power_divide of_rat_numeral_eq) 
     also have \<open>\<dots> \<le>  inverse (real 3 ^ n) * norm (T n)\<close>
       using \<open>\<And>n. norm (T n) \<ge> of_nat (4^n)\<close> by simp
     finally have \<open>of_rat (4/3)^n \<le> inverse (real 3 ^ n) * norm (T n)\<close>
       by blast
     moreover have \<open>inverse (of_nat 6) > (0::real)\<close>
       by auto
     ultimately show ?thesis by auto
   qed
   have inverse_1: \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) \<le> M\<close> for n
   proof-
     have \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) 
           \<le> (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\<close> 
       using inverse_3 by blast
     also have \<open>\<dots> \<le> norm ((*\<^sub>v) (T n) x)\<close> 
       using inverse_2 by blast
     finally have \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) \<le> norm ((*\<^sub>v) (T n) x)\<close>
       by auto
-    thus ?thesis using \<open>\<And> n. norm ((*\<^sub>v) (T n) x) \<le> M\<close> by smt
+    thus ?thesis using \<open>\<And> n. norm ((*\<^sub>v) (T n) x) \<le> M\<close> by (smt (verit))
   qed
   have \<open>\<exists>n. M < (inverse (of_nat 6)) * (of_rat (4/3)^n)\<close>
     using Real.real_arch_pow by auto
   moreover have \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) \<le> M\<close> for n
     using inverse_1 by blast                      
-  ultimately show ?thesis by smt
+  ultimately show ?thesis by (smt (verit))
 qed
 
 subsection \<open>A consequence of Banach-Steinhaus theorem\<close>
 
 corollary bounded_linear_limit_bounded_linear:
   fixes f::\<open>nat \<Rightarrow> ('a::banach \<Rightarrow>\<^sub>L 'b::real_normed_vector)\<close>
   assumes \<open>\<And>x. convergent (\<lambda>n. (f n) *\<^sub>v x)\<close>
   shows  \<open>\<exists>g. (\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> (*\<^sub>v) g\<close>
   text\<open>
   Explanation: If a sequence of bounded operators on a Banach space converges
   pointwise, then the limit is also a bounded operator.
 \<close>
 proof-
   have \<open>\<exists>l. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> l\<close> for x
     by (simp add:  \<open>\<And>x. convergent (\<lambda>n. (*\<^sub>v) (f n) x)\<close> convergentD)
   hence \<open>\<exists>F. (\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close>
     unfolding pointwise_convergent_to_def by metis
   obtain F where \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close>
     using \<open>\<exists>F. (\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> by auto
   have \<open>\<And>x. (\<lambda> n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close>
     using \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> apply transfer
     by (simp add: pointwise_convergent_to_def)
   have \<open>bounded (range f)\<close>
     using \<open>\<And>x. convergent (\<lambda>n. (*\<^sub>v) (f n) x)\<close> banach_steinhaus
       \<open>\<And>x. \<exists>l. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> l\<close> convergent_imp_bounded by blast
   have norm_f_n: \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
     unfolding bounded_def
     by (meson UNIV_I \<open>bounded (range f)\<close> bounded_iff image_eqI)
   have \<open>isCont (\<lambda> t::'b. norm t) y\<close> for y::'b
     using Limits.isCont_norm by simp
   hence \<open>(\<lambda> n. norm ((*\<^sub>v) (f n) x)) \<longlonglongrightarrow> (norm (F x))\<close> for x
     using \<open>\<And> x::'a. (\<lambda> n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> by (simp add: tendsto_norm)
   hence norm_f_n_x: \<open>\<exists> M. \<forall> n. norm ((*\<^sub>v) (f n) x) \<le> M\<close> for x
     using Elementary_Metric_Spaces.convergent_imp_bounded
     by (metis UNIV_I \<open>\<And> x::'a. (\<lambda> n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> bounded_iff image_eqI)
   have norm_f: \<open>\<exists>K. \<forall>n. \<forall>x. norm ((*\<^sub>v) (f n) x) \<le> norm x * K\<close>
   proof-
     have \<open>\<exists> M. \<forall> n. norm ((*\<^sub>v) (f n) x) \<le> M\<close> for x
       using norm_f_n_x  \<open>\<And>x. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> by blast
     hence \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
       using norm_f_n by simp 
     then obtain M::real where \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
       by blast
     have \<open>\<forall> n. \<forall>x. norm ((*\<^sub>v) (f n) x) \<le> norm x * norm (f n)\<close>
       apply transfer apply auto by (metis mult.commute onorm) 
     thus  ?thesis using \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
       by (metis (no_types, opaque_lifting) dual_order.trans norm_eq_zero order_refl 
           mult_le_cancel_left_pos vector_space_over_itself.scale_zero_left zero_less_norm_iff)
   qed 
   have norm_F_x: \<open>\<exists>K. \<forall>x. norm (F x) \<le> norm x * K\<close>
   proof-
     have "\<exists>K. \<forall>n. \<forall>x. norm ((*\<^sub>v) (f n) x) \<le> norm x * K"
       using norm_f \<open>\<And>x. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> by auto
     thus ?thesis
       using  \<open>\<And> x::'a. (\<lambda> n. (*\<^sub>v) (f n)  x) \<longlonglongrightarrow> F x\<close> apply transfer 
       by (metis Lim_bounded tendsto_norm)   
   qed
   have \<open>linear F\<close>
   proof(rule linear_limit_linear)
     show \<open>linear ((*\<^sub>v) (f n))\<close> for n
       apply transfer apply auto by (simp add: bounded_linear.linear) 
     show \<open>f \<midarrow>pointwise\<rightarrow> F\<close>
       using \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> by auto
   qed
   moreover have \<open>bounded_linear_axioms F\<close>
     using norm_F_x by (simp add: \<open>\<And>x. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> bounded_linear_axioms_def) 
   ultimately have \<open>bounded_linear F\<close> 
     unfolding bounded_linear_def by blast
   hence \<open>\<exists>g. (*\<^sub>v) g = F\<close>
     using bounded_linear_Blinfun_apply by auto
   thus ?thesis using \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> apply transfer by auto
 qed
 
 end
diff --git a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
--- a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
+++ b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy
@@ -1,898 +1,898 @@
 (*
   File:   Banach_Steinhaus_Missing.thy
   Author: Dominique Unruh, University of Tartu
   Author: Jose Manuel Rodriguez Caballero, University of Tartu
 *)
 section \<open>Missing results for the proof of Banach-Steinhaus theorem\<close>
 
 theory Banach_Steinhaus_Missing
   imports
     "HOL-Analysis.Bounded_Linear_Function"
     "HOL-Analysis.Line_Segment"
 
 begin
 subsection \<open>Results missing for the proof of Banach-Steinhaus theorem\<close>
 text \<open>
   The results proved here are preliminaries for the proof of Banach-Steinhaus theorem using Sokal's 
   approach, but they do not explicitly appear in Sokal's paper \<^cite>\<open>sokal2011really\<close>.
 \<close>
 
 text\<open>Notation for the norm\<close>
 bundle notation_norm begin
 notation norm ("\<parallel>_\<parallel>")
 end
 
 bundle no_notation_norm begin
 no_notation norm ("\<parallel>_\<parallel>")
 end
 
 unbundle notation_norm
 
 text\<open>Notation for apply bilinear function\<close>
 bundle notation_blinfun_apply begin
 notation blinfun_apply (infixr "*\<^sub>v" 70)
 end
 
 bundle no_notation_blinfun_apply begin
 no_notation blinfun_apply (infixr "*\<^sub>v" 70)
 end
 
 unbundle notation_blinfun_apply
 
 lemma bdd_above_plus:
   fixes f::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>bdd_above (f ` S)\<close> and \<open>bdd_above (g ` S)\<close> 
   shows \<open>bdd_above ((\<lambda> x. f x + g x) ` S)\<close>
   text \<open>
   Explanation: If the images of two real-valued functions \<^term>\<open>f\<close>,\<^term>\<open>g\<close> are bounded above on a 
   set \<^term>\<open>S\<close>, then the image of their sum is bounded on \<^term>\<open>S\<close>.
 \<close>
 proof-
   obtain M where \<open>\<And> x. x\<in>S \<Longrightarrow> f x \<le> M\<close>
     using \<open>bdd_above (f ` S)\<close> unfolding bdd_above_def by blast
   obtain N where \<open>\<And> x. x\<in>S \<Longrightarrow> g x \<le> N\<close>
     using \<open>bdd_above (g ` S)\<close> unfolding bdd_above_def by blast
   have \<open>\<And> x. x\<in>S \<Longrightarrow> f x + g x \<le> M + N\<close>
     using \<open>\<And>x. x \<in> S \<Longrightarrow> f x \<le> M\<close> \<open>\<And>x. x \<in> S \<Longrightarrow> g x \<le> N\<close> by fastforce
   thus ?thesis unfolding bdd_above_def by blast
 qed
 
 text\<open>The maximum of two functions\<close>
 definition pointwise_max:: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
   \<open>pointwise_max f g = (\<lambda>x. max (f x) (g x))\<close>
 
 lemma max_Sup_absorb_left:
   fixes f g::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close> and \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>
   shows \<open>Sup ((pointwise_max f g) ` X) = Sup (f ` X)\<close>
 
   text \<open>Explanation: For real-valued functions \<^term>\<open>f\<close> and \<^term>\<open>g\<close>, if the supremum of \<^term>\<open>f\<close> is 
     greater-equal the supremum of \<^term>\<open>g\<close>, then the supremum of \<^term>\<open>max f g\<close> equals the supremum of
     \<^term>\<open>f\<close>. (Under some technical conditions.)\<close>
 
 proof-
   have y_Sup: \<open>y \<in> ((\<lambda> x. max (f x) (g x)) ` X) \<Longrightarrow> y \<le> Sup (f ` X)\<close> for y
   proof-
     assume \<open>y \<in> ((\<lambda> x. max (f x) (g x)) ` X)\<close>
     then obtain x where \<open>y = max (f x) (g x)\<close> and \<open>x \<in> X\<close>
       by blast
     have \<open>f x \<le> Sup (f ` X)\<close>
       by (simp add:  \<open>x \<in> X\<close> \<open>bdd_above (f ` X)\<close> cSUP_upper) 
     moreover have  \<open>g x \<le> Sup (g ` X)\<close>
       by (simp add:  \<open>x \<in> X\<close> \<open>bdd_above (g ` X)\<close> cSUP_upper) 
     ultimately have \<open>max (f x) (g x) \<le> Sup (f ` X)\<close>
       using  \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close> by auto
     thus ?thesis by (simp add: \<open>y = max (f x) (g x)\<close>) 
   qed
   have y_f_X: \<open>y \<in> f ` X \<Longrightarrow> y \<le> Sup ((\<lambda> x. max (f x) (g x)) ` X)\<close> for y
   proof-
     assume \<open>y \<in> f ` X\<close>
     then obtain x where \<open>x \<in> X\<close> and \<open>y = f x\<close>
       by blast
     have  \<open>bdd_above ((\<lambda> \<xi>. max (f \<xi>) (g \<xi>)) ` X)\<close>
       by (metis (no_types) \<open>bdd_above (f ` X)\<close> \<open>bdd_above (g ` X)\<close> bdd_above_image_sup sup_max)
     moreover have \<open>e > 0 \<Longrightarrow> \<exists> k \<in> (\<lambda> \<xi>. max (f \<xi>) (g \<xi>)) ` X. y \<le> k + e\<close>
       for e::real
       using \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>
       by (smt (verit, best) \<open>x \<in> X\<close> \<open>y = f x\<close> imageI)
     ultimately show ?thesis
       using \<open>x \<in> X\<close> \<open>y = f x\<close> cSUP_upper by fastforce
   qed
   have \<open>Sup ((\<lambda> x. max (f x) (g x)) ` X) \<le> Sup (f ` X)\<close>
     using y_Sup by (simp add: \<open>X \<noteq> {}\<close> cSup_least) 
   moreover have \<open>Sup ((\<lambda> x. max (f x) (g x)) ` X) \<ge> Sup (f ` X)\<close>
     using y_f_X by (metis (mono_tags) cSup_least calculation empty_is_image)  
   ultimately show ?thesis unfolding pointwise_max_def by simp
 qed
 
 lemma max_Sup_absorb_right:
   fixes f g::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close> and \<open>Sup (f ` X) \<le> Sup (g ` X)\<close>
   shows \<open>Sup ((pointwise_max f g) ` X) = Sup (g ` X)\<close>
   text \<open>
   Explanation: For real-valued functions \<^term>\<open>f\<close> and \<^term>\<open>g\<close> and a nonempty set \<^term>\<open>X\<close>, such that 
   the \<^term>\<open>f\<close> and \<^term>\<open>g\<close> are bounded above on \<^term>\<open>X\<close>, if the supremum of \<^term>\<open>f\<close> on \<^term>\<open>X\<close> is 
   lower-equal the supremum of \<^term>\<open>g\<close> on \<^term>\<open>X\<close>, then the supremum of \<^term>\<open>pointwise_max f g\<close> on \<^term>\<open>X\<close>
   equals the supremum of \<^term>\<open>g\<close>. This is the right analog of @{text max_Sup_absorb_left}.
 \<close>
 proof-
   have \<open>Sup ((pointwise_max g f) ` X) = Sup (g ` X)\<close>
     using  assms by (simp add: max_Sup_absorb_left)     
   moreover have \<open>pointwise_max g f = pointwise_max f g\<close>
     unfolding pointwise_max_def  by auto
   ultimately show ?thesis by simp
 qed
 
 lemma max_Sup:
   fixes f g::\<open>'a \<Rightarrow> real\<close>
   assumes \<open>X \<noteq> {}\<close> and \<open>bdd_above (f ` X)\<close> and \<open>bdd_above (g ` X)\<close>
   shows \<open>Sup ((pointwise_max f g) ` X) = max (Sup (f ` X)) (Sup (g ` X))\<close>
   text \<open>
   Explanation: Let \<^term>\<open>X\<close> be a nonempty set. Two supremum over \<^term>\<open>X\<close> of the maximum of two 
   real-value functions is equal to the maximum of their suprema over \<^term>\<open>X\<close>, provided that the
   functions are bounded above on \<^term>\<open>X\<close>.
 \<close>
 proof(cases \<open>Sup (f ` X) \<ge> Sup (g ` X)\<close>)
   case True thus ?thesis by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_left)
 next
   case False 
   have f1: "\<not> 0 \<le> Sup (f ` X) + - 1 * Sup (g ` X)"
     using False by linarith
   hence "Sup (Banach_Steinhaus_Missing.pointwise_max f g ` X) = Sup (g ` X)"
     by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_right)
   thus ?thesis
     using f1 by linarith
 qed
 
 
 lemma identity_telescopic:
   fixes x :: \<open>_ \<Rightarrow> 'a::real_normed_vector\<close>
   assumes \<open>x \<longlonglongrightarrow> l\<close>
   shows \<open>(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) \<longlonglongrightarrow> l - x n\<close>
   text\<open>
   Expression of a limit as a telescopic series.
   Explanation: If \<^term>\<open>x\<close> converges to \<^term>\<open>l\<close> then the sum \<^term>\<open>sum (\<lambda> k. x (Suc k) - x k) {n..N}\<close>
   converges to \<^term>\<open>l - x n\<close> as \<^term>\<open>N\<close> goes to infinity.
 \<close>
 proof-
   have \<open>(\<lambda> p. x (p + Suc n)) \<longlonglongrightarrow> l\<close>
     using \<open>x \<longlonglongrightarrow> l\<close> by (rule LIMSEQ_ignore_initial_segment)
   hence \<open>(\<lambda> p. x (Suc n + p)) \<longlonglongrightarrow> l\<close>   
     by (simp add: add.commute)
   hence \<open>(\<lambda> p. x (Suc (n + p))) \<longlonglongrightarrow> l\<close>
     by simp 
   hence \<open>(\<lambda> t. (- (x n)) + (\<lambda> p.  x (Suc (n + p))) t ) \<longlonglongrightarrow> (- (x n))  + l\<close>
     using tendsto_add_const_iff by metis 
   hence f1: \<open>(\<lambda> p. x (Suc (n + p)) - x n)\<longlonglongrightarrow> l - x n\<close>
     by simp
   have \<open>sum (\<lambda> k. x (Suc k) - x k) {n..n+p} = x (Suc (n+p)) - x n\<close> for p
     by (simp add: sum_Suc_diff)
   moreover have \<open>(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (n + t) 
                = (\<lambda> p. sum (\<lambda> k. x (Suc k) - x k) {n..n+p}) t\<close> for t
     by blast
   ultimately have  \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (n + p)) \<longlonglongrightarrow> l - x n\<close>
     using f1 by simp
   hence \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) (p + n)) \<longlonglongrightarrow> l - x n\<close>
     by (simp add: add.commute)
   hence  \<open>(\<lambda> p. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) p) \<longlonglongrightarrow> l - x n\<close>
     using Topological_Spaces.LIMSEQ_offset[where f = "(\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N})" 
         and a = "l - x n" and k = n] by blast
   hence  \<open>(\<lambda> M. (\<lambda> N. sum (\<lambda> k. x (Suc k) - x k) {n..N}) M) \<longlonglongrightarrow> l - x n\<close>
     by simp
   thus ?thesis by blast
 qed
 
 lemma bound_Cauchy_to_lim:
   assumes \<open>y \<longlonglongrightarrow> x\<close> and \<open>\<And>n. \<parallel>y (Suc n) - y n\<parallel> \<le> c^n\<close> and \<open>y 0 = 0\<close> and \<open>c < 1\<close>
   shows \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * c ^ n\<close>
   text\<open>
   Inequality about a sequence of approximations assuming that the sequence of differences is bounded
   by a geometric progression.
   Explanation: Let \<^term>\<open>y\<close> be a sequence converging to \<^term>\<open>x\<close>.
   If \<^term>\<open>y\<close> satisfies the inequality \<open>\<parallel>y (Suc n) - y n\<parallel> \<le> c ^ n\<close> for some \<^term>\<open>c < 1\<close> and 
   assuming \<^term>\<open>y 0 = 0\<close> then the inequality \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * c ^ n\<close> holds.
 \<close>
 proof-
   have \<open>c \<ge> 0\<close>
     using \<open>\<And> n. \<parallel>y (Suc n) - y n\<parallel> \<le> c^n\<close>
     by (metis dual_order.trans norm_ge_zero power_one_right)
   have norm_1: \<open>norm (\<Sum>k = Suc n..N. y (Suc k) - y k) \<le> (c ^ Suc n)/(1 - c)\<close> for N
   proof(cases \<open>N < Suc n\<close>)
     case True
     hence \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> = 0\<close>
       by auto
     thus ?thesis  using  \<open>c \<ge> 0\<close> \<open>c < 1\<close> by auto       
   next
     case False
     hence \<open>N \<ge> Suc n\<close>
       by auto
     have \<open>c^(Suc N) \<ge> 0\<close>
       using \<open>c \<ge> 0\<close> by auto
     have \<open>1 - c > 0\<close>
       by (simp add: \<open>c < 1\<close>)
     hence \<open>(1 - c)/(1 - c) = 1\<close>
       by auto
     have \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> \<le> (sum (\<lambda>k. \<parallel>y (Suc k) - y k\<parallel>) {Suc n .. N})\<close>
       by (simp add: sum_norm_le)
     hence \<open>\<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel> \<le> (sum (power c) {Suc n .. N})\<close>
       by (simp add: assms(2) sum_norm_le)
     hence \<open>(1 - c) * \<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel>
                    \<le> (1 - c) * (sum (power c) {Suc n .. N})\<close>
       using \<open>0 < 1 - c\<close> mult_le_cancel_left_pos by blast      
     also have \<open>\<dots> = c^(Suc n) - c^(Suc N)\<close>
       using Set_Interval.sum_gp_multiplied \<open>Suc n \<le> N\<close> by blast
     also have \<open>\<dots> \<le> c^(Suc n)\<close>
       using \<open>c^(Suc N) \<ge> 0\<close> by auto
     finally have \<open>(1 - c) * \<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel> \<le> c ^ Suc n\<close>
       by blast
     hence \<open>((1 - c) * \<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel>)/(1 - c)
                    \<le> (c ^ Suc n)/(1 - c)\<close>
       using \<open>0 < 1 - c\<close> divide_le_cancel by fastforce
     thus \<open>\<parallel>\<Sum>k = Suc n..N. y (Suc k) - y k\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
       using \<open>0 < 1 - c\<close> by auto 
   qed
   have \<open>(\<lambda> N. (sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N})) \<longlonglongrightarrow> x - y (Suc n)\<close>
     by (metis (no_types) \<open>y \<longlonglongrightarrow> x\<close> identity_telescopic)     
   hence \<open>(\<lambda> N. \<parallel>sum (\<lambda>k. y (Suc k) - y k) {Suc n .. N}\<parallel>) \<longlonglongrightarrow> \<parallel>x - y (Suc n)\<parallel>\<close>
     using tendsto_norm by blast
   hence \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
     using norm_1 Lim_bounded by blast
   hence  \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c ^ Suc n)/(1 - c)\<close>
     by auto
   moreover have \<open>(c ^ Suc n)/(1 - c) = (c / (1 - c)) * (c ^ n)\<close>
     by (simp add: divide_inverse_commute)    
   ultimately show \<open>\<parallel>x - y (Suc n)\<parallel> \<le> (c / (1 - c)) * (c ^ n)\<close> by linarith
 qed
 
 lemma onorm_open_ball:
   includes notation_norm
   shows \<open>\<parallel>f\<parallel> = Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 }\<close>
   text \<open>
   Explanation: Let \<^term>\<open>f\<close> be a bounded linear operator. The operator norm of \<^term>\<open>f\<close> is the
   supremum of \<^term>\<open>norm (f x)\<close> for \<^term>\<open>x\<close> such that \<^term>\<open>norm x < 1\<close>.
 \<close>
 proof(cases \<open>(UNIV::'a set) = 0\<close>)
   case True
   hence \<open>x = 0\<close> for x::'a
     by auto
   hence \<open>f *\<^sub>v x = 0\<close> for x
     by (metis (full_types) blinfun.zero_right)
   hence \<open>\<parallel>f\<parallel> = 0\<close>
     by (simp add: blinfun_eqI zero_blinfun.rep_eq)      
   have \<open>{ \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} = {0}\<close>
     by (smt (verit, ccfv_SIG) Collect_cong \<open>\<And>x. f *\<^sub>v x = 0\<close> norm_zero singleton_conv)      
   hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} = 0\<close>
     by simp    
   thus ?thesis using \<open>\<parallel>f\<parallel> = 0\<close> by auto      
 next
   case False
   hence \<open>(UNIV::'a set) \<noteq> 0\<close>
     by simp
   have nonnegative: \<open>\<parallel>f *\<^sub>v x\<parallel> \<ge> 0\<close> for x
     by simp
   have \<open>\<exists> x::'a. x \<noteq> 0\<close>
     using \<open>UNIV \<noteq> 0\<close> by auto
   then obtain x::'a where \<open>x \<noteq> 0\<close>
     by blast
   hence \<open>\<parallel>x\<parallel> \<noteq> 0\<close>
     by auto
   define y where \<open>y = x /\<^sub>R \<parallel>x\<parallel>\<close>
   have \<open>norm y = \<parallel> x /\<^sub>R \<parallel>x\<parallel> \<parallel>\<close>
     unfolding y_def by auto
   also have \<open>\<dots> = \<parallel>x\<parallel> /\<^sub>R \<parallel>x\<parallel>\<close>
     by auto
   also have \<open>\<dots> = 1\<close>
     using \<open>\<parallel>x\<parallel> \<noteq> 0\<close> by auto
   finally have \<open>\<parallel>y\<parallel> = 1\<close>
     by blast
   hence norm_1_non_empty: \<open>{ \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<noteq> {}\<close>
     by blast
   have norm_1_bounded: \<open>bdd_above { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
     unfolding bdd_above_def apply auto
     by (metis norm_blinfun)
   have norm_less_1_non_empty: \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} \<noteq> {}\<close>
     by (metis (mono_tags, lifting) Collect_empty_eq_bot bot_empty_eq empty_iff norm_zero 
         zero_less_one)   
   have norm_less_1_bounded: \<open>bdd_above {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
   proof-
     have \<open>\<exists>r. \<parallel>a r\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v (a r)\<parallel> \<le> r\<close> for a :: "real \<Rightarrow> 'a"
     proof-
       obtain r :: "('a \<Rightarrow>\<^sub>L 'b) \<Rightarrow> real" where
         "\<And>f x. 0 \<le> r f \<and> (bounded_linear f \<longrightarrow> \<parallel>f *\<^sub>v x\<parallel> \<le> \<parallel>x\<parallel> * r f)"
         by (metis mult.commute norm_blinfun norm_ge_zero)
       have \<open>\<not> \<parallel>f\<parallel> < 0\<close>
         by simp          
       hence "(\<exists>r. \<parallel>f\<parallel> * \<parallel>a r\<parallel> \<le> r) \<or> (\<exists>r. \<parallel>a r\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v a r\<parallel> \<le> r)"
         by (meson less_eq_real_def mult_le_cancel_left2) 
       thus ?thesis using dual_order.trans norm_blinfun by blast
     qed
     hence \<open>\<exists> M. \<forall> x. \<parallel>x\<parallel> < 1 \<longrightarrow> \<parallel>f *\<^sub>v x\<parallel> \<le> M\<close>
       by metis
     thus ?thesis by auto 
   qed
   have Sup_non_neg: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<ge> 0\<close>
     by (metis (mono_tags, lifting) \<open>\<parallel>y\<parallel> = 1\<close> cSup_upper2 mem_Collect_eq norm_1_bounded norm_ge_zero)
   have \<open>{0::real} \<noteq> {}\<close>
     by simp
   have \<open>bdd_above {0::real}\<close>
     by simp
   show \<open>\<parallel>f\<parallel> = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
   proof(cases \<open>\<forall>x. f *\<^sub>v x = 0\<close>)
     case True
     have \<open>\<parallel>f *\<^sub>v x\<parallel> = 0\<close> for x
       by (simp add: True)
     hence \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } \<subseteq> {0}\<close>
       by blast        
     moreover have \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } \<supseteq> {0}\<close>
       using calculation norm_less_1_non_empty by fastforce                        
     ultimately have \<open>{\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } = {0}\<close>  
       by blast
     hence Sup1: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 } = 0\<close> 
       by simp
     have \<open>\<parallel>f\<parallel> = 0\<close>
       by (simp add: True blinfun_eqI)        
     moreover have \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} = 0\<close>
       using Sup1 by blast
     ultimately show ?thesis by simp
   next
     case False
     have norm_f_eq_leq: \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<Longrightarrow> 
                          y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close> for y
     proof-
       assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       hence \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> \<and> \<parallel>x\<parallel> = 1\<close>
         by blast
       then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> and \<open>\<parallel>x\<parallel> = 1\<close>
         by auto
       define y' where \<open>y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R y\<close> for n
       have \<open>y' n \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close> for n
       proof-
         have \<open>y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R \<parallel>f *\<^sub>v x\<parallel>\<close>
           using y'_def \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> by blast
         also have \<open>... = \<bar>(1 - (inverse (real (Suc n))))\<bar> *\<^sub>R \<parallel>f *\<^sub>v x\<parallel>\<close>
           by (metis (mono_tags, opaque_lifting) \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> abs_1 abs_le_self_iff abs_of_nat 
               abs_of_nonneg add_diff_cancel_left' add_eq_if cancel_comm_monoid_add_class.diff_cancel
               diff_ge_0_iff_ge eq_iff_diff_eq_0 inverse_1 inverse_le_iff_le nat.distinct(1) of_nat_0
               of_nat_Suc of_nat_le_0_iff zero_less_abs_iff zero_neq_one)
         also have \<open>... = \<parallel>f *\<^sub>v ((1 - (inverse (real (Suc n)))) *\<^sub>R  x)\<parallel>\<close>
           by (simp add: blinfun.scaleR_right)            
         finally have y'_1: \<open>y' n = \<parallel>f *\<^sub>v ( (1 - (inverse (real (Suc n)))) *\<^sub>R x)\<parallel>\<close> 
           by blast
         have \<open>\<parallel>(1 - (inverse (Suc n))) *\<^sub>R x\<parallel> = (1 - (inverse (real (Suc n)))) * \<parallel>x\<parallel>\<close>
           by (simp add: linordered_field_class.inverse_le_1_iff)                
         hence \<open>\<parallel>(1 - (inverse (Suc n))) *\<^sub>R x\<parallel> < 1\<close>
           by (simp add: \<open>\<parallel>x\<parallel> = 1\<close>) 
         thus ?thesis using y'_1 by blast 
       qed
       have \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) ) \<longlonglongrightarrow> 1\<close>
         using Limits.LIMSEQ_inverse_real_of_nat_add_minus by simp
       hence \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \<longlonglongrightarrow> 1 *\<^sub>R y\<close>
         using Limits.tendsto_scaleR by blast
       hence \<open>(\<lambda>n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \<longlonglongrightarrow> y\<close>
         by simp
       hence \<open>(\<lambda>n. y' n) \<longlonglongrightarrow> y\<close>
         using y'_def by simp
       hence \<open>y' \<longlonglongrightarrow> y\<close> 
         by simp
       have \<open>y' n \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close> for n
         using cSup_upper \<open>\<And>n. y' n \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close> norm_less_1_bounded by blast
       hence \<open>y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
         using \<open>y' \<longlonglongrightarrow> y\<close> Topological_Spaces.Sup_lim by (meson LIMSEQ_le_const2)
       thus ?thesis by blast
     qed
     hence \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
       by (metis (lifting) cSup_least norm_1_non_empty)
     have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} \<Longrightarrow> y \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close> for y
     proof(cases \<open>y = 0\<close>)
       case True thus ?thesis by (simp add: Sup_non_neg) 
     next
       case False
       hence \<open>y \<noteq> 0\<close> by blast
       assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
       hence \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> \<and> \<parallel>x\<parallel> < 1\<close>
         by blast
       then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> and \<open>\<parallel>x\<parallel> < 1\<close>
         by blast
       have \<open>(1/\<parallel>x\<parallel>) * y = (1/\<parallel>x\<parallel>) * \<parallel>f x\<parallel>\<close>
         by (simp add: \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>)
       also have \<open>... = \<bar>1/\<parallel>x\<parallel>\<bar> * \<parallel>f *\<^sub>v x\<parallel>\<close>
         by simp
       also have \<open>... = \<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R (f *\<^sub>v x)\<parallel>\<close>
         by simp
       also have \<open>... = \<parallel>f *\<^sub>v ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
         by (simp add: blinfun.scaleR_right)          
       finally have \<open>(1/\<parallel>x\<parallel>) * y  = \<parallel>f *\<^sub>v ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
         by blast
       have \<open>x \<noteq> 0\<close>
         using  \<open>y \<noteq> 0\<close> \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> blinfun.zero_right by auto 
       have \<open>\<parallel> (1/\<parallel>x\<parallel>) *\<^sub>R x \<parallel> = \<bar> (1/\<parallel>x\<parallel>) \<bar> * \<parallel>x\<parallel>\<close>
         by simp
       also have \<open>... = (1/\<parallel>x\<parallel>) * \<parallel>x\<parallel>\<close>
         by simp
       finally have  \<open>\<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R x\<parallel> = 1\<close>
         using \<open>x \<noteq> 0\<close> by simp
       hence \<open>(1/\<parallel>x\<parallel>) * y \<in> { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
         using \<open>1 / \<parallel>x\<parallel> * y = \<parallel>f *\<^sub>v (1 / \<parallel>x\<parallel>) *\<^sub>R x\<parallel>\<close> by blast
       hence \<open>(1/\<parallel>x\<parallel>) * y \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
         by (simp add: cSup_upper norm_1_bounded)
       moreover have \<open>y \<le> (1/\<parallel>x\<parallel>) * y\<close>
         by (metis \<open>\<parallel>x\<parallel> < 1\<close> \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close> mult_le_cancel_right1 norm_not_less_zero 
             order.strict_implies_order \<open>x \<noteq> 0\<close> less_divide_eq_1_pos zero_less_norm_iff)
       ultimately show ?thesis by linarith 
     qed
     hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1} \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       by (smt (verit, del_insts) less_cSupD norm_less_1_non_empty)
     hence \<open>Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1} = Sup { \<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1}\<close>
       using \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> |x. norm x = 1} \<le> Sup { \<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close> by linarith
     have f1: \<open>(SUP x. \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> | x. True}\<close>
       by (simp add: full_SetCompr_eq)
     have \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} \<Longrightarrow> y \<in> { \<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
       for y
     proof-
       assume \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True}\<close> show ?thesis
       proof(cases \<open>y = 0\<close>)
         case True  thus ?thesis by simp 
       next
         case False
         have \<open>\<exists> x. y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close>
           using \<open>y \<in> { \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True}\<close> by auto
         then obtain x where \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close>
           by blast
         hence \<open>y = \<bar>(1/\<parallel>x\<parallel>)\<bar> * \<parallel> f *\<^sub>v x \<parallel>\<close>
           by simp
         hence \<open>y = \<parallel>(1/\<parallel>x\<parallel>) *\<^sub>R (f *\<^sub>v x)\<parallel>\<close>
           by simp
         hence \<open>y = \<parallel>f ((1/\<parallel>x\<parallel>) *\<^sub>R x)\<parallel>\<close>
           by (simp add: blinfun.scaleR_right)            
         moreover have \<open>\<parallel> (1/\<parallel>x\<parallel>) *\<^sub>R x \<parallel> = 1\<close>
           using False \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close> by auto
         ultimately have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close>
           by blast
         thus ?thesis by blast
       qed
     qed
     moreover have \<open>y \<in> {\<parallel>f x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0} \<Longrightarrow> y \<in> {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True}\<close>
       for y
     proof(cases \<open>y = 0\<close>)
       case True thus ?thesis by auto 
     next
       case False
       hence \<open>y \<notin> {0}\<close>
         by simp
       moreover assume \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
       ultimately have \<open>y \<in> {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close>
         by simp
       then obtain x where \<open>\<parallel>x\<parallel> = 1\<close> and \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>
         by auto
       have \<open>y = \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>\<close> using  \<open>\<parallel>x\<parallel> = 1\<close>  \<open>y = \<parallel>f *\<^sub>v x\<parallel>\<close>
         by simp 
       thus ?thesis by auto 
     qed
     ultimately have \<open>{\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} = {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}\<close>
       by blast
     hence \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} = Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0})\<close>
       by simp
     have "\<And>r s. \<not> (r::real) \<le> s \<or> sup r s = s"
       by (metis (lifting) sup.absorb_iff1 sup_commute)
     hence \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {(0::real)})
              = max (Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}) (Sup {0::real})\<close>
       using \<open>0 \<le> Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close> \<open>bdd_above {0}\<close> \<open>{0} \<noteq> {}\<close> cSup_singleton 
         cSup_union_distrib max.absorb_iff1 sup_commute norm_1_bounded norm_1_non_empty
       by (metis (no_types, lifting) )
     moreover have \<open>Sup {(0::real)} = (0::real)\<close>
       by simp          
     ultimately have \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}) = Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}\<close>
       using Sup_non_neg by linarith
     moreover have \<open>Sup ( {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}) 
                     = max (Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}) (Sup {0}) \<close>
       using Sup_non_neg  \<open>Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0}) 
         = max (Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1}) (Sup {0})\<close> 
       by auto           
     ultimately have f2: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> | x. True} = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       using \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel> |x. True} = Sup ({\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} \<union> {0})\<close> by linarith
     have \<open>(SUP x. \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> = 1}\<close>
       using f1 f2 by linarith
     hence \<open>(SUP x. \<parallel>f *\<^sub>v x\<parallel> / \<parallel>x\<parallel>) = Sup {\<parallel>f *\<^sub>v x\<parallel> | x. \<parallel>x\<parallel> < 1 }\<close>
       by (simp add: \<open>Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> = 1} = Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close>)        
     thus ?thesis apply transfer by (simp add: onorm_def) 
   qed      
 qed
 
 lemma onorm_r:
   includes notation_norm
   assumes \<open>r > 0\<close>
   shows \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r)) / r\<close>
   text \<open>
   Explanation: The norm of \<^term>\<open>f\<close> is \<^term>\<open>1/r\<close> of the supremum of the norm of \<^term>\<open>f *\<^sub>v x\<close> for
   \<^term>\<open>x\<close> in the ball of radius \<^term>\<open>r\<close> centered at the origin.
 \<close>
 proof-
   have \<open>\<parallel>f\<parallel> = Sup {\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1}\<close>
     using onorm_open_ball by blast
   moreover have *: \<open>{\<parallel>f *\<^sub>v x\<parallel> |x. \<parallel>x\<parallel> < 1} = (\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 1)\<close>
     unfolding ball_def by auto
   ultimately have onorm_f: \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 1))\<close>
     by simp
   have s2: \<open>x \<in> (\<lambda>t. r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close> for x
   proof-
     assume \<open>x \<in> (\<lambda>t. r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
     hence \<open>\<exists> t. x = r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel> \<and> \<parallel>t\<parallel> < 1\<close>
       by auto
     then obtain t where t: \<open>x = r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>\<close> \<open>\<parallel>t\<parallel> < 1\<close>
       by blast
     define y where \<open>y = x /\<^sub>R r\<close>
     have \<open>x = r * (inverse r * x)\<close>
       using \<open>x = r *\<^sub>R norm (f t)\<close> by auto
     hence \<open>x - (r * (inverse r * x)) \<le> 0\<close>
       by linarith
     hence \<open>x \<le> r * (x /\<^sub>R r)\<close>
       by auto
     have \<open>y \<in> (\<lambda>k. \<parallel>f *\<^sub>v k\<parallel>) ` ball 0 1\<close>
       unfolding y_def using assms t * by fastforce 
     moreover have \<open>x \<le> r * y\<close>          
       using \<open>x \<le> r * (x /\<^sub>R r)\<close> y_def by blast
     ultimately have y_norm_f: \<open>y \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<and> x \<le> r * y\<close>
       by blast
     have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<noteq> {}\<close>
       by simp        
     moreover have \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close>
       by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above 
           bounded_norm_comp) 
     moreover have \<open>\<exists> y. y \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<and> x \<le> r * y\<close>
       using y_norm_f by blast
     ultimately show ?thesis
       by (meson assms cSup_upper dual_order.trans mult_le_cancel_left_pos)
   qed
   have s3: \<open>(\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y) \<Longrightarrow>
          r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1) \<le> y\<close> for y
   proof-
     assume \<open>\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y\<close> 
     have x_leq: \<open>x \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y / r\<close> for x
     proof-
       assume \<open>x \<in> (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
       then obtain t where \<open>t \<in> ball (0::'a) 1\<close> and \<open>x = \<parallel>f *\<^sub>v t\<parallel>\<close>
         by auto
       define x' where \<open>x' = r *\<^sub>R x\<close>
       have \<open>x' = r * \<parallel>f *\<^sub>v t\<parallel>\<close>
         by (simp add: \<open>x = \<parallel>f *\<^sub>v t\<parallel>\<close> x'_def)
       hence \<open>x' \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1\<close>
         using \<open>t \<in> ball (0::'a) 1\<close> by auto
       hence \<open>x' \<le> y\<close>
         using \<open>\<And>x. x \<in> (\<lambda>t. r * \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<Longrightarrow> x \<le> y\<close> by blast        
       thus \<open>x \<le> y / r\<close>
         unfolding x'_def using \<open>r > 0\<close> by (simp add: mult.commute pos_le_divide_eq) 
     qed
     have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1 \<noteq> {}\<close>
       by simp        
     moreover have \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close>
       by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above 
           bounded_norm_comp) 
     ultimately have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1) \<le> y/r\<close>
       using x_leq by (simp add: \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 1)\<close> cSup_least) 
     thus ?thesis using \<open>r > 0\<close>
       by (simp add: mult.commute pos_le_divide_eq)
   qed
   have norm_scaleR: \<open>norm \<circ> ((*\<^sub>R) r) = ((*\<^sub>R) \<bar>r\<bar>) \<circ> (norm::'a \<Rightarrow> real)\<close>
     by auto
   have f_x1: \<open>f (r *\<^sub>R x) = r *\<^sub>R f x\<close> for x
     by (simp add: blinfun.scaleR_right)    
   have \<open>ball (0::'a) r = ((*\<^sub>R) r) ` (ball 0 1)\<close>
-    by (smt assms ball_scale nonzero_mult_div_cancel_left right_inverse_eq scale_zero_right)
+    by (smt (verit) assms ball_scale nonzero_mult_div_cancel_left right_inverse_eq scale_zero_right)
   hence \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) = Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (((*\<^sub>R) r) ` (ball 0 1)))\<close>
     by simp
   also have \<open>\<dots> = Sup (((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) \<circ> ((*\<^sub>R) r)) ` (ball 0 1))\<close>
     using Sup.SUP_image by auto
   also have \<open>\<dots> = Sup ((\<lambda>t. \<parallel>f *\<^sub>v (r *\<^sub>R t)\<parallel>) ` (ball 0 1))\<close>
     using f_x1 by (simp add: comp_assoc) 
   also have \<open>\<dots> = Sup ((\<lambda>t. \<bar>r\<bar> *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
     using norm_scaleR f_x1 by auto 
   also have \<open>\<dots> = Sup ((\<lambda>t. r *\<^sub>R \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
     using \<open>r > 0\<close> by auto
   also have \<open>\<dots> = r * Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 1))\<close>
     apply (rule cSup_eq_non_empty) apply simp using s2 apply auto using s3 by auto
   also have \<open>\<dots> = r * \<parallel>f\<parallel>\<close>
     using onorm_f by auto
   finally have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball 0 r) = r * \<parallel>f\<parallel>\<close>
     by blast    
   thus \<open>\<parallel>f\<parallel> = Sup ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r)) / r\<close> using \<open>r > 0\<close> by simp
 qed
 
 text\<open>Pointwise convergence\<close>
 definition pointwise_convergent_to :: 
   \<open>( nat \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) ) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool\<close> 
   (\<open>((_)/ \<midarrow>pointwise\<rightarrow> (_))\<close> [60, 60] 60) where
   \<open>pointwise_convergent_to x l = (\<forall> t::'a. (\<lambda> n. (x n) t) \<longlonglongrightarrow> l t)\<close>
 
 lemma linear_limit_linear:
   fixes f :: \<open>_ \<Rightarrow> ('a::real_vector \<Rightarrow> 'b::real_normed_vector)\<close>
   assumes  \<open>\<And>n. linear (f n)\<close> and \<open>f \<midarrow>pointwise\<rightarrow> F\<close>
   shows \<open>linear F\<close>
   text\<open>
   Explanation: If a family of linear operators converges pointwise, then the limit is also a linear
   operator.
 \<close>
 proof
   show "F (x + y) = F x + F y" for x y
   proof-
     have "\<forall>a. F a = lim (\<lambda>n. f n a)"
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by (metis (full_types) limI)
     moreover have "\<forall>f b c g. (lim (\<lambda>n. g n + f n) = (b::'b) + c \<or> \<not> f \<longlonglongrightarrow> c) \<or> \<not> g \<longlonglongrightarrow> b"
       by (metis (no_types) limI tendsto_add)
     moreover have "\<And>a. (\<lambda>n. f n a) \<longlonglongrightarrow> F a"
       using assms(2) pointwise_convergent_to_def by force
     ultimately have 
       lim_sum: \<open>lim (\<lambda> n. (f n) x + (f n) y) = lim (\<lambda> n. (f n) x) + lim (\<lambda> n. (f n) y)\<close>
       by metis
     have \<open>(f n) (x + y) = (f n) x + (f n) y\<close> for n
       using \<open>\<And> n.  linear (f n)\<close> unfolding linear_def using Real_Vector_Spaces.linear_iff assms(1) 
       by auto
     hence \<open>lim (\<lambda> n. (f n) (x + y)) = lim (\<lambda> n. (f n) x + (f n) y)\<close>
       by simp
     hence \<open>lim (\<lambda> n. (f n) (x + y)) = lim (\<lambda> n. (f n) x) + lim (\<lambda> n. (f n) y)\<close>
       using lim_sum by simp
     moreover have \<open>(\<lambda> n. (f n) (x + y)) \<longlonglongrightarrow> F (x + y)\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     moreover have \<open>(\<lambda> n. (f n) x) \<longlonglongrightarrow> F x\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     moreover have \<open>(\<lambda> n. (f n) y) \<longlonglongrightarrow> F y\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     ultimately show ?thesis
       by (metis limI) 
   qed
   show "F (r *\<^sub>R x) = r *\<^sub>R F x" for r and x
   proof-
     have \<open>(f n) (r *\<^sub>R x) = r *\<^sub>R (f n) x\<close> for n
       using  \<open>\<And> n.  linear (f n)\<close> 
       by (simp add: Real_Vector_Spaces.linear_def real_vector.linear_scale)
     hence \<open>lim (\<lambda> n. (f n) (r *\<^sub>R x)) = lim (\<lambda> n. r *\<^sub>R (f n) x)\<close>
       by simp
     have \<open>convergent (\<lambda> n. (f n) x)\<close>
       by (metis assms(2) convergentI pointwise_convergent_to_def)
     moreover have \<open>isCont (\<lambda> t::'b. r *\<^sub>R t) tt\<close> for tt
       by (simp add: bounded_linear_scaleR_right)
     ultimately have \<open>lim (\<lambda> n. r *\<^sub>R ((f n) x)) =  r *\<^sub>R lim (\<lambda> n. (f n) x)\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def 
       by (metis (mono_tags) isCont_tendsto_compose limI)
     hence \<open>lim (\<lambda> n.  (f n) (r *\<^sub>R x)) = r *\<^sub>R lim (\<lambda> n. (f n) x)\<close> 
       using \<open>lim (\<lambda> n. (f n) (r *\<^sub>R x)) = lim (\<lambda> n. r *\<^sub>R (f n) x)\<close> by simp
     moreover have \<open>(\<lambda> n. (f n) x) \<longlonglongrightarrow> F x\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     moreover have \<open>(\<lambda> n.  (f n) (r *\<^sub>R x)) \<longlonglongrightarrow> F (r *\<^sub>R x)\<close>
       using \<open>f \<midarrow>pointwise\<rightarrow> F\<close> unfolding pointwise_convergent_to_def by blast
     ultimately show ?thesis
       by (metis limI) 
   qed
 qed
 
 
 lemma non_Cauchy_unbounded:
   fixes a ::\<open>_ \<Rightarrow> real\<close> 
   assumes \<open>\<And>n. a n \<ge> 0\<close> and \<open>e > 0\<close> 
     and \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
   shows \<open>(\<lambda>n. (sum a  {0..n})) \<longlonglongrightarrow> \<infinity>\<close>
   text\<open>
   Explanation: If the sequence of partial sums of nonnegative terms is not Cauchy, then it converges
   to infinite.
 \<close>
 proof-
   define S::"ereal set" where \<open>S = range (\<lambda>n. sum a  {0..n})\<close>
   have \<open>\<exists>s\<in>S.  k*e \<le> s\<close> for k::nat
   proof(induction k)
     case 0
     from \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
     obtain m n where \<open>m \<ge> 0\<close> and \<open>n \<ge> 0\<close> and \<open>m > n\<close> and \<open>sum a {Suc n..m} \<ge> e\<close> by blast
     have \<open>n < Suc n\<close>
       by simp
     hence \<open>{0..n} \<union> {Suc n..m} = {0..m}\<close>
       using Set_Interval.ivl_disj_un(7) \<open>n < m\<close> by auto
     moreover have \<open>finite {0..n}\<close>
       by simp
     moreover have \<open>finite {Suc n..m}\<close>
       by simp
     moreover have \<open>{0..n} \<inter> {Suc n..m} = {}\<close>
       by simp
     ultimately have \<open>sum a {0..n} + sum a {Suc n..m} = sum a {0..m}\<close>
       by (metis sum.union_disjoint) 
     moreover have \<open>sum a {Suc n..m} > 0\<close>
       using \<open>e > 0\<close> \<open>sum a {Suc n..m} \<ge> e\<close> by linarith
     moreover have \<open>sum a {0..n} \<ge> 0\<close>
       by (simp add: assms(1) sum_nonneg)
     ultimately have \<open>sum a {0..m} > 0\<close>
       by linarith      
     moreover have \<open>sum a {0..m} \<in> S\<close>
       unfolding S_def by blast
     ultimately have \<open>\<exists>s\<in>S. 0 \<le> s\<close>
       using ereal_less_eq(5) by fastforce    
     thus ?case
       by (simp add: zero_ereal_def)  
   next
     case (Suc k)
     assume \<open>\<exists>s\<in>S. k*e \<le> s\<close>
     then obtain s where \<open>s\<in>S\<close> and \<open>ereal (k * e) \<le> s\<close>
       by blast
     have \<open>\<exists>N. s = sum a {0..N}\<close>
       using \<open>s\<in>S\<close> unfolding S_def by blast
     then obtain N where \<open>s = sum a {0..N}\<close>
       by blast
     from \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
     obtain m n where \<open>m \<ge> Suc N\<close> and \<open>n \<ge> Suc N\<close> and \<open>m > n\<close> and \<open>sum a {Suc n..m} \<ge> e\<close>
       by blast
     have \<open>finite {Suc N..n}\<close>
       by simp
     moreover have \<open>finite {Suc n..m}\<close>
       by simp
     moreover have \<open>{Suc N..n} \<union> {Suc n..m} = {Suc N..m}\<close>
       using Set_Interval.ivl_disj_un
       by (metis \<open>Suc N \<le> n\<close> \<open>n < m\<close> atLeastSucAtMost_greaterThanAtMost order_less_imp_le)
     moreover have \<open>{} = {Suc N..n} \<inter> {Suc n..m}\<close>
       by simp
     ultimately have \<open>sum a {Suc N..m} = sum a {Suc N..n} + sum a {Suc n..m}\<close>
       by (metis sum.union_disjoint)
     moreover have \<open>sum a {Suc N..n} \<ge> 0\<close>
       using  \<open>\<And>n. a n \<ge> 0\<close> by (simp add: sum_nonneg) 
     ultimately have \<open>sum a {Suc N..m} \<ge> e\<close>
       using \<open>e \<le> sum a {Suc n..m}\<close> by linarith
     have \<open>finite {0..N}\<close>
       by simp
     have \<open>finite {Suc N..m}\<close>
       by simp
     moreover have \<open>{0..N} \<union> {Suc N..m} = {0..m}\<close>
       using Set_Interval.ivl_disj_un(7) \<open>Suc N \<le> m\<close> by auto          
     moreover have \<open>{0..N} \<inter> {Suc N..m} = {}\<close>
       by simp
     ultimately have \<open>sum a {0..N} + sum a {Suc N..m} =  sum a {0..m}\<close> 
       by (metis \<open>finite {0..N}\<close> sum.union_disjoint)    
     hence \<open>e + k * e \<le> sum a {0..m}\<close>
       using \<open>ereal (real k * e) \<le> s\<close> \<open>s = ereal (sum a {0..N})\<close> \<open>e \<le> sum a {Suc N..m}\<close> by auto 
     moreover have \<open>e + k * e = (Suc k) * e\<close>
       by (simp add: semiring_normalization_rules(3))
     ultimately have \<open>(Suc k) * e \<le> sum a {0..m}\<close>
       by linarith
     hence \<open>ereal ((Suc k) * e) \<le> sum a {0..m}\<close>
       by auto
     moreover have \<open>sum a {0..m}\<in>S\<close>
       unfolding S_def by blast
     ultimately show ?case by blast
   qed
   hence \<open>\<exists>s\<in>S. (real n) \<le> s\<close> for n
     by (meson assms(2) ereal_le_le ex_less_of_nat_mult less_le_not_le)
   hence  \<open>Sup S = \<infinity>\<close>
     using Sup_le_iff Sup_subset_mono dual_order.strict_trans1 leD less_PInf_Ex_of_nat subsetI 
     by metis
   hence Sup: \<open>Sup ((range (\<lambda> n. (sum a  {0..n})))::ereal set) = \<infinity>\<close> using S_def 
     by blast
   have \<open>incseq (\<lambda>n. (sum a  {..<n}))\<close>
     using \<open>\<And>n. a n \<ge> 0\<close> using Extended_Real.incseq_sumI by auto
   hence \<open>incseq (\<lambda>n. (sum a  {..< Suc n}))\<close>
     by (meson incseq_Suc_iff)
   hence \<open>incseq (\<lambda>n. (sum a  {0..n})::ereal)\<close>
     using incseq_ereal by (simp add: atLeast0AtMost lessThan_Suc_atMost) 
   hence \<open>(\<lambda>n. sum a  {0..n}) \<longlonglongrightarrow> Sup (range (\<lambda>n. (sum a  {0..n})::ereal))\<close>
     using LIMSEQ_SUP by auto
   thus ?thesis using Sup PInfty_neq_ereal by auto 
 qed
 
 lemma sum_Cauchy_positive:
   fixes a ::\<open>_ \<Rightarrow> real\<close>
   assumes \<open>\<And>n. a n \<ge> 0\<close> and \<open>\<exists>K. \<forall>n. (sum a  {0..n}) \<le> K\<close>
   shows \<open>Cauchy (\<lambda>n. sum a {0..n})\<close>
   text\<open>
   Explanation: If a series of nonnegative reals is bounded, then the series is 
   Cauchy.
 \<close>
 proof (unfold Cauchy_altdef2, rule, rule)
   fix e::real
   assume \<open>e>0\<close>       
   have \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
   proof(rule classical)
     assume \<open>\<not>(\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e)\<close>
     hence \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> \<not>(sum a {Suc n..m} < e)\<close>
       by blast
     hence \<open>\<forall>M. \<exists>m. \<exists>n. m \<ge> M \<and> n \<ge> M \<and> m > n \<and> sum a {Suc n..m} \<ge> e\<close>
       by fastforce
     hence \<open>(\<lambda>n. (sum a  {0..n}) ) \<longlonglongrightarrow> \<infinity>\<close>
       using non_Cauchy_unbounded \<open>0 < e\<close> assms(1) by blast
     from  \<open>\<exists>K. \<forall>n. sum a  {0..n} \<le> K\<close>
     obtain K where  \<open>\<forall>n. sum a {0..n} \<le> K\<close>
       by blast
     from  \<open>(\<lambda>n. sum a {0..n})  \<longlonglongrightarrow> \<infinity>\<close>
     have \<open>\<forall>B. \<exists>N. \<forall>n\<ge>N. (\<lambda> n. (sum a  {0..n}) ) n \<ge> B\<close>
       using Lim_PInfty by simp
     hence  \<open>\<exists>n. (sum a {0..n}) \<ge> K+1\<close>
       using ereal_less_eq(3) by blast        
     thus ?thesis using  \<open>\<forall>n. (sum a  {0..n}) \<le> K\<close> by (smt (verit, best))
   qed
   have \<open>sum a {Suc n..m} = sum a {0..m} - sum a {0..n}\<close>
     if "m > n" for m n
     by (metis add_diff_cancel_left' atLeast0AtMost less_imp_add_positive sum_up_index_split that)
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
     using \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close> by presburger
   then obtain M where \<open>\<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {0..m} - sum a {0..n} < e\<close>
     by blast
   moreover have \<open>m > n \<Longrightarrow> sum a {0..m} \<ge> sum a {0..n}\<close> for m n
     using \<open>\<And> n. a n \<ge> 0\<close> by (simp add: sum_mono2)
   ultimately have \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
     by auto
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m \<ge> n \<longrightarrow> \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
     by (metis \<open>0 < e\<close> abs_zero cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq' 
         less_irrefl_nat linorder_neqE_nat zero_less_diff)      
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. \<bar>sum a {0..m} - sum a {0..n}\<bar> < e\<close>
     by (metis abs_minus_commute nat_le_linear)
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>
     by (simp add: dist_real_def)      
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close> by blast
   thus \<open>\<exists>N. \<forall>n\<ge>N. dist (sum a {0..n}) (sum a {0..N}) < e\<close> by auto
 qed
 
 lemma convergent_series_Cauchy:
   fixes a::\<open>nat \<Rightarrow> real\<close> and \<phi>::\<open>nat \<Rightarrow> 'a::metric_space\<close>
   assumes \<open>\<exists>M. \<forall>n. sum a {0..n} \<le> M\<close> and \<open>\<And>n. dist (\<phi> (Suc n)) (\<phi> n) \<le> a n\<close>
   shows \<open>Cauchy \<phi>\<close>
   text\<open>
   Explanation: Let \<^term>\<open>a\<close> be a real-valued sequence and let \<^term>\<open>\<phi>\<close> be sequence in a metric space.
   If the partial sums of \<^term>\<open>a\<close> are uniformly bounded and the distance between consecutive terms of \<^term>\<open>\<phi>\<close>
   are bounded by the sequence \<^term>\<open>a\<close>, then \<^term>\<open>\<phi>\<close> is Cauchy.\<close>
 proof (unfold Cauchy_altdef2, rule, rule)
   fix e::real
   assume \<open>e > 0\<close>
   have \<open>\<And>k. a k \<ge> 0\<close>
     using \<open>\<And>n. dist (\<phi> (Suc n)) (\<phi> n) \<le> a n\<close> dual_order.trans zero_le_dist by blast
   hence \<open>Cauchy (\<lambda>k. sum a {0..k})\<close>
     using  \<open>\<exists>M. \<forall>n. sum a {0..n} \<le> M\<close> sum_Cauchy_positive by blast
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>
     unfolding Cauchy_def using \<open>e > 0\<close> by blast
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> dist (sum a {0..m}) (sum a {0..n}) < e\<close>
     by blast
   have \<open>dist (sum a {0..m}) (sum a {0..n}) = sum a {Suc n..m}\<close> if \<open>n<m\<close> for m n
   proof -
     have \<open>n < Suc n\<close>
       by simp
     have \<open>finite {0..n}\<close>
       by simp
     moreover have \<open>finite {Suc n..m}\<close>
       by simp
     moreover have \<open>{0..n} \<union> {Suc n..m} = {0..m}\<close>
       using \<open>n < Suc n\<close> \<open>n < m\<close> by auto
     moreover have  \<open>{0..n} \<inter> {Suc n..m} = {}\<close>
       by simp
     ultimately have sum_plus: \<open>(sum a {0..n}) + sum a {Suc n..m} = (sum a {0..m})\<close>
       by (metis sum.union_disjoint)
     have \<open>dist (sum a {0..m}) (sum a {0..n}) = \<bar>(sum a {0..m}) - (sum a {0..n})\<bar>\<close>
       using dist_real_def by blast
     moreover have \<open>(sum a {0..m}) - (sum a {0..n}) = sum a {Suc n..m}\<close>
       using sum_plus by linarith 
     ultimately show ?thesis
       by (simp add: \<open>\<And>k. 0 \<le> a k\<close> sum_nonneg)
   qed
   hence sum_a: \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
     by (metis \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (sum a {0..m}) (sum a {0..n}) < e\<close>) 
   obtain M where \<open>\<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {Suc n..m} < e\<close>
     using sum_a \<open>e > 0\<close> by blast
   hence  \<open>\<forall>m. \<forall>n. Suc m \<ge> Suc M \<and> Suc n \<ge> Suc M \<and> Suc m > Suc n \<longrightarrow> sum a {Suc n..Suc m - 1} < e\<close>
     by simp
   hence  \<open>\<forall>m\<ge>1. \<forall>n\<ge>1. m \<ge> Suc M \<and> n \<ge> Suc M \<and> m > n \<longrightarrow> sum a {n..m - 1} < e\<close>
     by (metis Suc_le_D)
   hence sum_a2: \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> sum a {n..m-1} < e\<close>
     by (meson add_leE)
   have \<open>dist (\<phi> (n+p+1)) (\<phi> n) \<le> sum a {n..n+p}\<close> for p n :: nat
   proof(induction p)
     case 0 thus ?case  by (simp add: assms(2))
   next
     case (Suc p) thus ?case
       by (smt(verit, ccfv_SIG) Suc_eq_plus1 add_Suc_right add_less_same_cancel1 assms(2) dist_self dist_triangle2 
           gr_implies_not0 sum.cl_ivl_Suc)  
   qed
   hence \<open>m > n \<Longrightarrow> dist (\<phi> m) (\<phi> n) \<le> sum a {n..m-1}\<close> for m n :: nat
     by (metis Suc_eq_plus1 Suc_le_D diff_Suc_1  gr0_implies_Suc less_eq_Suc_le less_imp_Suc_add 
         zero_less_Suc)
   hence \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. m > n \<longrightarrow> dist (\<phi> m) (\<phi> n) < e\<close> 
-    using sum_a2 \<open>e > 0\<close> by smt
+    using sum_a2 \<open>e > 0\<close> by (smt (verit))
   thus "\<exists>N. \<forall>n\<ge>N. dist (\<phi> n) (\<phi> N) < e"
     using \<open>0 < e\<close> by fastforce
 qed
 
 unbundle notation_blinfun_apply
 
 unbundle no_notation_norm
 
 end
diff --git a/thys/Boolos_Curious_Inference_Automated/ROOT b/thys/Boolos_Curious_Inference_Automated/ROOT
--- a/thys/Boolos_Curious_Inference_Automated/ROOT
+++ b/thys/Boolos_Curious_Inference_Automated/ROOT
@@ -1,12 +1,9 @@
 chapter AFP
 
 session "Boolos_Curious_Inference_Automated" = HOL +
-
   options [timeout = 600]
-
   theories
-   Boolos_Curious_Inference_Automated
-
+    Boolos_Curious_Inference_Automated
   document_files
     "root.bib"
     "root.tex"
diff --git a/thys/DigitsInBase/DigitsInBase.thy b/thys/DigitsInBase/DigitsInBase.thy
--- a/thys/DigitsInBase/DigitsInBase.thy
+++ b/thys/DigitsInBase/DigitsInBase.thy
@@ -1,920 +1,918 @@
 theory DigitsInBase
   imports "HOL-Computational_Algebra.Computational_Algebra" "HOL-Number_Theory.Number_Theory"
 begin
 
 section\<open>Infinite sums\<close>
 text\<open>In this section, it is shown that an infinite series \emph{of natural numbers} converges if
 and only if its terms are eventually zero. Additionally, the notion of a summation starting from an
 index other than zero is defined. A few obvious lemmas about these notions are established.\<close>
 
 definition eventually_zero :: "(nat \<Rightarrow> _) \<Rightarrow> bool" where
 "eventually_zero (D :: nat \<Rightarrow> _) \<longleftrightarrow> (\<forall>\<^sub>\<infinity> n. D n = 0)"
 
 lemma eventually_zero_char:
   shows "eventually_zero D \<longleftrightarrow> (\<exists>s. \<forall>i\<ge>s. D i = 0)"
   unfolding eventually_zero_def
   using MOST_nat_le .
 
 text\<open>There's a lot of commonality between this setup and univariate polynomials, but drawing out
 the similarities and proving them is beyond the scope of the current version of this theory except
 for the following lemma.\<close>
 lemma eventually_zero_poly:
   shows "eventually_zero D \<longleftrightarrow> D = poly.coeff (Abs_poly D)"
   by (metis Abs_poly_inverse MOST_coeff_eq_0 eventually_zero_def mem_Collect_eq)
 
 lemma eventually_zero_imp_summable [simp]:
   assumes "eventually_zero D"
   shows "summable D"
   using summable_finite assms eventually_zero_char
   by (metis (mono_tags) atMost_iff finite_atMost nat_le_linear)
 
 lemma summable_bounded:
   fixes my_seq :: "nat \<Rightarrow> nat" and n :: nat
   assumes "\<And> i . i \<ge> n \<longrightarrow> my_seq i = 0"
   shows "summable my_seq"
   using assms eventually_zero_char eventually_zero_imp_summable by blast
 
 lemma sum_bounded:
   fixes my_seq :: "nat \<Rightarrow> nat" and n :: nat
   assumes "\<And> i . i \<ge> n \<longrightarrow> my_seq i = 0"
   shows "(\<Sum>i. my_seq i) = (\<Sum>i<n. my_seq i)"
   by (meson assms finite_lessThan lessThan_iff linorder_not_le suminf_finite)  
 
 lemma product_seq_eventually_zero:
   fixes seq1 seq2 :: "nat \<Rightarrow> nat"
   assumes "eventually_zero seq1"
   shows "eventually_zero (\<lambda> i. seq1 i * seq2 i)"
   using mult_0 eventually_zero_char
   by (metis (no_types, lifting) assms)
 
 abbreviation upper_sum
   where "upper_sum seq n \<equiv> \<Sum>i. seq (i + n)"
 syntax
   "_from_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sum>_\<ge>_./ _)" [0,0,10] 10)
 translations
   "\<Sum>i\<ge>n. t" == "CONST upper_sum (\<lambda>i. t) n"
 
 text \<open>The following two statements are proved as a sanity check. They are not intended to be used
 anywhere.\<close>
 corollary
   fixes seq :: "nat \<Rightarrow> nat" and a :: nat
   assumes seq_def: "\<And> i. seq i = (if i = 0 then a else 0)"
   shows "(\<Sum>i\<ge>0. seq i) = upper_sum (\<lambda> i. seq i) 0"
   by simp
 
 corollary
   fixes seq :: "nat \<Rightarrow> nat" and a :: nat
   assumes seq_def: "\<And> i. seq i = (if i = 0 then a else 0)"
   shows "(\<Sum>i\<ge>0. seq i) = a"
   by (smt (verit) group_cancel.rule0 lessI lessThan_0 linorder_not_less seq_def sum.empty
       sum.lessThan_Suc_shift sum_bounded)
 
 lemma bounded_sum_from:
   fixes seq :: "nat \<Rightarrow> nat" and n s :: nat
   assumes "\<forall>i>s. seq i = 0" and "n \<le> s"
   shows "(\<Sum>i\<ge>n. seq i) = (\<Sum>i=n..s. seq i)"
 proof -  
   have "\<And>i. i > (s - n) \<Longrightarrow> seq (i + n) = 0"
     using assms by (meson less_diff_conv2)
   then have "(\<Sum>i\<ge>n. seq i) = (\<Sum>i\<le>s-n. seq (i + n))"
     by (meson atMost_iff finite_atMost leI suminf_finite)
   also have "\<dots> = (\<Sum>i=n..s. seq i)"
   proof -
     have "\<And>na. (\<Sum>na\<le>na. seq (na + n)) = sum seq {0 + n..na + n}"
       by (metis (no_types) atLeast0AtMost sum.shift_bounds_cl_nat_ivl)
     then show ?thesis
       by (simp add: assms(2))
   qed
   finally show ?thesis .
 qed
 
 lemma split_suminf:
   fixes seq :: "nat \<Rightarrow> nat" and n :: nat
   assumes "eventually_zero seq"
   shows "(\<Sum>i. seq i) = (\<Sum>i<n. seq i) + (\<Sum>i\<ge>n. seq i)"
 proof -
   obtain s where s: "\<And>i. i\<ge>s \<longrightarrow> seq i = 0"
     using assms unfolding eventually_zero_char by presburger
   then have sum_s: "(\<Sum>i. seq i) = (\<Sum>i<s. seq i)"
     using sum_bounded by presburger
   show "(\<Sum>i. seq i) = (\<Sum>i<n. seq i) + (\<Sum>i\<ge>(n). seq i)"
   proof (cases "n \<ge> s")
     case True
     then have "(\<Sum>i\<ge>(n). seq i) = 0"
       using s by force
     moreover have "(\<Sum>i<n. seq i) = (\<Sum>i<s. seq i)"
       by (metis True dual_order.trans s sum_bounded sum_s)
     ultimately show ?thesis using sum_s by simp
   next
     case False
     have 0: "(\<Sum>i=n..s. seq i) = (\<Sum>i\<ge>n. seq i)"
       by (metis False bounded_sum_from le_eq_less_or_eq nle_le s)
     from False have "n \<le> s"
       by simp
     then have "(\<Sum>i<s. seq i) = (\<Sum>i<n. seq i) + (\<Sum>i=n..s. seq i)"
       by (metis add_cancel_left_right nat_le_iff_add s sum.atLeastLessThan_concat add_0 
           lessThan_atLeast0 sum.last_plus)
     then show ?thesis using 0 sum_s
       by presburger
   qed
 qed
 
 lemma dvd_suminf:
   fixes seq :: "nat \<Rightarrow> nat" and b :: nat
   assumes "eventually_zero seq" and "\<And>i. b dvd seq i"
   shows "b dvd (\<Sum>i. seq i)"
 proof -
   obtain s::nat where s: "i \<ge> s \<Longrightarrow> seq i = 0" for i
     using assms(1) eventually_zero_char by blast
   then have "(\<Sum>i. seq i) = (\<Sum>i<s. seq i)"
     using sum_bounded by blast
   moreover have "b dvd (\<Sum>i<s. seq i)"
     using assms(2) by (simp add: dvd_sum)
   ultimately show ?thesis by presburger
 qed
 
 lemma eventually_zero_shifted:
   assumes "eventually_zero seq"
   shows "eventually_zero (\<lambda> i. seq (i + n))"
   by (meson assms eventually_zero_char trans_le_add1)
 
 section\<open>Modular arithmetic\<close>
 text\<open>This section establishes a number of lemmas about modular arithmetic, including that modular
 division distributes over an ``infinite'' sum whose terms are eventually zero.\<close>
 
 lemma pmod_int_char:
   fixes a b d :: int
   shows "[a = b] (mod d) \<longleftrightarrow> (\<exists>(n::int). a = b + n*d)"
   by (metis cong_iff_lin cong_sym mult.commute)
 
 lemma equiv_conj_if:
   assumes "P \<Longrightarrow> Q" and "P \<Longrightarrow> R" and "Q \<Longrightarrow> R \<Longrightarrow> P"
   shows "P \<longleftrightarrow> Q \<and> R"
   using assms by auto
 
 lemma mod_successor_char:
   fixes k k' i b :: nat
   assumes "(b::nat) \<ge> 2"
   shows "[k = k'] (mod b^(Suc i)) \<longleftrightarrow> [k div b^i = k' div b^i] (mod b) \<and> [k = k'] (mod b^i)"
 proof (rule equiv_conj_if)
   assume kk'_cong: "[k = k'] (mod b ^ Suc i)"
   then show "[k div b^i = k' div b^i] (mod b)"
     by (smt (verit, ccfv_SIG) Groups.mult_ac(2) add_diff_cancel_right' cong_def div_mult_mod_eq
         mod_mult2_eq mod_mult_self4 mult_cancel1 power_Suc2)
   from kk'_cong show "[k = k'] (mod b ^ i)"
     using Cong.cong_dvd_modulus_nat
     by (meson Suc_n_not_le_n le_imp_power_dvd nat_le_linear)
 next
   assume "[k div b^i = k' div b^i] (mod b)"
   moreover assume "[k = k'] (mod b^i)"
   ultimately show "[k = k'] (mod b ^ Suc i)"
     by (metis (mono_tags, lifting) cong_def mod_mult2_eq power_Suc2)
 qed
 
 lemma mod_1:
   fixes k k' b :: nat
   shows "[k = k'] (mod b^0)"
   by simp
 
 lemma mod_distributes:
   fixes seq :: "nat \<Rightarrow> nat" and b :: nat
   assumes "\<exists>n. \<forall>i\<ge>n. seq i = 0"
   shows "[(\<Sum>i. seq i) = (\<Sum>i. seq i mod b)] (mod b)"
 proof -
   obtain n where n: "\<And>i. i\<ge>n \<longrightarrow> seq i = 0"
     using assms by presburger
   from n have "(\<Sum>i. seq i) = (\<Sum>i<n. seq i)"
     using sum_bounded by presburger
   moreover from n have "(\<Sum>i. seq i mod b) = (\<Sum>i<n. seq i mod b)"
     using sum_bounded by presburger
   ultimately show ?thesis
     unfolding cong_def
     by (metis mod_sum_eq)
 qed
 
 lemma another_mod_cancellation_int:
   fixes a b c d m :: int
   assumes "d > 0" and "[m = a + b] (mod c * d)" and "a div d = 0" and "d dvd b"
   shows "[m div d = b div d] (mod c)"
 proof (subst pmod_int_char)
   obtain k::int where k: "m = a + b + k*c*d"
     using pmod_int_char assms(2) by (metis mult.assoc)
   have "d dvd (b + k*c*d)" using \<open>d dvd b\<close>
     by simp
   from k have "m div d = (a + b + k*c*d) div d"
     by presburger
   also have "\<dots> = (b + k*c*d) div d"
     using \<open>a div d = 0\<close> \<open>d dvd (b + k*c*d)\<close>
     by fastforce
   also have "\<dots> = (b div d) + k*c"
     using \<open>d dvd b\<close> \<open>d > 0\<close> by auto
   finally show "\<exists>n. m div d = b div d + n * c"
     by blast
 qed
 
 lemma another_mod_cancellation:
   fixes a b c d m :: nat
   assumes "d > 0" and "[m = a + b] (mod c * d)" and "a div d = 0" and "d dvd b"
   shows "[m div d = b div d] (mod c)"
   by (smt (verit) another_mod_cancellation_int assms cong_int_iff of_nat_0 of_nat_0_less_iff
       of_nat_add of_nat_dvd_iff of_nat_mult zdiv_int)
 
 section\<open>Digits as sequence\<close>
 text\<open>Rules are introduced for computing the $i^{\text{th}}$ digit of a base-$b$ representation
 and the number of digits required to represent a given number. (The latter is essentially an integer
 version of the base-$b$ logarithm.) It is shown that the sum of the terms $d_i b^i$ converges to
 $m$ if $d_i$ is the $i^{\text{th}}$ digit $m$. It is shown that the sequence of digits defined is
 the unique sequence of digits less than $b$ with this property 
 
 Additionally, the \texttt{digits\_in\_base} locale is introduced, which specifies a single symbol
 @{term b} referring to a natural number greater than one (the base of the digits). Consequently
 this symbol is omitted from many of the following lemmas and definitions.
 \<close>
 
 locale digits_in_base =
   fixes b :: nat
   assumes b_gte_2: "b \<ge> 2"
 begin
 
 lemma b_facts [simp]:
   shows "b > 1" and "b > 0" and "b \<noteq> 1" and "b \<noteq> 0" and "1 mod b = 1" and "1 div b = 0"
   using b_gte_2 by force+
 
 text\<open>Definition based on @{cite ThreeDivides}.\<close>
 abbreviation ith_digit :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
 "ith_digit m i \<equiv> (m div b^i) mod b"
 
 lemma ith_digit_lt_base:
   fixes m i :: nat
   shows "0 \<le> ith_digit m i" and "ith_digit m i < b"
   apply (rule Nat.le0)
   using b_facts(2) mod_less_divisor by presburger
 
 definition num_digits :: "nat \<Rightarrow> nat"
   where "num_digits m = (LEAST i. m < b^i)"
 
 lemma num_digits_works:
   shows "m < b ^ (num_digits m)"
   by (metis LeastI One_nat_def b_facts(1) num_digits_def power_gt_expt)
 
 lemma num_digits_le:
   assumes "m < b^i"
   shows "num_digits m \<le> i"
   using assms num_digits_works[of m] Least_le num_digits_def
   by metis
 
 lemma num_digits_zero:
   fixes m :: nat
   assumes "num_digits m = 0"
   shows "m = 0"
   using num_digits_works[of m]
   unfolding assms
   by simp
 
 lemma num_digits_gt:
   assumes "m \<ge> b^i"
   shows "num_digits m > i"
   by (meson assms b_facts(2) dual_order.strict_trans2 nat_power_less_imp_less num_digits_works)
 
 lemma num_digits_eqI [intro]:
   assumes "m \<ge> b^i" and "m < b^(i+1)"
   shows "num_digits m = i + 1"
 proof -
   {
     fix j :: nat
     assume "j < i + 1"
     then have "m \<ge> b^j"
       by (metis Suc_eq_plus1 assms(1) b_facts(1) less_Suc_eq_le order_trans power_increasing_iff)
   }
   then show ?thesis
     using num_digits_works
     unfolding num_digits_def
     by (meson assms(2) leD linorder_neqE_nat not_less_Least)
 qed
 
 lemma num_digits_char:
   assumes "m \<ge> 1"
   shows "num_digits m = i + 1 \<longleftrightarrow> m \<ge> b^i \<and> m < b^(i+1)"
   by (metis add_diff_cancel_right' assms b_gte_2 ex_power_ivl1 num_digits_eqI)
 
 
 text\<open>Statement based on @{cite ThreeDivides}.\<close>
 lemma num_digits_recurrence:
   fixes m :: nat
   assumes "m \<ge> 1"
   shows "num_digits m = num_digits (m div b) + 1"
 proof -
   define nd where "nd = num_digits m"
   then have lb: "m \<ge> b^(nd-1)" and ub: "m < b^nd"
     using num_digits_char[OF assms]
      apply (metis assms diff_is_0_eq le_add_diff_inverse2 nat_le_linear power_0)
     using nd_def num_digits_works by presburger
   from ub have ub2: "m div b < b^(nd-1)"
     by (metis Suc_eq_plus1 add.commute add_diff_inverse_nat assms less_mult_imp_div_less less_one
         linorder_not_less mult.commute power.simps(2) power_0)
   from lb have lb2: "m div b \<ge> b^(nd - 1) div b"
     using div_le_mono by presburger
   show ?thesis
   proof (cases "m \<ge> b")
     assume "m \<ge> b"
     then have "nd \<ge> 2"
       unfolding nd_def
       by (metis One_nat_def assms less_2_cases_iff linorder_not_le nd_def power_0 power_one_right
           ub)
     then have "m div b \<ge> b^(nd-2)"
       using lb2
       by (smt (verit) One_nat_def add_le_imp_le_diff b_facts(4) diff_diff_left le_add_diff_inverse2
           nonzero_mult_div_cancel_left numeral_2_eq_2 plus_1_eq_Suc power_add power_commutes
           power_one_right)
     then show ?thesis
       using ub2 num_digits_char assms nd_def
       by (smt (verit) \<open>2 \<le> nd\<close> add_diff_cancel_right' add_leD2 add_le_imp_le_diff diff_diff_left
           eq_diff_iff le_add2 nat_1_add_1 num_digits_eqI)
   next
     assume "\<not> b \<le> m"
     then have "m < b"
       by simp
     then have "num_digits m = 1"
       using assms
       by (metis One_nat_def Suc_eq_plus1 num_digits_char power_0 power_one_right)
     from \<open>m < b\<close> have "m div b = 0"
       using div_less by presburger
     then have "num_digits (m div b) = 0"
       using Least_eq_0 num_digits_def by presburger
     show ?thesis
       using \<open>num_digits (m div b) = 0\<close> \<open>num_digits m = 1\<close> by presburger
   qed
 qed
 
 lemma num_digits_zero_2 [simp]: "num_digits 0 = 0"
   by (simp add: num_digits_def)
 
 end (* digits_in_base *)
 
 locale base_10
 begin
 text\<open>As a sanity check, the number of digits in base ten is computed for several natural numbers.\<close>
 
 sublocale digits_in_base 10
   by (unfold_locales, simp)
 
 corollary
   shows "num_digits 0 = 0"
         and "num_digits 1 = 1"
         and "num_digits 9 = 1"
         and "num_digits 10 = 2"
         and "num_digits 99 = 2"
         and "num_digits 100 = 3"
   by (simp_all add: num_digits_recurrence)
 
 end (* base_10 *)
 
 context digits_in_base
 begin
 
 lemma high_digits_zero_helper:
   fixes m i :: nat
   shows "i < num_digits m \<or> ith_digit m i = 0"
 proof (cases "i < num_digits m")
   case True
   then show ?thesis by meson
 next
   case False
   then have "i \<ge> num_digits m" by force
   then have "m < b^i"
     by (meson b_facts(1) num_digits_works order_less_le_trans power_increasing_iff)
   then show ?thesis
     by simp
 qed
 
 lemma high_digits_zero:
   fixes m i :: nat
   assumes "i \<ge> num_digits m"
   shows "ith_digit m i = 0"
   using high_digits_zero_helper assms leD by blast
 
 lemma digit_expansion_bound:
   fixes i :: nat and A :: "nat \<Rightarrow> nat"
   assumes "\<And>j. A j < b"
   shows "(\<Sum>j<i. A j * b^j) < b^i"
 proof (induct i)
   case (Suc i)
   show ?case
   proof (subst Set_Interval.comm_monoid_add_class.sum.lessThan_Suc)
     have "A i * b^i \<le> (b-1) * b^i" using assms
       by (metis One_nat_def Suc_pred b_facts(2) le_simps(2) mult_le_mono1)
     then have "(\<Sum>j<i. A j * b ^ j) + A i * b ^ i < b^i + (b-1) * b^i"
       using Suc add_less_le_mono by blast
     also have "\<dots> \<le> b ^ Suc i"
       using assms(1) mult_eq_if by auto
     finally show "(\<Sum>j<i. A j * b ^ j) + A i * b ^ i < b ^ Suc i" .
   qed
 qed simp
 
 text\<open>Statement and proof based on @{cite ThreeDivides}.\<close>
 lemma num_digits_suc:
   fixes n m :: nat
   assumes "Suc n = num_digits m"
   shows "n = num_digits (m div b)"
   using num_digits_recurrence assms
   by (metis One_nat_def Suc_eq_plus1 Suc_le_lessD le_add2 linorder_not_less num_digits_le
       old.nat.inject power_0)
 
 text\<open>Proof (and to some extent statement) based on @{cite ThreeDivides}.\<close>
 lemma digit_expansion_bounded_seq:
   fixes m :: nat
   shows "m = (\<Sum>j<num_digits m. ith_digit m j * b^j)"
 proof (induct "num_digits m" arbitrary: m)
   case 0
   then show "m = (\<Sum>j<num_digits m. ith_digit m j * b^j)"
     using lessThan_0 sum.empty num_digits_zero by metis
 next
   case (Suc nd m)
   assume nd: "Suc nd = num_digits m"
   define c where "c = m mod b"
   then have mexp: "m = b * (m div b) + c" and "c < b"
     by force+
   show "m = (\<Sum>j<num_digits m. ith_digit m j * b^j)"
   proof -
     have "nd = num_digits (m div b)"
       using num_digits_suc[OF nd] .
     with Suc have "m div b = (\<Sum>j<nd. ith_digit (m div b) j * b^j)"
       by presburger
     with mexp have "m = b * (\<Sum>j<nd. ith_digit (m div b) j * b^j) + c"
       by presburger
     also have "\<dots> = (\<Sum>j<nd. ith_digit (m div b) j * b^Suc j) + c"
       by (simp add: sum_distrib_left mult.assoc mult.commute)
     also have "\<dots> = (\<Sum>j<nd. ith_digit m (Suc j) * b^Suc j) + c"
       by (simp add: div_mult2_eq)
     also have "\<dots> = (\<Sum>j=Suc 0..<Suc nd. ith_digit m j * b^j) + ith_digit m 0"
       unfolding sum.shift_bounds_Suc_ivl c_def atLeast0LessThan
       by simp
     also have "\<dots> = (\<Sum>j<Suc nd. ith_digit m j * b^j)"
       by (smt (verit) One_nat_def Zero_not_Suc add.commute add_diff_cancel_right' atLeast0LessThan
           calculation div_by_Suc_0 mult.commute nonzero_mult_div_cancel_left power_0
           sum.lessThan_Suc_shift sum.shift_bounds_Suc_ivl)
     also note nd
     finally show "m = (\<Sum>j<num_digits m. ith_digit m j * b^j)" .
   qed
 qed
 
 text\<open>A natural number can be obtained from knowing all its base-$b$ digits by the formula
 $\sum_j d_j b^j$.\<close>
 theorem digit_expansion_seq:
   fixes m :: nat
   shows "m = (\<Sum>j. ith_digit m j * b^j)"
   using digit_expansion_bounded_seq[of m] high_digits_zero[of m] sum_bounded mult_0
   by (metis (no_types, lifting))
 
 lemma lower_terms:
   fixes a c i :: nat
   assumes "c < b^i" and "a < b"
   shows "ith_digit (a * b^i + c) i = a"
   using assms by force
 
 lemma upper_terms:
   fixes A a i :: nat
   assumes "b*b^i dvd A" and "a < b"
   shows "ith_digit (A + a * b^i) i = a"
   using assms by force
 
 lemma current_term:
   fixes A a c i :: nat
   assumes "b*b^i dvd A" and "c < b^i" and "a < b"
   shows "ith_digit (A + a*b^i + c) i = a"
 proof -
   have "(A + a*b^i + c) div b^i mod b = (a*b^i + c) div b^i mod b"
     using assms(1)
     by (metis (no_types, lifting) div_eq_0_iff add_cancel_right_right
         assms(2) assms(3) div_plus_div_distrib_dvd_left dvd_add_times_triv_right_iff
         dvd_mult_right lower_terms upper_terms)
   also have "\<dots> = a"
     using assms by force
   finally show "(A + a*b^i + c) div b^i mod b = a" .
 qed
 
 text\<open>Given that
 \begin{equation*}
 m = \sum_i d_i b^i
 \end{equation*}
 where the $d_i$ are all natural numbers less than $b$, it follows that $d_j$ is the $j^{\text{th}}$
 digit of $m$.\<close>
 theorem seq_uniqueness:
   fixes m j :: nat and D :: "nat \<Rightarrow> nat"
   assumes "eventually_zero D" and "m = (\<Sum>i. D i * b^i)" and "\<And>i. D i < b"
   shows "D j = ith_digit m j"
 proof -
   have "eventually_zero (ith_digit m)"
     using high_digits_zero
     by (meson eventually_zero_char)
   then have term_eventually_zero: "eventually_zero (\<lambda> i. D i * b^i)"
     using product_seq_eventually_zero assms(1) by auto
   then have shifted_term_eventually_zero:
     "eventually_zero (\<lambda> i. D (i + n) * b ^ (i + n))" for n
     using eventually_zero_shifted
     by blast
   note \<open>m = (\<Sum>i. D i * b^i)\<close>
   then have two_sums: "m = (\<Sum>i<Suc j. D i * b^i) + (\<Sum>i\<ge>Suc j. D i * b^i)"
     using split_suminf[OF term_eventually_zero] by presburger
   have "i\<ge>Suc j \<Longrightarrow> b*b^j dvd (D i * b^i)" for i
     by (metis dvd_mult2 le_imp_power_dvd mult.commute power_Suc)
   then have "b*b^j dvd (\<Sum>i\<ge>Suc j. D i * b^i)"
     using dvd_suminf shifted_term_eventually_zero le_add2
     by presburger
   with two_sums have "[m = (\<Sum>i<Suc j. D i * b^i)] (mod b*b^j)"
     by (meson cong_def Cong.cong_dvd_modulus_nat mod_add_self2)
   then have one_sum: "[m = (\<Sum>i<j. D i * b^i) + D j * b^j] (mod b*b^j)"
     by simp
   have "(\<Sum>i<j. D i * b^i) < b^j"
     using assms(3) digit_expansion_bound by blast
   with one_sum have "[m div b^j = (D j)] (mod b)"
     using another_mod_cancellation dual_order.strict_trans1
     unfolding cong_def
     by auto
   then show "D j = ith_digit m j"
     using assms(3) mod_less unfolding cong_def by presburger
 qed
 
 
 end (* digits_in_base *)
 
 section\<open>Little Endian notation\<close>
 text\<open>In this section we begin to define finite digit expansions. Ultimately we want to write digit
 expansions in ``big endian'' notation, by which we mean with the highest place digit on the left
 and the ones digit on the write, since this ordering is standard in informal mathematics. However,
 it is easier to first define ``little endian'' expansions with the ones digit on the left since that
 way the list indexing agrees with the sequence indexing used in the previous section (whenever both
 are defined).
 
 Notation, definitions, and lemmas in this section typically start with the prefix \texttt{LE} (for
 ``little endian'') to distinguish them from the big endian versions in the next section.
 \<close>
 
 fun LEeval_as_base ("_\<^bsub>LEbase _\<^esub>" [65, 65] 70)
   where "[] \<^bsub>LEbase b\<^esub> = 0"
   | "(d # d_list) \<^bsub>LEbase b\<^esub>  = d + b * (d_list\<^bsub>LEbase b\<^esub>)"
 
 corollary shows "[2, 4] \<^bsub>LEbase 5\<^esub> = (22::nat)"
   by simp
 
 lemma LEbase_one_digit [simp]: shows "[a::nat] \<^bsub>LEbase b\<^esub> = a"
   by simp
 
 lemma LEbase_two_digits [simp]: shows "[a\<^sub>0::nat, a\<^sub>1] \<^bsub>LEbase b\<^esub> = a\<^sub>0 + a\<^sub>1 * b"
   by simp
 
 lemma LEbase_three_digits [simp]: shows "[a\<^sub>0::nat, a\<^sub>1, a\<^sub>2] \<^bsub>LEbase b\<^esub> = a\<^sub>0 + a\<^sub>1*b + a\<^sub>2*b^2"
 proof -
   have "[a\<^sub>0::nat, a\<^sub>1, a\<^sub>2] \<^bsub>LEbase b\<^esub> = a\<^sub>0 + ([a\<^sub>1, a\<^sub>2] \<^bsub>LEbase b\<^esub>) * b"
     by simp
   also have "\<dots> = a\<^sub>0 + (a\<^sub>1 + a\<^sub>2*b) * b"
     by simp
   also have "\<dots> = a\<^sub>0 + a\<^sub>1*b + a\<^sub>2*b^2"
     by (simp add: add_mult_distrib power2_eq_square)
   finally show ?thesis .
 qed
 
 
 lemma LEbase_closed_form:
 shows "(A :: nat list) \<^bsub>LEbase b\<^esub> = (\<Sum>i < length A . A!i * b^i)"
 proof (induct A)
   case Nil
   show ?case
     by simp
 next
   case (Cons a A)
   show ?case
   proof -
     have "(a # A)\<^bsub>LEbase b\<^esub> = a + b * (A\<^bsub>LEbase b\<^esub>)"
       by simp
     also have "\<dots> = a + b * (\<Sum>i<length A. A!i * b ^ i)"
       using Cons by simp
     also have "\<dots> = a + (\<Sum>i<length A. b * A!i * b^i)"
       by (smt (verit) mult.assoc sum.cong sum_distrib_left)
     also have "\<dots> = a + (\<Sum>i<length A. A!i * b^(i+1))"
       by (simp add: mult.assoc mult.left_commute)
     also have "\<dots> = a + (\<Sum>i<length A. (a#A)!(i+1) * b^(i+1))"
       by force
     also have "\<dots> = (a#A)!0 * b^0 + (\<Sum>i<length A. (a#A)!(Suc i) * b^(Suc i))"
       by force
     also have "\<dots> = (\<Sum>i<length (a # A). (a#A)!i * b^i)"
       using sum.lessThan_Suc_shift
       by (smt (verit) length_Cons sum.cong)
     finally show ?thesis .
   qed
 qed
 
 lemma LEbase_concatenate:
   fixes A D :: "nat list" and b :: nat
   shows "(A @ D)\<^bsub>LEbase b\<^esub> = (A\<^bsub>LEbase b\<^esub>) + b^(length A) * (D\<^bsub>LEbase b\<^esub>)"
 proof (induct A)
   case Nil
   show ?case
     by simp
 next
   case (Cons a A)
   show ?case
   proof -
     have "((a # A) @ D)\<^bsub>LEbase b\<^esub> = ((a # (A @ D)) \<^bsub>LEbase b\<^esub>)"
       by simp
     also have "\<dots> = a + b * ((A @ D) \<^bsub>LEbase b\<^esub>)"
       by simp
     also have "\<dots> = a + b * (A\<^bsub>LEbase b\<^esub> + b ^ length A * (D\<^bsub>LEbase b\<^esub>))"
       unfolding Cons by rule
     also have "\<dots> = (a + b * (A\<^bsub>LEbase b\<^esub>)) + b ^ (length (a#A)) * (D\<^bsub>LEbase b\<^esub>)"
       by (simp add: distrib_left)
     also have "\<dots> = ((a # A)\<^bsub>LEbase b\<^esub>) + b ^ length (a # A) * (D\<^bsub>LEbase b\<^esub>)"
       by simp
     finally show ?thesis .
   qed
 qed
 
 context digits_in_base
 begin
 
 definition LEdigits :: "nat \<Rightarrow> nat list" where
 "LEdigits m = [ith_digit m i. i \<leftarrow> [0..<(num_digits m)]]"
 
 lemma length_is_num_digits:
   fixes m :: nat
   shows "length (LEdigits m) = num_digits m"
   unfolding LEdigits_def by simp
 
 lemma ith_list_element [simp]:
   assumes "(i::nat) < length (LEdigits m)"
   shows "(LEdigits m) ! i = ith_digit m i"
   using assms
   by (simp add: length_is_num_digits LEdigits_def)
 
 lemma LEbase_infinite_sum:
   fixes m :: nat
   shows "(\<Sum>i. ith_digit m i  * b^i) = (LEdigits m)\<^bsub>LEbase b\<^esub>"
 proof (unfold LEdigits_def LEbase_closed_form)
   have
     "(\<Sum>i<length (map (ith_digit m) [0..<num_digits m]).
                                                   map (ith_digit m) [0..<num_digits m] ! i * b ^ i)
      = (\<Sum>i<num_digits m. map (ith_digit m) [0..<num_digits m] ! i * b ^ i)"
     using LEdigits_def length_is_num_digits by presburger
   also have "\<dots>= (\<Sum>i<num_digits m. ith_digit m i * b^i)"
     by force
   also have "\<dots>=(\<Sum>i. ith_digit m i * b ^ i)" 
     using sum_bounded high_digits_zero mult_0
     by (metis (no_types, lifting))
   finally show
     "(\<Sum>i. ith_digit m i * b ^ i) =
      (\<Sum>i<length (map (ith_digit m) [0..<num_digits m]). map (ith_digit m) [0..<num_digits m] ! i * b ^ i)"
     by presburger
 qed
 
 lemma digit_expansion_LElist:
   fixes m :: nat
   shows "(LEdigits m)\<^bsub>LEbase b\<^esub> = m"
   using digit_expansion_seq LEbase_infinite_sum
   by presburger
 
 lemma LElist_uniqueness:
   fixes D :: "nat list"
   assumes "\<forall> i < length D. D!i < b" and "D = [] \<or> last D \<noteq> 0"
   shows "LEdigits (D\<^bsub>LEbase b\<^esub>) = D"
 proof -
   define seq where "seq i = (if i < length D then D!i else 0)" for i
   then have seq_bound: "i \<ge> length D \<Longrightarrow> seq i = 0" for i
     by simp
   then have seq_eventually_zero: "eventually_zero seq"
     using eventually_zero_char by blast
   have ith_digit_connection: "i < num_digits m \<Longrightarrow> (LEdigits m)!i = ith_digit m i" for m i
     unfolding LEdigits_def by simp
   let ?m = "D\<^bsub>LEbase b\<^esub>"
   have length_bounded_sum: "D\<^bsub>LEbase b\<^esub> = (\<Sum>i<length D. seq i * b^i)"
     unfolding LEbase_closed_form seq_def by force
   also have "\<dots> = (\<Sum>i. seq i * b^i)"
     using seq_bound sum_bounded by fastforce
   finally have seq_is_digits: "seq j = ith_digit ?m j" for j
     using seq_uniqueness[OF seq_eventually_zero] assms(1)
     by (metis b_facts(2) seq_def)
   then have "i < length D \<Longrightarrow> ith_digit ?m i = D!i" for i
     using seq_def by presburger
   then have "i < length D \<Longrightarrow> i < num_digits ?m \<Longrightarrow> (LEdigits ?m)!i = D!i" for i
     using ith_digit_connection[of i ?m] by presburger
   moreover have "length D = num_digits ?m"
   proof (rule le_antisym)
     show "length D \<le> num_digits ?m"
     proof (cases "D = []")
       assume "D \<noteq> []"
       then have "last D \<noteq> 0" using assms(2) by auto
       then have "last D \<ge> 1" by simp
       have "?m \<ge> seq (length D - 1) * b^(length D - 1)"
         using length_bounded_sum
-        by (smt (z3) One_nat_def Suc_pred diff_is_0_eq diff_le_self dual_order.strict_trans1 le_add2
-            linorder_le_less_linear mult.right_neutral mult_cancel1 seq_def sum.lessThan_Suc
-            zero_less_diff)
+        by (metis b_facts(2) less_eq_div_iff_mult_less_eq mod_less_eq_dividend seq_is_digits zero_less_power)
       then have "?m \<ge> (last D) * b^(length D - 1)"
         by (simp add: \<open>D \<noteq> []\<close> last_conv_nth seq_def)
       with \<open>last D \<ge> 1\<close> have "?m \<ge> b^(length D - 1)"
         by (metis le_trans mult_1 mult_le_mono1)
       then show "num_digits ?m \<ge> length D"
         using num_digits_gt not_less_eq
         by (metis One_nat_def Suc_pred \<open>D \<noteq> []\<close> bot_nat_0.extremum_uniqueI leI length_0_conv)
     qed simp
     show "num_digits ?m \<le> length D"
       by (metis length_bounded_sum seq_is_digits digit_expansion_bound ith_digit_lt_base(2)
           num_digits_le)
   qed
   ultimately show ?thesis
     by (simp add: length_is_num_digits list_eq_iff_nth_eq)
 qed
 
 lemma LE_digits_zero [simp]: "LEdigits 0 = []"
   using LEdigits_def by auto
 
 lemma LE_units_digit [simp]:
   assumes "(m::nat) \<in> {1..<b}"
   shows "LEdigits m = [m]"
   using assms LEdigits_def num_digits_recurrence by auto
 
 end (* digits_in_base *)
 
 section\<open>Big Endian notation\<close>
 text\<open>In this section the desired representation of natural numbers, as finite lists of digits
 with the highest place on the left, is finally realized.\<close>
 
 definition BEeval_as_base ("_\<^bsub>base _\<^esub>" [65, 65] 70)
   where [simp]: "D\<^bsub>base b\<^esub> = (rev D)\<^bsub>LEbase b\<^esub>"
 
 corollary shows "[4, 2]\<^bsub>base 5\<^esub> = (22::nat)"
   by simp
 
 lemma BEbase_one_digit [simp]: shows "[a::nat] \<^bsub>base b\<^esub> = a"
   by simp
 
 lemma BEbase_two_digits [simp]: shows "[a\<^sub>1::nat, a\<^sub>0] \<^bsub>base b\<^esub> = a\<^sub>1*b + a\<^sub>0"
   by simp
 
 lemma BEbase_three_digits [simp]: shows "[a\<^sub>2::nat, a\<^sub>1, a\<^sub>0] \<^bsub>base b\<^esub> = a\<^sub>2*b^2 + a\<^sub>1*b + a\<^sub>0"
 proof -
   have "b * (a\<^sub>1 + b * a\<^sub>2) = a\<^sub>2 * b\<^sup>2 + a\<^sub>1 * b"
     apply (subst mult.commute)
     unfolding add_mult_distrib power2_eq_square
     by simp
   then show ?thesis by simp
 qed
 
 lemma BEbase_closed_form:
   fixes A :: "nat list" and b :: nat
   shows "A\<^bsub>base b\<^esub> = (\<Sum>i<length A. A!i * b^(length A - Suc i))"
   unfolding LEbase_closed_form BEeval_as_base_def
   apply (subst sum.nat_diff_reindex[symmetric])
   apply (subst length_rev)
   using rev_nth
   by (metis (no_types, lifting) length_rev lessThan_iff rev_rev_ident sum.cong)
 
 lemma BEbase_concatenate:
   fixes A D :: "nat list" and b :: nat
   shows "(A @ D) \<^bsub>base b\<^esub> = (A\<^bsub>base b\<^esub>)*b^(length D) + (D\<^bsub>base b\<^esub>)"
   using LEbase_concatenate by simp
 
 context digits_in_base
 begin
 
 definition digits :: "nat \<Rightarrow> nat list" where
 "digits m = rev (LEdigits m)"
 
 lemma length_is_num_digits_2:
   fixes m :: nat
   shows "length (digits m) = num_digits m"
   using length_is_num_digits digits_def by simp
 
 lemma LE_BE_equivalence:
   fixes m :: nat
   shows "(digits m) \<^bsub>base b\<^esub> = (LEdigits m) \<^bsub>LEbase b\<^esub>"
   by (simp add: digits_def)
 
 lemma BEbase_infinite_sum:
   fixes m :: nat
   shows "(\<Sum>i. ith_digit m i * b^i) = (digits m)\<^bsub>base b\<^esub>"
   using LE_BE_equivalence LEbase_infinite_sum by presburger
 
 text\<open>Every natural number can be represented in base $b$, specifically by the digits sequence
 defined earlier.\<close>
 theorem digit_expansion_list:
   fixes m :: nat
   shows "(digits m)\<^bsub>base b\<^esub> = m"
   using LE_BE_equivalence digit_expansion_LElist by auto
 
 text\<open>If two natural numbers have the same base-$b$ representation, then they are equal.\<close>
 lemma digits_cancellation:
   fixes k m :: nat
   assumes "digits k = digits m"
   shows "k = m"
   by (metis assms digit_expansion_list)
 
 text\<open>Suppose we have a finite (possibly empty) sequence $D_1, \dotsc, D_n$ of natural numbers such
 that $0 \le D_i < b$ for all $i$ and such that $D_1$, if it exists, is nonzero. Then this sequence
 is the base-$b$ representation for $\sum_i D_i b^{n-i}$.\<close>
 theorem list_uniqueness:
   fixes D :: "nat list"
   assumes "\<forall> d \<in> set D. d < b" and "D = [] \<or> D!0 \<noteq> 0"
   shows "digits (D\<^bsub>base b\<^esub>) = D"
   unfolding digits_def BEeval_as_base_def
   using LElist_uniqueness
   by (metis Nil_is_rev_conv One_nat_def assms last_conv_nth length_greater_0_conv
       nth_mem rev_nth rev_swap set_rev)
 
 text\<open>We now prove some simplification rules (including a reccurrence relation) to make it easier for
 Isabelle/HOL to compute the base-$b$ representation of a natural number.\<close>
 
 text\<open>The base-b representation of $0$ is empty, at least following the conventions of this theory
 file.\<close>
 lemma digits_zero [simp]:
   shows "digits 0 = []"
   by (simp add: digits_def)
 
 text\<open>If $0 < m < b$, then the base-$b$ representation of $m$ consists of a single digit, namely
 $m$ itself.\<close>
 lemma single_digit_number [simp]:
   assumes "m \<in> {0<..<b}"
   shows "digits m = [m]"
   using assms digits_def by auto
 
 text\<open>For all $m \ge b$, the base-$b$ representation of $m$ consists of the base-$b$ representation
 of $\lfloor m / b \rfloor$ followed by (as the last digit) the remainder of $m$ when divided by
 $b$.\<close>
 lemma digits_recurrence [simp]:
   assumes "m \<ge> b"
   shows "digits m = (digits (m div b)) @ [m mod b]"
 proof -
   have "num_digits m > 1"
     using assms by (simp add: num_digits_gt)
   then have "num_digits m > 0"
     by simp
   then have "num_digits (m div b) = num_digits m - 1"
     by (metis Suc_diff_1 num_digits_suc)
   have "k > 0 \<Longrightarrow> last (rev [0..<k]) = 0" for k::nat
     by (simp add: last_rev)
   have "[Suc 0..<Suc k] = [Suc i. i \<leftarrow> [0..<k]]" for k::nat
     using map_Suc_upt by presburger
   then have "rev [Suc 0..<Suc k] = [Suc i. i \<leftarrow> rev [0..<k]]" for k::nat
     by (metis rev_map)
   then have "[f i. i \<leftarrow> rev [Suc 0..<Suc k]] = [f (Suc i). i \<leftarrow> rev [0..<k]]" for f and k::nat
     by simp
   then have map_shift: "k > 0 \<Longrightarrow> [f i. i \<leftarrow> rev [1..<k]] = [f (Suc i). i \<leftarrow> rev [0..<(k-1)]]"
                        for f and k::nat
     by (metis One_nat_def Suc_diff_1)
   have digit_down: "ith_digit m (Suc i) = ith_digit (m div b) i" for i::nat
     by (simp add: div_mult2_eq)
   have "digits m = rev [ith_digit m i. i \<leftarrow> [0..<num_digits m]]"
     using LEdigits_def digits_def by presburger
   also have "\<dots> = [ith_digit m i. i \<leftarrow> rev [0..<num_digits m]]"
     using rev_map by blast
   also have "\<dots> = [ith_digit m i. i \<leftarrow> butlast (rev [0..<num_digits m])] @
                   [ith_digit m (last (rev [0..<num_digits m]))]"
     by (metis (no_types, lifting) Nil_is_map_conv Nil_is_rev_conv \<open>1 < num_digits m\<close>
         bot_nat_0.extremum_strict dual_order.strict_trans1 last_map map_butlast snoc_eq_iff_butlast
         upt_eq_Nil_conv)
   also have "\<dots> = [ith_digit m i. i \<leftarrow> rev [1..<num_digits m]] @
                   [ith_digit m 0]"
     using \<open>1 < num_digits m\<close> \<open>\<And>k. 0 < k \<Longrightarrow> last (rev [0..<k]) = 0\<close> by fastforce
   also have "\<dots> = [ith_digit m (Suc i). i \<leftarrow> rev [0..<(num_digits m - 1)]] @
                   [ith_digit m 0]"
     using map_shift[OF \<open>num_digits m > 0\<close>] by blast
   also have "\<dots> = [ith_digit (m div b) i. i \<leftarrow> rev [0..<(num_digits m - 1)]] @
                   [ith_digit m 0]"
     using digit_down by presburger
   also have "\<dots> = (digits (m div b)) @ [ith_digit m 0]"
     by (simp add: LEdigits_def \<open>num_digits (m div b) = num_digits m - 1\<close> digits_def rev_map)
   also have "\<dots> = (digits (m div b)) @ [m mod b]"
     by simp
   finally show ?thesis .
 qed
 
 end (* digits_in_base *)
 
 section\<open>Exercises\<close>
 text\<open>This section contains demonstrations of how to denote certain facts with the notation of the
 previous sections, and how to quickly prove those facts using the lemmas and theorems above.
 \<close>
 
 text\<open>The base-5 representation of $22$ is $42_5$.\<close>
 corollary "digits_in_base.digits 5 22 = [4, 2]"
 proof -
   interpret digits_in_base 5
     by (simp add: digits_in_base.intro)
   show "digits 22 = [4, 2]"
     by simp
 qed
 
 text\<open>A different proof of the same statement.\<close>
 corollary "digits_in_base.digits 5 22 = [4, 2]"
 proof -
   interpret digits_in_base 5
     by (simp add: digits_in_base.intro)
   have "[4, 2]\<^bsub>base 5\<^esub> = (22::nat)"
     by simp
   have "d \<in> set [4, 2] \<Longrightarrow> d < 5" for d::nat
     by fastforce
   then show ?thesis
     using list_uniqueness
     by (metis \<open>[4, 2]\<^bsub>base 5\<^esub> = 22\<close> nth_Cons_0 numeral_2_eq_2 zero_neq_numeral)
 qed
 
 end
diff --git a/thys/FOL_Seq_Calc1/Sequent2.thy b/thys/FOL_Seq_Calc1/Sequent2.thy
--- a/thys/FOL_Seq_Calc1/Sequent2.thy
+++ b/thys/FOL_Seq_Calc1/Sequent2.thy
@@ -1,44 +1,44 @@
 theory Sequent2 imports Sequent begin
 
 section \<open>Completeness Revisited\<close>
 
 lemma \<open>\<exists>p. q = compl p\<close>
   by (metis compl.simps(1))
 
 definition compl' where
   \<open>compl' = (\<lambda>q. (SOME p. q = compl p))\<close>
 
 lemma comp'_sem:
   \<open>eval e f g (compl' p) \<longleftrightarrow> \<not> eval e f g p\<close>
   by (smt compl'_def compl.simps(1) compl eval.simps(7) someI_ex)
 
 lemma comp'_sem_list: \<open>list_ex (\<lambda>p. \<not> eval e f g p) (map compl' ps) \<longleftrightarrow> list_ex (eval e f g) ps\<close>
   by (induct ps) (use comp'_sem in auto)
 
 theorem SC_completeness':
   fixes ps :: \<open>(nat, nat) form list\<close>
   assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_ex (eval e f g) (p # ps)\<close>
   shows \<open>\<turnstile> p # ps\<close>
 proof -
   define ps' where \<open>ps' = map compl' ps\<close>
   then have \<open>ps = map compl ps'\<close>
-    by (induct ps arbitrary: ps') (simp, smt compl'_def compl.simps(1) list.simps(9) someI_ex)
+    by (induct ps arbitrary: ps') (simp, smt (verit) compl'_def compl.simps(1) list.simps(9) someI_ex)
   from assms have \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. (list_ex (eval e f g) ps) \<or> eval e f g p\<close>
     by auto
   then have \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. (list_ex (\<lambda>p. \<not> eval e f g p) ps') \<or> eval e f g p\<close>
     unfolding ps'_def using comp'_sem_list by blast
   then have \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_all (eval e f g) ps' \<longrightarrow> eval e f g p\<close>
     by (metis Ball_set Bex_set)
   then have \<open>\<turnstile> p # map compl ps'\<close>
     using SC_completeness by blast
   then show ?thesis
     using \<open>ps = map compl ps'\<close> by auto
 qed
 
 corollary
   fixes ps :: \<open>(nat, nat) form list\<close>
   assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_ex (eval e f g) ps\<close>
   shows \<open>\<turnstile> ps\<close>
   using assms SC_completeness' by (cases ps) auto
 
 end
diff --git a/thys/GaleStewart_Games/AlternatingLists.thy b/thys/GaleStewart_Games/AlternatingLists.thy
--- a/thys/GaleStewart_Games/AlternatingLists.thy
+++ b/thys/GaleStewart_Games/AlternatingLists.thy
@@ -1,144 +1,144 @@
 section \<open> Alternating lists \<close>
 
 text \<open>In lists where even and odd elements play different roles, it helps to define functions to
       take out the even elements. We defined the function (l)alternate on (coinductive) lists to
       do exactly this, and define certain properties.\<close>
 
 theory AlternatingLists
   imports MoreCoinductiveList2 (* for notation and lemmas like infinite_small_llength *)
 begin
 
 text \<open>The functions ``alternate" and ``lalternate" are our main workhorses:
       they take every other item, so every item at even indices.\<close>
 
 fun alternate where
   "alternate Nil = Nil" |
   "alternate (Cons x xs) = Cons x (alternate (tl xs))"
 
 text \<open>``lalternate" takes every other item from a co-inductive list.\<close>
 primcorec lalternate :: "'a llist \<Rightarrow> 'a llist"
   where
     "lalternate xs = (case xs of LNil \<Rightarrow> LNil |
                                  (LCons x xs) \<Rightarrow> LCons x (lalternate (ltl xs)))"
 
 lemma lalternate_ltake:
   "ltake (enat n) (lalternate xs) = lalternate (ltake (2*n) xs)"
 proof(induct n arbitrary:xs)
   case 0
   then show ?case by (metis LNil_eq_ltake_iff enat_defs(1) lalternate.ctr(1) lnull_def mult_zero_right)
 next
   case (Suc n)
   hence lt:"ltake (enat n) (lalternate (ltl (ltl xs))) = lalternate (ltake (enat (2 * n)) (ltl (ltl xs)))".
   show ?case
   proof(cases "lalternate xs")
     case LNil
     then show ?thesis by(metis lalternate.disc(2) lnull_def ltake_LNil)
   next
     case (LCons x21 x22)
     thus ?thesis unfolding ltake_ltl mult_Suc_right add_2_eq_Suc
       using eSuc_enat lalternate.code lalternate.ctr(1) lhd_LCons_ltl llist.sel(1)
-      by (smt (z3) lt ltake_ltl llist.simps(3) llist.simps(5) ltake_eSuc_LCons)
+      by (smt (verit) lt ltake_ltl llist.simps(3) llist.simps(5) ltake_eSuc_LCons)
   qed
 qed
 
 lemma lalternate_llist_of[simp]:
   "lalternate (llist_of xs) = llist_of (alternate xs)"
 proof(induct "alternate xs" arbitrary:xs)
   case Nil
   then show ?case
     by (metis alternate.elims lalternate.ctr(1) list.simps(3) llist_of.simps(1) lnull_llist_of)
 next
   case (Cons a xs)
   then show ?case by(cases xs,auto simp: lalternate.ctr)
 qed
 
 lemma lalternate_finite_helper: (* The other direction is proved later, added as SIMP rule *)
   assumes "lfinite (lalternate xs)"
   shows "lfinite xs"
 using assms proof(induct "lalternate xs" arbitrary:xs rule:lfinite_induct)
   case LNil
   then show ?case unfolding lalternate.code[of xs] by(cases xs;auto)
 next
   case (LCons xs)
   then show ?case unfolding lalternate.code[of xs] by(cases "xs";cases "ltl xs";auto)
 qed
 
 lemma alternate_list_of: (* Note that this only holds for finite lists,
                     as the other direction is left undefined with arguments (not just undefined) *)
   assumes "lfinite xs"
   shows "alternate (list_of xs) = list_of (lalternate xs)"
   using assms by (metis lalternate_llist_of list_of_llist_of llist_of_list_of)
 
 lemma alternate_length:
   "length (alternate xs) = (1+length xs) div 2"
   by (induct xs rule:induct_list012;simp)
 
 lemma lalternate_llength:
   "llength (lalternate xs) * 2 = (1+llength xs) \<or> llength (lalternate xs) * 2 = llength xs"
 proof(cases "lfinite xs")
   case True
   let ?xs = "list_of xs"
   have "length (alternate ?xs) = (1+length ?xs) div 2" using alternate_length by auto
   hence "length (alternate ?xs) * 2 = (1+length ?xs) \<or> length (alternate ?xs) * 2 = length ?xs"
     by auto
   then show ?thesis using alternate_list_of[OF True] lalternate_llist_of True
     length_list_of_conv_the_enat[OF True] llist_of_list_of[OF True]
     by (metis llength_llist_of numeral_One of_nat_eq_enat of_nat_mult of_nat_numeral plus_enat_simps(1))
 next
   case False
   have "\<not> lfinite (lalternate xs)" using False lalternate_finite_helper by auto
   hence l1:"llength (lalternate xs) = \<infinity>" by(rule not_lfinite_llength)
   from False have l2:"llength xs = \<infinity>" using not_lfinite_llength by auto
   show ?thesis using l1 l2 by (simp add: mult_2_right)
 qed
 
 lemma lalternate_finite[simp]:
   shows "lfinite (lalternate xs) = lfinite xs"
 proof(cases "lfinite xs")
   case True
   then show ?thesis
   proof(cases "lfinite (lalternate xs)")
     case False
     hence False using not_lfinite_llength[OF False] True[unfolded lfinite_conv_llength_enat]
                       lalternate_llength[of xs]
                 by (auto simp:one_enat_def numeral_eq_enat)
     thus ?thesis by metis
   qed auto
 next
   case False
   then show ?thesis using lalternate_finite_helper by blast
 qed
 
 lemma nth_alternate:
   assumes "2*n < length xs"
   shows "alternate xs ! n = xs ! (2 * n)"
   using assms proof (induct xs arbitrary:n rule:induct_list012)
   case (3 x y zs)
   then show ?case proof(cases n)
     case (Suc nat)
     show ?thesis using "3.hyps"(1) "3.prems" Suc by force
   qed simp
 qed auto
 
 lemma lnth_lalternate:
   assumes "2*n < llength xs"
   shows "lalternate xs $ n = xs $ (2 * n)"
 proof -
   let ?xs = "ltake (2*Suc n) xs"
   have "lalternate ?xs $ n = ?xs $ (2 * n)"
     using assms alternate_list_of[of "ltake (2*Suc n) xs"] nth_alternate[of n "list_of ?xs"]
-    by (smt (z3) Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) infinite_small_llength lalternate_ltake length_list_of lessI llength_eq_enat_lfiniteD llength_ltake' ltake_all not_less nth_list_of numeral_eq_enat the_enat.simps times_enat_simps(1))
+    by (smt (verit) Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) infinite_small_llength lalternate_ltake length_list_of lessI llength_eq_enat_lfiniteD llength_ltake' ltake_all not_less nth_list_of numeral_eq_enat the_enat.simps times_enat_simps(1))
   thus ?thesis
     by (metis Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) lalternate_ltake lessI lnth_ltake)
 qed
 
 lemma lnth_lalternate2[simp]:
   assumes "n < llength (lalternate xs)"
   shows "lalternate xs $ n = xs $ (2 * n)"
 proof -
   from assms have "2*enat n < llength xs"
     by (metis enat_numeral lalternate_ltake leI linorder_neq_iff llength_ltake' ltake_all times_enat_simps(1))
   from lnth_lalternate[OF this] show ?thesis.
 qed
 
 end
\ No newline at end of file
diff --git a/thys/GaleStewart_Games/FilteredList.thy b/thys/GaleStewart_Games/FilteredList.thy
--- a/thys/GaleStewart_Games/FilteredList.thy
+++ b/thys/GaleStewart_Games/FilteredList.thy
@@ -1,310 +1,310 @@
 theory FilteredList
   imports MoreCoinductiveList2
 begin
 
 subsection \<open>More on filtered lists\<close>
 
 text \<open>We will reason about (co-inductive) lists with distinct elements.
       However, for our setting, this 'distinct' property only holds on the list after filtering.
       For this reason, we need some additional lemmas.\<close>
 
 text \<open>Taking a sublist preserves distinctness after filtering.\<close>
 lemma ldistinct_lfilter_ltake[intro]:
   assumes "ldistinct (lfilter P xs)"
   shows "ldistinct (lfilter P (ltake x xs))"
   using assms
   by(induct xs,force,force
     ,(* sledgehammer found this gem to prove the inductive step via lfilter_lappend_lfinite!
         We will use this strategy ourselves later on *)
      metis lappend_ltake_ldrop ldistinct_lappend lfilter_lappend_lfinite lfinite_LConsI lfinite_ltake)
 
 text \<open>The function lfind is used in multiple proofs, all are introduced to prove ltake_lfilter.\<close>
 definition lfind where "lfind P lst = (LEAST i. P (lst $ i))"
 
 lemma lfilter_lfind:
   assumes "lfilter P lst \<noteq> LNil"
   shows "P (lst $ lfind P lst)" (is ?g1)
         "P (lst $ y) \<Longrightarrow> lfind P lst \<le> y" (is "?a \<Longrightarrow> ?g2")
         "lfind P lst < llength lst" (is ?g3)
 proof -
   let ?I = "{n. enat n < llength lst \<and> P (lst $ n)}"
   let ?xs = lst
   from assms[unfolded lfilter_conv_lnths] lset_LNil
   have "lset (lnths lst {n. enat n < llength lst \<and> P (lst $ n)}) \<noteq> {}" by auto
   hence "{?xs $ i |i. enat i < llength ?xs \<and> i \<in> ?I} \<noteq> {}" using lset_lnths[of ?xs ?I] by metis
   then obtain i where p:"P (lst $ i)" "i < llength lst" by auto
   from p show ?g1 using LeastI lfind_def by metis
   from p show "?a \<Longrightarrow> ?g2" using Least_le lfind_def by metis
   from p show ?g3 using Least_le lfind_def by (metis enat_ord_simps(1) le_less_trans)
 qed
 
 lemma ltake_lfind_lset:
   assumes "x \<in> lset (ltake (enat (lfind P lst)) lst)"
   shows "\<not> P x"
 proof(cases "lfilter P (ltake (enat (lfind P lst)) lst) = LNil")
   case True
   then show ?thesis using assms unfolding lfilter_eq_LNil by auto
 next
   case False
   from assms[unfolded in_lset_conv_lnth] obtain n where
     n:"enat n < llength (ltake (enat (lfind P lst)) lst)" "ltake (enat (lfind P lst)) lst $ n = x"
     by blast
   { assume a:"P x"
       (* The idea of this {block} is that the element n must come after (lfind P lst) by lfilter_lfind(2)
      but this contradicts n(1).
      However, in the last step when writing this proof, sledgehammer found one that didn't use
        any of my previous steps, so here's a one-liner: *)
     from n Coinductive_List.lset_ltake False a enat_ord_simps(1) leD lfilter_empty_conv lfilter_lfind(2,3) llength_ltake' lnth_ltake subset_eq
     have False by metis
   }
   then show ?thesis by blast
 qed
 
 lemma ltake_lfind_conv:
   assumes "lfilter P lst \<noteq> LNil"
   shows "ltake (lfind P lst) lst = ltakeWhile (Not o P) lst" (is "?t1 = ?t2")
         "ldrop (lfind P lst) lst = ldropWhile (Not o P) lst" (is "?t3 = ?t4")
 proof -
   have lfin:"lfinite ?t1" by simp
   have [simp]:"min (enat (lfind P lst)) (llength lst) = (lfind P lst)"
     using lfilter_lfind(3)[OF assms] by (metis min.strict_order_iff)
   have l1:"llength ?t1 = lfind P lst" by simp
   from ltake_lfind_lset ltakeWhile_all
   have t:"ltakeWhile (Not o P) ?t1 = ?t1" unfolding o_def by metis
   have inset:"lset (ltake (enat (lfind P lst)) lst) \<subseteq> {x. (Not \<circ> P) x}"
     using ltake_lfind_lset[of _ P lst] by auto (* for use in ltakeWhile_lappend2 *)
   have isnull:"ltakeWhile (Not \<circ> P) (ldrop (enat (lfind P lst)) lst) = LNil"
     apply(cases "ldrop (enat (lfind P lst)) lst")
     using lfilter_lfind(1)[OF assms] lhd_ldrop[OF lfilter_lfind(3)[OF assms]]
     by auto
   have "ltakeWhile (Not o P) ?t1 = ltakeWhile (Not o P) (lappend ?t1 ?t3)"
     unfolding ltakeWhile_lappend2[OF inset] isnull lappend_LNil2 t..
   hence leneq:"llength ?t1 = llength ?t2" using t l1 lappend_ltake_ldrop by metis
   have "lappend ?t1 ?t3 = lappend ?t2 ?t4" 
      unfolding lappend_ltakeWhile_ldropWhile[of "Not \<circ> P" lst]
                lappend_ltake_ldrop[of "lfind P lst" lst]
      by simp
   from this[unfolded lappend_eq_lappend_conv[OF leneq]] lfin
   show "?t1 = ?t2" "?t3 = ?t4" by auto
 qed
 
 lemma lfilter_hdtl:
   assumes "lfilter P lst \<noteq> LNil"
   shows "\<exists> n. LCons (lhd (lfilter P lst)) LNil = lfilter P (ltake (enat n) lst) \<and>
               ltl (lfilter P lst) = lfilter P (ldrop (enat n) lst)"
 proof(standard,standard)
   note * = lfilter_lfind[OF assms]
   let ?n = "Suc (lfind P lst)"
   let ?ltake = "ltake (enat ?n) lst"
   have ltake:"lappend (ltakeWhile (Not \<circ> P) ?ltake) (ldropWhile (Not \<circ> P) ?ltake) = ?ltake"
       (is "lappend ?ltw ?ldw = _")
       using lappend_ltakeWhile_ldropWhile by blast
   have "llength ?ldw \<le> 1"
       unfolding ldropWhile_lappend ltake_Suc_conv_snoc_lnth[OF *(3)]
       using ltake_lfind_lset[of _ P lst] by (auto intro:* simp:one_eSuc)
   hence null:"lnull (ltl (ldropWhile (Not \<circ> P) ?ltake))"
       unfolding llength_eq_0[symmetric] llength_ltl
       by (metis dual_order.order_iff_strict enat_ile epred_0 epred_1 iless_Suc_eq le_zero_eq one_eSuc one_enat_def)
   have e:"enat (lfind P lst) < enat (Suc (lfind P lst))" by auto
     from * have "P (?ltake $ lfind P lst)" using lnth_ltake[OF e] by metis
   hence nonnull:"\<not> lnull (lfilter P ?ltake)" unfolding lnull_lfilter
       by (metis "*"(3) e in_lset_conv_lnth leI llength_ltake' ltake_all)
 
   show a:"LCons (lhd (lfilter P lst)) LNil = lfilter P ?ltake" (is "?lhs = ?rhs")
   proof -
     have "lhd (lfilter P ?ltake) = lhd (lfilter P lst)"
       by(rule lprefix_lhdD[OF lprefix_lfilterI[OF ltake_is_lprefix] nonnull])
     hence h:"lhd ?lhs = lhd ?rhs" by simp
     have "ltl ?rhs = LNil" 
       unfolding ltl_lfilter using null by (metis lfilter_LNil llist.collapse(1))
     hence t:"ltl ?lhs = ltl ?rhs" by simp
     have flt:"?rhs \<noteq> LNil" using nonnull by fastforce
     show ?thesis by(rule llist_eq_lcons[of ?lhs ?rhs,OF _ flt h t],auto)
   qed
 
   from lappend_ltake_ldrop[of ?n lst] lappend_ltakeWhile_ldropWhile[of "Not \<circ> P" lst]
   have "lappend (ltake ?n lst) (ldrop ?n lst) = lappend (ltakeWhile (Not \<circ> P) lst) (ldropWhile (Not \<circ> P) lst)"
     by auto
   from ltake_lfind_conv(2)[OF assms]
   have "ltl (ldropWhile (Not \<circ> P) lst) = ldrop (enat (Suc (lfind P lst))) lst"
     unfolding ldrop_eSuc_conv_ltl eSuc_enat[symmetric] by simp
   thus "ltl (lfilter P lst) = lfilter P (ldrop (enat ?n) lst)" unfolding ltl_lfilter by metis
 qed
 
 lemma ltake_lfilter:
   shows "\<exists> n. ltake (enat x) (lfilter P lst) = lfilter P (ltake (enat n) lst) \<and> ldrop (enat x) (lfilter P lst) = lfilter P (ldrop (enat n) lst)"
 proof(induct x)
   case 0
   then show ?case by (metis LNil_eq_ltake_iff ldrop_enat ldropn_0 lfilter_code(1) zero_enat_def)
 next
   let ?fP = "lfilter P"
   case (Suc x)
   then obtain n where n:"ltake (enat x) (?fP lst) = ?fP (ltake (enat n) lst)"
     "ldrop (enat x) (lfilter P lst) = lfilter P (ldrop (enat n) lst)" by blast
   consider "lfilter P (ldrop (enat n) lst) \<noteq> LNil \<and> x < llength (?fP lst)" |
     "lfilter P (ldrop (enat n) lst) = LNil" | "x \<ge> llength (?fP lst)" by force
   then show ?case proof(cases)
     case 1
     hence *:"lfilter P (ldrop (enat n) lst) \<noteq> LNil" "enat x < llength (lfilter P lst)" by auto
     from lappend_ltake_ldrop have "lst = lappend (ltake (enat n) lst) (ldrop (enat n) lst)" by metis
     from lfilter_hdtl[OF *(1)] obtain delta where
       delta:"LCons (lhd (?fP (ldrop (enat n) lst))) LNil = ?fP (ltake (enat delta) (ldrop (enat n) lst))"
       "ltl (lfilter P (ldrop (enat n) lst)) = lfilter P (ldrop (enat delta) (ldrop (enat n) lst))" by blast
     have "ltake (enat (Suc x)) (?fP lst) = lappend (?fP (ltake (enat n) lst)) (LCons (?fP lst $ x) LNil)"
       using n ltake_Suc_conv_snoc_lnth * by metis
     also have "?fP lst $ x = ?fP lst $ (the_enat x)" by auto
     also have "\<dots> = lhd (ldrop x (?fP lst))" using lhd_ldrop[symmetric] *(2) by metis
     also have "\<dots> = lhd (?fP (ldrop (enat n) lst))" using n by metis
     also note delta(1)
     finally have take_part:"ltake (enat (Suc x)) (?fP lst) = ?fP (ltake (enat (n + delta)) lst)"
       using ltake_plus_conv_lappend
       by (metis infinite_small_llength lfilter_lappend_lfinite llength_ltake' ltake_all min.strict_order_iff not_less plus_enat_simps(1))
     have "ldrop (enat (Suc x)) (?fP lst) = ltl (ldrop x (?fP lst))" by (simp add: ltl_ldropn ldrop_eSuc_ltl ldrop_enat)
     also have "ldrop x (?fP lst) = ?fP (ldrop (enat n) lst)" using n by metis
     also note delta(2)
     also have "lfilter P (ldrop (enat delta) (ldrop (enat n) lst)) = lfilter P (ldrop (enat delta + enat n) lst)"
       by simp
     also have "(enat delta + enat n) = enat (n + delta)" by simp
     finally have drop_part:"ldrop (enat (Suc x)) (?fP lst) = ?fP (ldrop (enat (n + delta)) lst)".
     from take_part drop_part show ?thesis by blast
   next
   case 2
     note * = 2 lappend_ltake_ldrop[of "enat n" lst] Suc_llength infinite_small_llength
              lappend_LNil2 leI lfilter_lappend_lfinite llength_ltake' min.strict_order_iff n
     have take_part:"ltake (enat (Suc x)) (?fP lst) = ?fP (ltake (enat n) lst)"
-      using * by (smt (z3) ltake_all)
+      using * by (smt (verit) ltake_all)
     from 2 have drop_part:"ldrop (enat (Suc x)) (?fP lst) = ?fP (ldrop (enat n) lst)"
-      using * by (smt (z3) ldrop_all)
+      using * by (smt (verit) ldrop_all)
     from take_part drop_part show ?thesis by blast
   next
   case 3
     then show ?thesis using n dual_order.order_iff_strict eSuc_enat iless_Suc_eq le_less_trans ltake_all ldrop_all
          by metis
   qed 
 qed
 
 lemma filter_obtain_two:
   assumes "i < j" "j < length (filter P lst)"
   shows "\<exists> i2 j2. i2 < j2 \<and> j2 < length lst \<and> lst ! i2 = filter P lst ! i \<and> lst ! j2 = filter P lst ! j"
   using assms
 proof(induct lst arbitrary: i j)
   case (Cons a lst)
   then obtain jprev where jprev:"j = Suc jprev" using lessE by metis
   show ?case proof(cases "P a")
     case True
     hence lnth[simp]:"length (filter P (a # lst)) = Suc (length (filter P lst))" by auto
     show ?thesis proof(cases i)
       case 0
       from jprev True Cons(3) have "jprev < length (filter P lst) " by auto
       from nth_mem[OF this]
       have "filter P lst ! jprev \<in> set lst" by auto
       from this[unfolded in_set_conv_nth] obtain j2 where
         "j2<length lst" "lst ! j2 = filter P lst ! jprev" by blast
       hence "0 < Suc j2" "Suc j2 < length (a # lst)"
         "(a # lst) ! 0 = filter P (a # lst) ! i"
         "(a # lst) ! Suc j2 = filter P (a # lst) ! j" using 0 True jprev by auto
       then show ?thesis by blast
     next
       case (Suc nat)
       then obtain jprev where jprev:"j = Suc jprev" using Cons lessE by metis
       hence "nat < jprev" "jprev < length (filter P lst)" using Cons Suc lnth by auto
       from Cons(1)[OF this] obtain i2 j2 where "i2 < j2" "j2 < length lst"
         "lst ! i2 = filter P lst ! nat" "lst ! j2 = filter P lst ! jprev" by blast
       hence "Suc i2 < Suc j2" "Suc j2 < length (a # lst)"
         "(a # lst) ! Suc i2 = filter P (a # lst) ! Suc nat"
         "(a # lst) ! Suc j2 = filter P (a # lst) ! Suc jprev" using lnth by auto
       then show ?thesis unfolding jprev[symmetric] Suc[symmetric] by blast
     qed
   next
     case False
     hence [simp]: "filter P (a # lst) = filter P lst" by auto
     from Cons(1)[OF Cons(2)] Cons(3)[unfolded this]
     obtain i2 j2 where "i2 < j2" "j2 < length lst"
       "lst ! i2 = filter P lst ! i" "lst ! j2 = filter P lst ! j" by blast
     hence "Suc i2 < Suc j2" "Suc j2 < length (a # lst)"
       "(a # lst) ! Suc i2 = filter P (a # lst) ! i"
       "(a # lst) ! Suc j2 = filter P (a # lst) ! j" by (auto simp:False) 
     then show ?thesis by blast
   qed
 qed auto
 
 lemma ldistinct_lfilterI:
   assumes "\<And> i j. i < llength lst \<Longrightarrow> j < llength lst \<Longrightarrow> lst $ i = lst $ j \<Longrightarrow> P (lst $ i) \<Longrightarrow> i = j"
   shows "ldistinct (lfilter P lst)"
 proof -
 { fix i j
   assume *: "enat i < llength (lfilter P lst)"
             "enat j < llength (lfilter P lst)"
             "lfilter P lst $ i = lfilter P lst $ j"
             "i < j"
   hence "lfilter P lst $ i \<in> lset (lfilter P lst)"
     unfolding in_lset_conv_lnth by auto
   with lset_lfilter
   have P:"P (lfilter P lst $ i)" by auto
   let ?maxij = "Suc (max i j)"
   from ltake_lfilter obtain maxij where
     maxij:"ltake ?maxij (lfilter P lst) = lfilter P (ltake (enat maxij) lst)"
     by blast
   let ?lst = "ltake (enat maxij) lst"
   have "lfinite ?lst" by auto
   define flst where "flst = list_of ?lst"
   hence flst:"llist_of flst = ?lst" by auto
   let ?flst = "llist_of flst"
   from * P
     have "enat i < llength (lfilter P ?flst)"
          "enat j < llength (lfilter P ?flst)"
          "lfilter P ?flst $ i = lfilter P ?flst $ j"
     and P2:"P (lfilter P ?lst $ i)"
     unfolding maxij[symmetric] flst by (auto simp add: lnth_ltake)
   hence "i < length (filter P flst)"
         "j < length (filter P flst)"
     and eq_ij: "filter P flst ! i = filter P flst ! j"
     unfolding llength_llist_of lfilter_llist_of lnth_llist_of by auto
   with filter_obtain_two[OF *(4) this(2)] obtain i2 j2
     where "i2 < length flst" "j2 < length flst"
           "flst ! i2 = filter P flst ! i"
           "flst ! j2 = filter P flst ! j"
           and ineq:"i2<j2"
     by auto
   hence "i2 < llength ?flst" "j2 < llength ?flst" "?flst $ i2 = ?flst $ j2" "?flst $ i2 = lfilter P ?flst $ i" "i2<j2" 
     unfolding llength_llist_of lfilter_llist_of lnth_llist_of eq_ij by auto
   hence "enat i2 < llength lst" "enat j2 < llength lst" "lst $ i2 = lst $ j2" "P (lst $ i2)"
     using P2 unfolding flst by (auto simp add: lnth_ltake)
   from assms[OF this]
   have False using ineq by auto
 }
-thus ?thesis unfolding ldistinct_conv_lnth by (smt (z3) le_cases3 less_le)
+thus ?thesis unfolding ldistinct_conv_lnth by (smt (verit) le_cases3 less_le)
 qed
 
 lemma ldistinct_lfilterE:
   assumes "ldistinct (lfilter P lst)" "e = lst $ i" "e = lst $ j"
           "i < llength lst" "j < llength lst" "P e"
   shows "i = j"
 proof -
   let ?maxij = "Suc (max i j)"
   let ?lst = "ltake (enat ?maxij) lst"
   have jle:"j < length (list_of (ltake (enat (Suc (max i j))) lst))" using assms(4,5)
     apply(subst length_list_of_conv_the_enat,force)
     by(cases "llength lst", auto simp:min_enat2_conv_enat min_enat1_conv_enat)
   have ile:"i < length (list_of (ltake (enat (Suc (max i j))) lst))" using assms(4,5)
     apply(subst length_list_of_conv_the_enat,force)
     by(cases "llength lst", auto simp:min_enat2_conv_enat min_enat1_conv_enat)
   have "enat i < ?maxij" "enat j < ?maxij" by auto
   from this[THEN lnth_ltake,of lst] assms
   have "ldistinct (lfilter P ?lst)" "e = ?lst $ i" "e = ?lst $ j" by auto
   hence d:"distinct (filter P (list_of ?lst))"
        "(list_of ?lst) ! j = e" "(list_of ?lst) ! i = e"
     using lfilter_llist_of[of P "list_of ?lst"] by auto
   show ?thesis by(rule distinct_filterD[OF d(1) jle ile assms(6) d(2,3)])
 qed
 
 lemma ldistinct_lfilter_conv:
   "ldistinct (lfilter P lst) = (\<forall> i j. i < llength lst \<longrightarrow> j < llength lst \<longrightarrow> P (lst $ i) \<longrightarrow> lst $ i = lst $ j \<longrightarrow> i = j)"
 proof
   show "ldistinct (lfilter P lst) \<Longrightarrow> \<forall>i j. enat i < llength lst \<longrightarrow> enat j < llength lst \<longrightarrow> P (lst $ i) \<longrightarrow> lst $ i = lst $ j \<longrightarrow> i = j" 
     by (auto simp add: ldistinct_lfilterE)
   show "\<forall>i j. enat i < llength lst \<longrightarrow> enat j < llength lst \<longrightarrow> P (lst $ i) \<longrightarrow> lst $ i = lst $ j \<longrightarrow> i = j \<Longrightarrow> ldistinct (lfilter P lst) "
     using ldistinct_lfilterI by blast
 qed
 
 end
\ No newline at end of file
diff --git a/thys/IMO2019/IMO2019_Q1.thy b/thys/IMO2019/IMO2019_Q1.thy
--- a/thys/IMO2019/IMO2019_Q1.thy
+++ b/thys/IMO2019/IMO2019_Q1.thy
@@ -1,66 +1,66 @@
 (*
   File:    IMO2019_Q1.thy
   Author:  Manuel Eberl, TU München
 *)
 section \<open>Q1\<close>
 theory IMO2019_Q1
   imports Main
 begin
 
 text \<open>
   Consider a function \<open>f : \<int> \<rightarrow> \<int>\<close> that fulfils the functional equation
   \<open>f(2a) + 2f(b) = f(f(a+b))\<close> for all \<open>a, b \<in> \<int>\<close>.
 
   Then \<open>f\<close> is either identically 0 or of the form \<open>f(x) = 2x + c\<close> for some constant \<open>c \<in> \<int>\<close>.
 \<close>
 
 context
   fixes f :: "int \<Rightarrow> int" and m :: int
   assumes f_eq: "f (2 * a) + 2 * f b = f (f (a + b))"
   defines "m \<equiv> (f 0 - f (-2)) div 2"
 begin
 
 text \<open>
   We first show that \<open>f\<close> is affine with slope \<open>(f(0) - f(-2)) / 2\<close>.
   This follows from plugging in \<open>(0, b)\<close> and \<open>(-1, b + 1)\<close> into the functional equation.
 \<close>
 lemma f_eq': "f x = m * x + f 0"
 proof -
   have rec: "f (b + 1) = f b + m" for b
     using f_eq[of 0 b] f_eq[of "-1" "b + 1"] by (simp add: m_def)
   moreover have "f (b - 1) = f b - m" for b
     using rec[of "b - 1"] by simp
   ultimately show ?thesis
     by (induction x rule: int_induct[of _ 0]) (auto simp: algebra_simps)
 qed
 
 text \<open>
   This version is better for the simplifier because it prevents it from looping.
 \<close>
 lemma f_eq'_aux [simp]: "NO_MATCH 0 x \<Longrightarrow> f x = m * x + f 0"
   by (rule f_eq')
 
 text \<open>
   Plugging in \<open>(0, 0)\<close> and \<open>(0, 1)\<close>.
 \<close>
 lemma f_classification: "(\<forall>x. f x = 0) \<or> (\<forall>x. f x = 2 * x + f 0)"
   using f_eq[of 0 0] f_eq[of 0 1] by auto
 
 end
 
 text \<open>
   It is now easy to derive the full characterisation of the functions we considered:
 \<close>
 theorem
   fixes f :: "int \<Rightarrow> int"
   shows "(\<forall>a b. f (2 * a) + 2 * f b = f (f (a + b))) \<longleftrightarrow>
            (\<forall>x. f x = 0) \<or> (\<forall>x. f x = 2 * x + f 0)" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   thus ?rhs using f_classification[of f] by blast
 next
   assume ?rhs
-  thus ?lhs by smt
+  thus ?lhs by (smt (verit, ccfv_threshold) mult_2)
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Isabelle_hoops/Ordinal_Sums.thy b/thys/Isabelle_hoops/Ordinal_Sums.thy
--- a/thys/Isabelle_hoops/Ordinal_Sums.thy
+++ b/thys/Isabelle_hoops/Ordinal_Sums.thy
@@ -1,778 +1,778 @@
 section\<open>Ordinal sums\<close>
 
 text\<open>We define @{text "tower of hoops"}, a family of almost disjoint hoops indexed by a total order.
  This is based on the definition of @{text "bounded tower of irreducible hoops"} in \<^cite>\<open>"BUSANICHE2005"\<close>
  (see paragraph after Lemma 3.3). Parting from a tower of hoops we can define a hoop known as @{text "ordinal sum"}.
  Ordinal sums are a fundamental tool in the study of totally ordered hoops.\<close>
 
 theory Ordinal_Sums
   imports Hoops 
 begin
 
 subsection\<open>Tower of hoops\<close>
 
 locale tower_of_hoops =
   fixes index_set :: "'b set" ("I")
   fixes index_lesseq :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<le>\<^sup>I" 60)
   fixes index_less :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "<\<^sup>I" 60)
   fixes universes :: "'b \<Rightarrow> ('a set)" ("UNI")
   fixes multiplications :: "'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a)" ("MUL")
   fixes implications :: "'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a)" ("IMP")
   fixes sum_one :: 'a ("1\<^sup>S")
   assumes index_set_total_order: "total_poset_on I (\<le>\<^sup>I) (<\<^sup>I)"
   and almost_disjoint: "i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> UNI i \<inter> UNI j = {1\<^sup>S}"
   and family_of_hoops: "i \<in> I \<Longrightarrow> hoop (UNI i) (MUL i) (IMP i) 1\<^sup>S"
 begin
 
 sublocale total_poset_on "I" "(\<le>\<^sup>I)" "(<\<^sup>I)"
   using index_set_total_order by simp                   
 
 abbreviation (uni_i)
   uni_i :: "['b] \<Rightarrow> ('a set)" ("(\<bbbA>(\<^sub>_))" [61] 60)
   where "\<bbbA>\<^sub>i \<equiv> UNI i"
 
 abbreviation (mult_i)
   mult_i :: "['b] \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a)" ("(*(\<^sup>_))" [61] 60)
   where "*\<^sup>i \<equiv> MUL i"
 
 abbreviation (imp_i)
   imp_i :: "['b] \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a)" ("(\<rightarrow>(\<^sup>_))" [61] 60)
   where "\<rightarrow>\<^sup>i \<equiv> IMP i"
 
 abbreviation (mult_i_xy)
   mult_i_xy :: "['a, 'b, 'a] \<Rightarrow> 'a"  ("((_)/ *(\<^sup>_) / (_))" [61, 50, 61] 60)
   where "x *\<^sup>i y \<equiv> MUL i x y"
 
 abbreviation (imp_i_xy)
   imp_i_xy :: "['a, 'b, 'a] \<Rightarrow> 'a"  ("((_)/ \<rightarrow>(\<^sup>_) / (_))" [61, 50, 61] 60)
   where "x \<rightarrow>\<^sup>i y \<equiv> IMP i x y"
 
 subsection\<open>Ordinal sum universe\<close>
 
 definition sum_univ :: "'a set" ("S")
   where "S = {x. \<exists> i \<in> I. x \<in> \<bbbA>\<^sub>i}"
 
 lemma sum_one_closed [simp]: "1\<^sup>S \<in> S"
   using family_of_hoops hoop.one_closed not_empty sum_univ_def by fastforce
 
 lemma sum_subsets: 
   assumes "i \<in> I"
   shows "\<bbbA>\<^sub>i \<subseteq> S"
   using sum_univ_def assms by blast
 
 subsection\<open>Floor function: definition and properties\<close>
 
 lemma floor_unique:
   assumes "a \<in> S-{1\<^sup>S}"
   shows "\<exists>! i. i \<in> I \<and> a \<in> \<bbbA>\<^sub>i"
   using assms sum_univ_def almost_disjoint by blast
 
 function floor :: "'a \<Rightarrow> 'b" where
   "floor x = (THE i. i \<in> I \<and> x \<in> \<bbbA>\<^sub>i)" if "x \<in> S-{1\<^sup>S}"
 | "floor x = undefined" if "x = 1\<^sup>S \<or> x \<notin> S"
   by auto
 termination by lexicographic_order
 
 abbreviation (uni_floor)
   uni_floor :: "['a] \<Rightarrow> ('a set)" ("(\<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r (\<^sub>_))" [61] 60)
   where "\<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>x \<equiv> UNI (floor x)"
 
 abbreviation (mult_floor)
   mult_floor :: "['a] \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a)"  ("(*\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_))" [61] 60)
   where "*\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a \<equiv> MUL (floor a)"
 
 abbreviation (imp_floor)
   imp_floor :: "['a] \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a)"  ("(\<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_))" [61] 60)
   where "\<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a \<equiv> IMP (floor a)"
 
 abbreviation (mult_floor_xy)
   mult_floor_xy :: "['a, 'a, 'a] \<Rightarrow> 'a"  ("((_)/ *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_) / (_))" [61, 50, 61] 60)
   where "x *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>y z \<equiv> MUL (floor y) x z"
 
 abbreviation (imp_floor_xy)
   imp_floor_xy :: "['a, 'a, 'a] \<Rightarrow> 'a"  ("((_)/ \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_) / (_))" [61, 50, 61] 60)
   where "x \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>y z \<equiv> IMP (floor y) x z"
 
 lemma floor_prop:
   assumes "a \<in> S-{1\<^sup>S}"
   shows "floor a \<in> I \<and> a \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
 proof -
   have "floor a = (THE i. i \<in> I \<and> a \<in> \<bbbA>\<^sub>i)"
     using assms by auto
   then
   show ?thesis
     using assms theI_unique floor_unique by (metis (mono_tags, lifting))
 qed
 
 lemma floor_one_closed:
   assumes "i \<in> I"
   shows "1\<^sup>S \<in> \<bbbA>\<^sub>i"
   using assms floor_prop family_of_hoops hoop.one_closed by metis
 
 lemma floor_mult_closed:
   assumes "i \<in> I" "a \<in> \<bbbA>\<^sub>i" "b \<in> \<bbbA>\<^sub>i" 
   shows "a *\<^sup>i b \<in> \<bbbA>\<^sub>i"
   using assms family_of_hoops hoop.mult_closed by meson
 
 lemma floor_imp_closed:
   assumes "i \<in> I" "a \<in> \<bbbA>\<^sub>i" "b \<in> \<bbbA>\<^sub>i" 
   shows "a \<rightarrow>\<^sup>i b \<in> \<bbbA>\<^sub>i"
   using assms family_of_hoops hoop.imp_closed by meson
 
 subsection\<open>Ordinal sum multiplication and implication\<close>
 
 function sum_mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "*\<^sup>S" 60) where
   "x *\<^sup>S y = x *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>x y" if  "x \<in> S-{1\<^sup>S}" "y \<in> S-{1\<^sup>S}" "floor x = floor y"
 | "x *\<^sup>S y = x" if "x \<in> S-{1\<^sup>S}" "y \<in> S-{1\<^sup>S}" "floor x <\<^sup>I floor y"
 | "x *\<^sup>S y = y" if "x \<in> S-{1\<^sup>S}" "y \<in> S-{1\<^sup>S}" "floor y <\<^sup>I floor x"
 | "x *\<^sup>S y = y" if "x = 1\<^sup>S" "y \<in> S-{1\<^sup>S}"
 | "x *\<^sup>S y = x" if "x \<in> S-{1\<^sup>S}" "y = 1\<^sup>S"
 | "x *\<^sup>S y = 1\<^sup>S" if "x = 1\<^sup>S" "y = 1\<^sup>S"
 | "x *\<^sup>S y = undefined" if "x \<notin> S \<or> y \<notin> S"
   apply auto
-  using floor.cases floor.simps(1) floor_prop trichotomy apply smt
+  using floor.cases floor.simps(1) floor_prop trichotomy apply (smt (verit))
   using floor_prop strict_iff_order apply force
   using floor_prop strict_iff_order apply force
   using floor_prop trichotomy by auto
 termination by lexicographic_order
 
 function sum_imp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<rightarrow>\<^sup>S" 60) where
   "x \<rightarrow>\<^sup>S y = x \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>x y" if "x \<in> S-{1\<^sup>S}" "y \<in> S-{1\<^sup>S}" "floor x = floor y"
 | "x \<rightarrow>\<^sup>S y = 1\<^sup>S" if "x \<in> S-{1\<^sup>S}" "y \<in> S-{1\<^sup>S}" "floor x <\<^sup>I floor y"
 | "x \<rightarrow>\<^sup>S y = y" if "x \<in> S-{1\<^sup>S}" "y \<in> S-{1\<^sup>S}" "floor y <\<^sup>I floor x"
 | "x \<rightarrow>\<^sup>S y = y" if "x = 1\<^sup>S" "y \<in> S-{1\<^sup>S}"
 | "x \<rightarrow>\<^sup>S y = 1\<^sup>S" if "x \<in> S-{1\<^sup>S}" "y = 1\<^sup>S"
 | "x \<rightarrow>\<^sup>S y = 1\<^sup>S" if "x = 1\<^sup>S" "y = 1\<^sup>S"
 | "x \<rightarrow>\<^sup>S y = undefined" if "x \<notin> S \<or> y \<notin> S"
   apply auto
-  using floor.cases floor.simps(1) floor_prop trichotomy apply smt
+  using floor.cases floor.simps(1) floor_prop trichotomy apply (smt (verit))
   using floor_prop strict_iff_order apply force
   using floor_prop strict_iff_order apply force
   using floor_prop trichotomy by auto
 termination by lexicographic_order
 
 subsubsection\<open>Some multiplication properties\<close>
 
 lemma sum_mult_not_one_aux:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
   shows "a *\<^sup>S b \<in> (\<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S}"
 proof -
   consider (1) "b \<in> S-{1\<^sup>S}"
     | (2) "b = 1\<^sup>S"
     using sum_subsets assms floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then
     have same_floor: "floor a = floor b"
       using assms floor_prop floor_unique by metis
     moreover
     have "a *\<^sup>S b = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b"
       using "1" assms(1) same_floor by simp
     moreover
     have "a \<in> (\<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S} \<and> b \<in> (\<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S}"
       using "1" assms floor_prop by simp
     ultimately
     show ?thesis
       using assms(1) family_of_hoops floor_prop hoop.mult_C by metis
   next
     case 2
     then
     show ?thesis
       using assms(1) floor_prop by auto
   qed
 qed
 
 corollary sum_mult_not_one:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
   shows "a *\<^sup>S b \<in> S-{1\<^sup>S} \<and> floor (a *\<^sup>S b) = floor a"
 proof -
   have "a *\<^sup>S b \<in> (\<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S}"
     using sum_mult_not_one_aux assms by meson
   then 
   have "a *\<^sup>S b \<in> S-{1\<^sup>S} \<and> a *\<^sup>S b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
     using sum_subsets assms(1) floor_prop by fastforce
   then
   show ?thesis
     using assms(1) floor_prop floor_unique by metis
 qed
    
 lemma sum_mult_A: 
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
   shows "a *\<^sup>S b = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b  \<and> b *\<^sup>S a = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a"
 proof -
   consider (1) "b \<in> S-{1\<^sup>S}"
     | (2) "b = 1\<^sup>S"
     using sum_subsets assms floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then
     have "floor a = floor b"
       using assms floor.cases floor_prop floor_unique by metis
     then
     show ?thesis
       using "1" assms by auto
   next
     case 2
     then
     show ?thesis
       using assms(1) family_of_hoops floor_prop hoop.mult_neutr hoop.mult_neutr_2
       by fastforce
   qed
 qed
 
 subsubsection\<open>Some implication properties\<close>
 
 lemma sum_imp_floor:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}" "floor a = floor b" "a \<rightarrow>\<^sup>S b \<in> S-{1\<^sup>S}" 
   shows "floor (a \<rightarrow>\<^sup>S b) = floor a"
 proof -
   have "a \<rightarrow>\<^sup>S b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
     using sum_imp.simps(1) assms(1-3) floor_imp_closed floor_prop
     by metis
   then 
   show ?thesis
     using assms(1,4) floor_prop floor_unique by blast
 qed
 
 lemma sum_imp_A:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
   shows "a \<rightarrow>\<^sup>S b = a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b"
 proof -
   consider (1) "b \<in> S-{1\<^sup>S}"
     | (2) "b = 1\<^sup>S"
     using sum_subsets assms floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then 
     show ?thesis
       using sum_imp.simps(1) assms floor_prop floor_unique by metis
   next
     case 2
     then
     show ?thesis
       using sum_imp.simps(5) assms(1) family_of_hoops floor_prop
             hoop.imp_one_top
       by metis
   qed
 qed
 
 lemma sum_imp_B:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
   shows "b \<rightarrow>\<^sup>S a = b \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a"
 proof -
   consider (1) "b \<in> S-{1\<^sup>S}"
     | (2) "b = 1\<^sup>S"
     using sum_subsets assms floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then 
     show ?thesis
       using sum_imp.simps(1) assms floor_prop floor_unique by metis
   next
     case 2
     then
     show ?thesis
       using sum_imp.simps(4) assms(1) family_of_hoops floor_prop
             hoop.imp_one_C
       by metis
   qed
 qed
 
 lemma sum_imp_floor_antisymm:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}" "floor a = floor b"
           "a \<rightarrow>\<^sup>S b = 1\<^sup>S" "b \<rightarrow>\<^sup>S a = 1\<^sup>S"
   shows "a = b"
 proof -
   have "a \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a \<and> b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a \<and> floor a \<in> I"
     using floor_prop assms by metis
   moreover 
   have "a \<rightarrow>\<^sup>S b = a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b \<and> b \<rightarrow>\<^sup>S a = b \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a"
     using assms by auto
   ultimately
   show ?thesis
     using assms(4,5) family_of_hoops hoop.ord_antisymm_equiv by metis
 qed
 
 corollary sum_imp_C:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}" "a \<noteq> b" "floor a = floor b" "a \<rightarrow>\<^sup>S b = 1\<^sup>S"
   shows "b \<rightarrow>\<^sup>S a \<noteq> 1\<^sup>S"
   using sum_imp_floor_antisymm assms by blast
 
 lemma sum_imp_D:
   assumes "a \<in> S"
   shows "1\<^sup>S \<rightarrow>\<^sup>S a = a"
   using sum_imp.simps(4,6) assms by blast
 
 lemma sum_imp_E:
   assumes "a \<in> S"
   shows "a \<rightarrow>\<^sup>S 1\<^sup>S = 1\<^sup>S"
   using sum_imp.simps(5,6) assms by blast
 
 subsection\<open>The ordinal sum of a tower of hoops is a hoop\<close>
 
 subsubsection\<open>@{term S} is not empty\<close>
 
 lemma sum_not_empty: "S \<noteq> \<emptyset>"
   using sum_one_closed by blast
 
 subsubsection\<open>@{term sum_mult} and @{term sum_imp} are well defined\<close>
 
 lemma sum_mult_closed_one: 
   assumes "a \<in> S" "b \<in> S" "a = 1\<^sup>S \<or> b = 1\<^sup>S"
   shows "a *\<^sup>S b \<in> S"
   using sum_mult.simps(4-6) assms floor.cases by metis
 
 lemma sum_mult_closed_not_one:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}"
   shows "a *\<^sup>S b \<in> S-{1\<^sup>S}"
 proof -
   from assms
   consider (1) "floor a = floor b"
     | (2) "floor a <\<^sup>I floor b \<or> floor b <\<^sup>I floor a"
     using trichotomy floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1 
     then 
     show ?thesis
       using sum_mult_not_one assms floor_prop by metis
   next 
     case 2
     then
     show ?thesis
       using assms by auto
   qed
 qed
 
 lemma sum_mult_closed:
   assumes "a \<in> S" "b \<in> S"
   shows "a *\<^sup>S b \<in> S"
   using sum_mult_closed_not_one sum_mult_closed_one assms by auto
 
 lemma sum_imp_closed_one:
   assumes "a \<in> S" "b \<in> S" "a = 1\<^sup>S \<or> b = 1\<^sup>S"
   shows "a \<rightarrow>\<^sup>S b \<in> S"
   using sum_imp.simps(4-6) assms floor.cases by metis
 
 lemma sum_imp_closed_not_one:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}"
   shows "a \<rightarrow>\<^sup>S b \<in> S"
 proof -
   from assms
   consider (1) "floor a = floor b"
     | (2) "floor a <\<^sup>I floor b \<or> floor b <\<^sup>I floor a"
     using trichotomy floor_prop by blast
   then
   show "a \<rightarrow>\<^sup>S b \<in> S"
   proof(cases)
     case 1 
     then
     have "a \<rightarrow>\<^sup>S b = a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b" 
       using assms by auto
     moreover
     have "a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
       using "1" assms floor_imp_closed floor_prop by metis
     ultimately
     show ?thesis
       using sum_subsets assms(1) floor_prop by auto
   next
     case 2
     then
     show ?thesis
       using assms by auto
   qed
 qed
 
 lemma sum_imp_closed:
   assumes "a \<in> S" "b \<in> S"
   shows "a \<rightarrow>\<^sup>S b \<in> S"
   using sum_imp_closed_one sum_imp_closed_not_one assms by auto
 
 subsubsection\<open>Neutrality of @{term sum_one}\<close>
 
 lemma sum_mult_neutr:
   assumes "a \<in> S"
   shows "a *\<^sup>S 1\<^sup>S = a \<and> 1\<^sup>S *\<^sup>S a = a"
   using assms sum_mult.simps(4-6) by blast
 
 subsubsection\<open>Commutativity of @{term sum_mult}\<close>
 
 text\<open>Now we prove @{term "x *\<^sup>S y = y *\<^sup>S x"} by showing
 that it holds when one of the variables is equal to @{term "1\<^sup>S"}. Then
 we consider when none of them is @{term "1\<^sup>S"}.\<close>
 
 lemma sum_mult_comm_one: 
   assumes "a \<in> S" "b \<in> S" "a = 1\<^sup>S \<or> b = 1\<^sup>S" 
   shows "a *\<^sup>S b = b *\<^sup>S a"
   using sum_mult_neutr assms by auto
 
 lemma sum_mult_comm_not_one: 
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}"
   shows "a *\<^sup>S b = b *\<^sup>S a"
 proof -
   from assms
   consider (1) "floor a = floor b"
     | (2) "floor a <\<^sup>I floor b \<or> floor b <\<^sup>I floor a"
     using trichotomy floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then 
     have same_floor: "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
       using assms(2) floor_prop by simp
     then
     have "a *\<^sup>S b = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b"
       using sum_mult_A assms(1) by blast
     also
     have "\<dots> = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a"
       using assms(1) family_of_hoops floor_prop hoop.mult_comm same_floor
       by meson
     also
     have "\<dots> = b *\<^sup>S a"
       using sum_mult_A assms(1) same_floor by simp
     finally 
     show ?thesis
       by auto
   next
     case 2
     then
     show ?thesis
       using assms by auto
   qed
 qed
 
 lemma sum_mult_comm:
   assumes "a \<in> S" "b \<in> S"
   shows "a *\<^sup>S b = b *\<^sup>S a"
   using assms sum_mult_comm_one sum_mult_comm_not_one by auto
 
 subsubsection\<open>Associativity of @{term sum_mult}\<close>
 
 text\<open>Next we prove @{term "x *\<^sup>S (y *\<^sup>S z) = (x *\<^sup>S y) *\<^sup>S z"}.\<close>
 
 lemma sum_mult_assoc_one:
   assumes "a \<in> S" "b \<in> S" "c \<in> S" "a = 1\<^sup>S \<or> b = 1\<^sup>S \<or> c = 1\<^sup>S"
   shows "a *\<^sup>S (b *\<^sup>S c) = (a *\<^sup>S b) *\<^sup>S c" 
   using  sum_mult_neutr assms sum_mult_closed by metis
 
 lemma sum_mult_assoc_not_one:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}" "c \<in> S-{1\<^sup>S}"
   shows "a *\<^sup>S (b *\<^sup>S c) = (a *\<^sup>S b) *\<^sup>S c"
 proof -
   from assms
   consider (1) "floor a = floor b" "floor b = floor c"
     | (2) "floor a = floor b" "floor b <\<^sup>I floor c"
     | (3) "floor a = floor b" "floor c <\<^sup>I floor b"
     | (4) "floor a <\<^sup>I floor b" "floor b = floor c"
     | (5) "floor a <\<^sup>I floor b" "floor b <\<^sup>I floor c"
     | (6) "floor a <\<^sup>I floor b" "floor c <\<^sup>I floor b"
     | (7) "floor b <\<^sup>I floor a" "floor b = floor c"
     | (8) "floor b <\<^sup>I floor a" "floor b <\<^sup>I floor c"
     | (9) "floor b <\<^sup>I floor a" "floor c <\<^sup>I floor b"
      using trichotomy floor_prop by meson
   then
   show ?thesis
   proof(cases)
     case 1
     then
     have "a *\<^sup>S (b *\<^sup>S c) = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c)"
       using sum_mult_A assms floor_mult_closed floor_prop by metis
     also
     have "\<dots> = (a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b) *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c"
       using "1" assms family_of_hoops floor_prop hoop.mult_assoc by metis
     also 
     have "\<dots> = (a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b b) *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b c"
       using "1" by simp
     also
     have "\<dots> = (a *\<^sup>S b) *\<^sup>S c"
       using "1" sum_mult_A assms floor_mult_closed floor_prop by metis
     finally
     show ?thesis 
       by auto
   next
     case 2 
     then
     show ?thesis
       using sum_mult.simps(2,3) sum_mult_not_one assms floor_prop by metis
   next
     case 3
     then
     show ?thesis
       using sum_mult.simps(3) sum_mult_not_one assms floor_prop by metis
   next
     case 4
     then
     show ?thesis
       using sum_mult.simps(2) sum_mult_not_one assms floor_prop by metis
   next
     case 5
     then
     show ?thesis
       using sum_mult.simps(2) assms floor_prop strict_trans by metis
   next
     case 6
     then
     show ?thesis
       using sum_mult.simps(2,3) assms by metis
   next
     case 7
     then
     show ?thesis
       using sum_mult.simps(3) sum_mult_not_one assms floor_prop by metis
   next
     case 8
     then
     show ?thesis
       using sum_mult.simps(2,3) assms by metis
   next
     case 9
     then 
     show ?thesis
       using sum_mult.simps(3) assms floor_prop strict_trans by metis
   qed
 qed
 
 lemma sum_mult_assoc:
   assumes "a \<in> S" "b \<in> S" "c \<in> S"
   shows "a *\<^sup>S (b *\<^sup>S c) = (a *\<^sup>S b) *\<^sup>S c"
   using assms sum_mult_assoc_one sum_mult_assoc_not_one by blast
 
 subsubsection\<open>Reflexivity of @{term sum_imp}\<close>
 
 lemma sum_imp_reflex:
   assumes "a \<in> S"
   shows "a \<rightarrow>\<^sup>S a = 1\<^sup>S"
 proof -
   consider (1) "a \<in> S-{1\<^sup>S}"
     | (2) "a = 1\<^sup>S"
     using assms by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then 
     have "a \<rightarrow>\<^sup>S a = a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a"
       by simp
     then
     show ?thesis
       using "1" family_of_hoops floor_prop hoop.imp_reflex by metis
   next
     case 2
     then 
     show ?thesis
       by simp
   qed
 qed
 
 subsubsection\<open>Divisibility\<close>
 
 text\<open>We prove @{term "x *\<^sup>S (x \<rightarrow>\<^sup>S y) = y *\<^sup>S (y \<rightarrow>\<^sup>S x)"} using the same methods as before.\<close>
 
 lemma sum_divisibility_one:
   assumes "a \<in> S" "b \<in> S" "a = 1\<^sup>S \<or> b = 1\<^sup>S"
   shows  "a *\<^sup>S (a \<rightarrow>\<^sup>S b) = b *\<^sup>S (b \<rightarrow>\<^sup>S a)"
 proof -
   have "x \<rightarrow>\<^sup>S y = y \<and> y \<rightarrow>\<^sup>S x = 1\<^sup>S" if "x = 1\<^sup>S" "y \<in> S" for x y
     using sum_imp_D sum_imp_E that by simp
   then
   show ?thesis
     using assms sum_mult_neutr by metis
 qed
 
 lemma sum_divisibility_aux:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> \<bbbA>\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a"
   shows "a *\<^sup>S (a \<rightarrow>\<^sup>S b) = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b)"
   using sum_imp_A sum_mult_A assms floor_imp_closed floor_prop by metis
 
 lemma sum_divisibility_not_one:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}"
   shows "a *\<^sup>S (a \<rightarrow>\<^sup>S b) = b *\<^sup>S (b \<rightarrow>\<^sup>S a)"
 proof -
   from assms
   consider (1) "floor a = floor b"
     | (2) "floor a <\<^sup>I floor b \<or> floor b <\<^sup>I floor a"
     using trichotomy floor_prop by blast
   then
   show ?thesis
   proof(cases)
     case 1
     then
     have "a *\<^sup>S (a \<rightarrow>\<^sup>S b) =  a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b)"
       using "1" sum_divisibility_aux assms floor_prop by metis
     also
     have "\<dots> = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (b \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a)"
       using "1" assms family_of_hoops floor_prop hoop.divisibility by metis
     also
     have "\<dots> = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b (b \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b a)"
       using "1" by simp
     also
     have "\<dots> = b *\<^sup>S (b \<rightarrow>\<^sup>S a)"
       using "1" sum_divisibility_aux assms floor_prop by metis
     finally
     show ?thesis
       by auto
   next 
     case 2
     then
     show ?thesis
       using assms by auto
   qed
 qed
 
 lemma sum_divisibility:
   assumes "a \<in> S" "b \<in> S"
   shows "a *\<^sup>S (a \<rightarrow>\<^sup>S b) = b *\<^sup>S (b \<rightarrow>\<^sup>S a)"
   using assms sum_divisibility_one sum_divisibility_not_one by auto
 
 subsubsection\<open>Residuation\<close>
 
 text\<open>Finally we prove @{term "(x *\<^sup>S y) \<rightarrow>\<^sup>S z = (x \<rightarrow>\<^sup>S (y \<rightarrow>\<^sup>S z))"}.\<close>
 
 lemma sum_residuation_one:
   assumes "a \<in> S" "b \<in> S" "c \<in> S" "a = 1\<^sup>S \<or> b = 1\<^sup>S \<or> c = 1\<^sup>S"
   shows "(a *\<^sup>S b) \<rightarrow>\<^sup>S c = a \<rightarrow>\<^sup>S (b \<rightarrow>\<^sup>S c)"
   using sum_imp_D sum_imp_E sum_imp_closed sum_mult_closed sum_mult_neutr
         assms
   by metis
 
 lemma sum_residuation_not_one:
   assumes "a \<in> S-{1\<^sup>S}" "b \<in> S-{1\<^sup>S}" "c \<in> S-{1\<^sup>S}"
   shows "(a *\<^sup>S b) \<rightarrow>\<^sup>S c = a \<rightarrow>\<^sup>S (b \<rightarrow>\<^sup>S c)"
 proof -
   from assms
    consider (1) "floor a = floor b" "floor b = floor c"
     | (2) "floor a = floor b" "floor b <\<^sup>I floor c"
     | (3) "floor a = floor b" "floor c <\<^sup>I floor b"
     | (4) "floor a <\<^sup>I floor b" "floor b = floor c"
     | (5) "floor a <\<^sup>I floor b" "floor b <\<^sup>I floor c"
     | (6) "floor a <\<^sup>I floor b" "floor c <\<^sup>I floor b"
     | (7) "floor b <\<^sup>I floor a" "floor b = floor c"
     | (8) "floor b <\<^sup>I floor a" "floor b <\<^sup>I floor c"
     | (9) "floor b <\<^sup>I floor a" "floor c <\<^sup>I floor b"
      using trichotomy floor_prop by meson
   then
   show ?thesis
   proof(cases)
     case 1
     then
     have "(a *\<^sup>S b) \<rightarrow>\<^sup>S c = (a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b) \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c"
       using sum_imp_B sum_mult_A assms floor_mult_closed floor_prop by metis
     also
     have "\<dots> = a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (b \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c)"
       using "1" assms family_of_hoops floor_prop hoop.residuation by metis
     also
     have "\<dots> = a \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b (b \<rightarrow>\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b c)"
       using "1" by simp
     also
     have "\<dots> = a \<rightarrow>\<^sup>S (b \<rightarrow>\<^sup>S c)"
       using "1" sum_imp_A assms floor_imp_closed floor_prop by metis
     finally
     show ?thesis
       by auto
   next
     case 2
     then
     show ?thesis
       using sum_imp.simps(2,5) sum_mult_not_one assms floor_prop by metis
   next
     case 3
     then
     show ?thesis
       using sum_imp.simps(3) sum_mult_not_one assms floor_prop by metis
   next
     case 4
     then
     have "(a *\<^sup>S b) \<rightarrow>\<^sup>S c = 1\<^sup>S"
       using "4" sum_imp.simps(2) sum_mult.simps(2) assms by metis
     moreover
     have "b \<rightarrow>\<^sup>S c = 1\<^sup>S \<or> (b \<rightarrow>\<^sup>S c \<in> S-{1\<^sup>S} \<and> floor (b \<rightarrow>\<^sup>S c) = floor b)"
       using "4"(2) sum_imp_closed_not_one sum_imp_floor assms(2,3) by blast
     ultimately 
     show ?thesis
       using "4"(1) sum_imp.simps(2,5) assms(1) by metis
   next
     case 5
     then
     show ?thesis  
       using sum_imp.simps(2,5) sum_mult.simps(2) assms floor_prop strict_trans
       by metis
   next
     case 6
     then
     show ?thesis
       using assms by auto
   next
     case 7
     then
     have "(a *\<^sup>S b) \<rightarrow>\<^sup>S c = (b \<rightarrow>\<^sup>S c)"
       using assms(1,2) by auto
     moreover
     have "b \<rightarrow>\<^sup>S c = 1\<^sup>S \<or> (b \<rightarrow>\<^sup>S c \<in> S-{1\<^sup>S} \<and> floor (b \<rightarrow>\<^sup>S c) = floor b)"
       using "7"(2) sum_imp_closed_not_one sum_imp_floor assms(2,3) by blast
     ultimately
     show ?thesis
       using "7"(1) sum_imp.simps(3,5) assms(1) by metis
   next
     case 8
     then
     show ?thesis
       using assms by auto
   next
     case 9
     then
     show ?thesis
       using sum_imp.simps(3) sum_mult.simps(3) assms floor_prop strict_trans 
       by metis
   qed
 qed
 
 lemma sum_residuation:
   assumes "a \<in> S" "b \<in> S" "c \<in> S"
   shows "(a *\<^sup>S b) \<rightarrow>\<^sup>S c = a \<rightarrow>\<^sup>S (b \<rightarrow>\<^sup>S c)"
   using assms sum_residuation_one sum_residuation_not_one by blast
 
 subsubsection\<open>Main result\<close>
 
 sublocale hoop "S" "(*\<^sup>S)" "(\<rightarrow>\<^sup>S)" "1\<^sup>S"
 proof
   show "x *\<^sup>S y \<in> S" if "x \<in> S" "y \<in> S" for x y
     using that sum_mult_closed by simp
 next
   show "x \<rightarrow>\<^sup>S y \<in> S" if "x \<in> S" "y \<in> S" for x y
     using that sum_imp_closed by simp
 next
   show "1\<^sup>S \<in> S"
     by simp
 next
   show "x *\<^sup>S y = y *\<^sup>S x" if "x \<in> S" "y \<in> S" for x y
     using that sum_mult_comm by simp
 next
   show "x *\<^sup>S (y *\<^sup>S z) = (x *\<^sup>S y) *\<^sup>S z" if "x \<in> S" "y \<in> S" "z \<in> S" for x y z 
     using that sum_mult_assoc by simp
 next
   show "x *\<^sup>S 1\<^sup>S = x" if "x \<in> S" for x
     using that sum_mult_neutr by simp
 next
   show "x \<rightarrow>\<^sup>S x = 1\<^sup>S" if "x \<in> S" for x
     using that sum_imp_reflex by simp
 next
   show "x *\<^sup>S (x \<rightarrow>\<^sup>S y) = y *\<^sup>S (y \<rightarrow>\<^sup>S x)" if "x \<in> S" "y \<in> S" for x y
     using that sum_divisibility by simp
 next
   show "x \<rightarrow>\<^sup>S (y \<rightarrow>\<^sup>S z) = (x *\<^sup>S y) \<rightarrow>\<^sup>S z" if "x \<in> S" "y \<in> S" "z \<in> S" for x y z
     using that sum_residuation by simp
 qed
 
 end
                                          
 end
\ No newline at end of file
diff --git a/thys/Isabelle_hoops/Posets.thy b/thys/Isabelle_hoops/Posets.thy
--- a/thys/Isabelle_hoops/Posets.thy
+++ b/thys/Isabelle_hoops/Posets.thy
@@ -1,57 +1,57 @@
 section\<open>Some order tools: posets with explicit universe\<close>
 
 theory Posets
 imports Main "HOL-Library.LaTeXsugar"
 
 begin
 
 locale poset_on =
   fixes P :: "'b set"
   fixes P_lesseq :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<le>\<^sup>P" 60) 
   fixes P_less :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "<\<^sup>P" 60)
   assumes not_empty [simp]: "P \<noteq> \<emptyset>"
   and reflex: "reflp_on P (\<le>\<^sup>P)"
   and antisymm: "antisymp_on P (\<le>\<^sup>P)"
   and trans: "transp_on P (\<le>\<^sup>P)"
   and strict_iff_order: "x \<in> P \<Longrightarrow> y \<in> P \<Longrightarrow> x <\<^sup>P y = (x \<le>\<^sup>P y \<and> x \<noteq> y)"
 begin
 
 lemma strict_trans:
   assumes "a \<in> P" "b \<in> P" "c \<in> P" "a <\<^sup>P b" "b <\<^sup>P c"
   shows "a <\<^sup>P c"
   using antisymm antisymp_onD assms trans strict_iff_order transp_onD
-  by smt 
+  by (smt (verit, ccfv_SIG))
 
 end
 
 locale bot_poset_on = poset_on +
   fixes bot :: "'b" ("0\<^sup>P")
   assumes bot_closed: "0\<^sup>P \<in> P"
   and bot_first: "x \<in> P \<Longrightarrow> 0\<^sup>P \<le>\<^sup>P x"
 
 locale top_poset_on = poset_on +
   fixes top :: "'b" ("1\<^sup>P")
   assumes top_closed: "1\<^sup>P \<in> P"
   and top_last: "x \<in> P \<Longrightarrow> x \<le>\<^sup>P 1\<^sup>P"
 
 locale bounded_poset_on  = bot_poset_on + top_poset_on
 
 locale total_poset_on = poset_on +
   assumes total: "totalp_on P (\<le>\<^sup>P)"
 begin
 
 lemma trichotomy:
   assumes "a \<in> P" "b \<in> P"
   shows "(a <\<^sup>P b \<and> \<not>(a = b \<or> b <\<^sup>P a)) \<or>
          (a = b \<and> \<not>(a <\<^sup>P b \<or> b <\<^sup>P a)) \<or>
          (b <\<^sup>P a \<and> \<not>(a = b \<or> a <\<^sup>P b))"
   using  antisymm antisymp_onD assms strict_iff_order total totalp_onD by metis
 
 lemma strict_order_equiv_not_converse: 
   assumes "a \<in> P" "b \<in> P"
   shows "a <\<^sup>P b \<longleftrightarrow> \<not>(b \<le>\<^sup>P a)"
   using assms strict_iff_order reflex reflp_onD strict_trans trichotomy by metis
 
 end
      
 end
\ No newline at end of file
diff --git a/thys/KD_Tree/Range_Search.thy b/thys/KD_Tree/Range_Search.thy
--- a/thys/KD_Tree/Range_Search.thy
+++ b/thys/KD_Tree/Range_Search.thy
@@ -1,87 +1,88 @@
 (*
   File:     Range_Search.thy
   Author:   Martin Rau, TU München
 *)
 
 section \<open>Range Searching\<close>
 
 theory Range_Search
 imports
   KD_Tree
 begin
 
 text\<open>
   Given two \<open>k\<close>-dimensional points \<open>p\<^sub>0\<close> and \<open>p\<^sub>1\<close> which bound the search space, the search should
   return only the points which satisfy the following criteria:
 
   For every point p in the resulting set: \newline
   \hspace{1cm}  For every axis @{term "k"}: \newline
   \hspace{2cm}    @{term "p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k"} \newline
 
   For a \<open>2\<close>-d tree a query corresponds to selecting all the points in the rectangle that
   has \<open>p\<^sub>0\<close> and \<open>p\<^sub>1\<close> as its defining edges.
 \<close>
 
 subsection \<open>Rectangle Definition\<close>
 
 lemma cbox_point_def:
   fixes p\<^sub>0 :: "('k::finite) point"
   shows "cbox p\<^sub>0 p\<^sub>1 = { p. \<forall>k. p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k }"
 proof -
   have "cbox p\<^sub>0 p\<^sub>1 = { p. \<forall>k. p\<^sub>0 \<bullet> axis k 1 \<le> p \<bullet> axis k 1 \<and> p \<bullet> axis k 1 \<le> p\<^sub>1 \<bullet> axis k 1 }"
     unfolding cbox_def using axis_inverse by auto
   also have "... = { p. \<forall>k. p\<^sub>0$k \<bullet> 1 \<le> p$k \<bullet> 1 \<and> p$k \<bullet> 1 \<le> p\<^sub>1$k \<bullet> 1 }"
-    using inner_axis[of _ _ 1] by (smt Collect_cong)
+    using inner_axis[of _ _ 1]
+    by (metis (mono_tags, opaque_lifting))
   also have "... = { p. \<forall>k. p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k }"
     by simp
   finally show ?thesis .
 qed
 
 
 subsection \<open>Search Function\<close>
 
 fun search :: "('k::finite) point \<Rightarrow> 'k point \<Rightarrow> 'k kdt \<Rightarrow> 'k point set" where
   "search p\<^sub>0 p\<^sub>1 (Leaf p) = (if p \<in> cbox p\<^sub>0 p\<^sub>1 then { p } else {})"
 | "search p\<^sub>0 p\<^sub>1 (Node k v l r) = (
     if v < p\<^sub>0$k then
       search p\<^sub>0 p\<^sub>1 r
     else if p\<^sub>1$k < v then
       search p\<^sub>0 p\<^sub>1 l
     else
       search p\<^sub>0 p\<^sub>1 l \<union> search p\<^sub>0 p\<^sub>1 r
   )"
 
 
 subsection \<open>Auxiliary Lemmas\<close>
 
 lemma l_empty:
   assumes "invar (Node k v l r)" "v < p\<^sub>0$k"
   shows "set_kdt l \<inter> cbox p\<^sub>0 p\<^sub>1 = {}"
 proof -
   have "\<forall>p \<in> set_kdt l. p$k < p\<^sub>0$k"
     using assms by auto
   hence "\<forall>p \<in> set_kdt l. p \<notin> cbox p\<^sub>0 p\<^sub>1"
     using cbox_point_def leD by blast
   thus ?thesis by blast
 qed
 
 lemma r_empty:
   assumes "invar (Node k v l r)" "p\<^sub>1$k < v"
   shows "set_kdt r \<inter> cbox p\<^sub>0 p\<^sub>1 = {}"
 proof -
   have "\<forall>p \<in> set_kdt r. p\<^sub>1$k < p$k"
     using assms by auto
   hence "\<forall>p \<in> set_kdt r. p \<notin> cbox p\<^sub>0 p\<^sub>1"
     using cbox_point_def leD by blast
   thus ?thesis by blast
 qed
 
 
 subsection \<open>Main Theorem\<close>
 
 theorem search_cbox:
   assumes "invar kdt"
   shows "search p\<^sub>0 p\<^sub>1 kdt = set_kdt kdt \<inter> cbox p\<^sub>0 p\<^sub>1"
   using assms l_empty r_empty by (induction kdt) (auto, blast+)
 
 end
diff --git a/thys/Lucas_Theorem/Lucas_Theorem.thy b/thys/Lucas_Theorem/Lucas_Theorem.thy
--- a/thys/Lucas_Theorem/Lucas_Theorem.thy
+++ b/thys/Lucas_Theorem/Lucas_Theorem.thy
@@ -1,372 +1,373 @@
 (* 
   Title: Lucas_Theorem.thy
   Author: Chelsea Edmonds, University of Cambridge
 *)
 
 theory Lucas_Theorem
   imports Main "HOL-Computational_Algebra.Computational_Algebra"
 begin
 
 notation fps_nth (infixl "$" 75)
 
 section \<open>Extensions on Formal Power Series (FPS) Library\<close>
 
 text \<open>This section presents a few extensions on the Formal Power Series (FPS) library, described in \<^cite>\<open>"Chaieb2011"\<close> \<close>
 
 subsection \<open>FPS Equivalence Relation \<close>
 
 text \<open> This proof requires reasoning around the equivalence of coefficients mod some prime number. 
 This section defines an equivalence relation on FPS using the pattern described by Paulson 
 in \<^cite>\<open>"paulsonDefiningFunctionsEquivalence2006"\<close>, as well as some basic lemmas for reasoning around 
 how the equivalence holds after common operations are applied \<close>
 
 definition "fpsmodrel p \<equiv> { (f, g). \<forall> n. (f $ n) mod p = (g $ n) mod p }"
 
 lemma fpsrel_iff [simp]: "(f, g) \<in> fpsmodrel p \<longleftrightarrow> (\<forall>n. (f $ n) mod p = (g $ n) mod p)"
   by (simp add: fpsmodrel_def)
 
 lemma fps_equiv: "equiv UNIV (fpsmodrel p)" 
 proof (rule equivI)
   show "refl (fpsmodrel p)" by (simp add: refl_on_def fpsmodrel_def)
   show "sym (fpsmodrel p)" by (simp add: sym_def fpsmodrel_def)
   show "trans (fpsmodrel p)" by (intro transI) (simp add: fpsmodrel_def)
 qed
 
 text \<open> Equivalence relation over multiplication \<close>
 
 lemma fps_mult_equiv_coeff: 
   fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
   assumes "(f, g) \<in> fpsmodrel p"
   shows "(f*h)$n mod p = (g*h)$n mod p" 
 proof -
   have "((f*h) $ n) mod p =(\<Sum>i=0..n. (f$i mod p * h$(n - i) mod p) mod p) mod p"
     using mod_sum_eq mod_mult_left_eq
     by (simp add: fps_mult_nth mod_sum_eq mod_mult_left_eq)
   also have "... = (\<Sum>i=0..n. (g$i mod p * h$(n - i) mod p) mod p) mod p"
     using assms by auto 
   also have "... = ((g*h) $ n) mod p"
     by (simp add: mod_mult_left_eq mod_sum_eq fps_mult_nth)
   thus ?thesis by (simp add: calculation)  
 qed
 
 lemma fps_mult_equiv: 
   fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
   assumes "(f, g) \<in> fpsmodrel p"
   shows "(f*h, g*h) \<in> fpsmodrel p"
   using fpsmodrel_def fps_mult_equiv_coeff assms by blast 
 
 
 text \<open> Equivalence relation over power operator \<close>
 lemma fps_power_equiv: 
   fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
   fixes x :: nat
   assumes "(f, g) \<in> fpsmodrel p"
   shows "(f^x, g^x) \<in> fpsmodrel p"
   using assms
 proof (induct x)
   case 0
   thus ?case by (simp add: fpsmodrel_def)
 next
   case (Suc x)
   then have hyp: " \<forall>n. f^x $ n mod p = g ^x $ n mod p" 
     using fpsrel_iff by blast 
   thus ?case 
   proof -
     have fact: "\<forall>n h. (g * h) $ n mod p = (f * h) $ n mod p"
       by (metis assms fps_mult_equiv_coeff)
     have "\<forall>n h. (g ^ x * h) $ n mod p = (f ^ x * h) $ n mod p"
       by (simp add: fps_mult_equiv_coeff hyp)
     then have "\<forall>n h. (h * g ^ x) $ n mod p = (h * f ^ x) $ n mod p"
       by (simp add: mult.commute)
     thus ?thesis
       using fact by force
   qed
 qed
 
 subsection \<open>Binomial Coefficients \<close>
 
 text \<open>The @{term "fps_binomial"} definition in the formal power series uses the @{term "n gchoose k"} operator. It's 
 defined as being of type @{typ "'a :: field_char_0 fps"}, however the equivalence relation requires a type @{typ 'a} 
 that supports the modulo operator. 
 The proof of the binomial theorem based on FPS coefficients below uses the choose operator and does
 not put bounds on the type of @{term "fps_X"}.\<close> 
 
 lemma binomial_coeffs_induct: 
   fixes n k :: nat
   shows "(1 + fps_X)^n $ k = of_nat(n choose k)"
 proof (induct n arbitrary: k)
   case 0
   thus ?case
     by (metis binomial_eq_0_iff binomial_n_0 fps_nth_of_nat not_gr_zero of_nat_0 of_nat_1 power_0) 
 next
   case h: (Suc n)
-  fix k 
   have start: "(1 + fps_X)^(n + 1) = (1 + fps_X) * (1 + fps_X)^n" by auto
   show ?case 
     using One_nat_def Suc_eq_plus1 Suc_pred add.commute binomial_Suc_Suc binomial_n_0 
-        fps_mult_fps_X_plus_1_nth h.hyps neq0_conv start by (smt of_nat_add)  
+        fps_mult_fps_X_plus_1_nth h.hyps neq0_conv start
+    by (smt (verit, del_insts) of_nat_add)
 qed
 
 subsection \<open>Freshman's Dream Lemma on FPS \<close>
 text \<open> The Freshman's dream lemma modulo a prime number $p$ is a well known proof that $(1 + x^p) \equiv (1 + x)^p \mod p$\<close>
 
 text \<open> First prove that $\binom{p^n}{k} \equiv 0 \mod p$ for $k \ge 1$ and $k < p^n$. The eventual
 proof only ended up requiring this with $n = 1$\<close>
 
 lemma pn_choose_k_modp_0:
   fixes n k::nat
   assumes "prime p"
           "k \<ge> 1 \<and> k \<le> p^n - 1"
           "n > 0"
   shows "(p^n choose k) mod p = 0"
 proof - 
   have inequality: "k \<le> p^n" using assms (2) by arith
   have choose_take_1: "((p^n - 1) choose ( k - 1))= fact (p^n - 1) div (fact (k - 1) * fact (p^n - k))"
     using binomial_altdef_nat diff_le_mono inequality assms(2) by auto
   have "k * (p^n choose k) = k * ((fact (p^n)) div (fact k * fact((p^n) - k)))" 
     using assms binomial_fact'[OF inequality] by auto
   also have "... = k * fact (p^n) div (fact k * fact((p^n) - k))"
     using binomial_fact_lemma div_mult_self_is_m fact_gt_zero inequality mult.assoc mult.commute 
-          nat_0_less_mult_iff by smt
+          nat_0_less_mult_iff
+    by (simp add: choose_dvd div_mult_swap)
   also have "... = k * fact (p^n) div (k * fact (k - 1) * fact((p^n) - k))" 
     by (metis assms(2) fact_nonzero fact_num_eq_if le0 le_antisym of_nat_id)
   also have "... = fact (p^n) div (fact (k - 1) * fact((p^n) - k))" 
     using assms by auto
   also have "... = ((p^n) * fact (p^n - 1)) div (fact (k - 1) * fact((p^n) - k))"
     by (metis assms(2) fact_nonzero fact_num_eq_if inequality le0 le_antisym of_nat_id)
   also have "... = (p^n) * (fact (p^n - 1) div (fact (k - 1) * fact((p^n) - k)))"
     by (metis assms(2) calculation choose_take_1 neq0_conv not_one_le_zero times_binomial_minus1_eq)
   finally have equality: "k * (p^n choose k) = p^n * ((p^n - 1) choose (k - 1))"
     using assms(2) times_binomial_minus1_eq by auto
   then have dvd_result: "p^n dvd (k * (p^n choose k))" by simp 
   have "\<not> (p^n dvd k)" 
     using assms (2) binomial_n_0 diff_diff_cancel nat_dvd_not_less neq0_conv by auto  
   then have "p dvd (p^n choose k)" 
     using mult.commute prime_imp_prime_elem prime_power_dvd_multD assms dvd_result by metis
   thus "?thesis" by simp 
 qed
 
 text \<open> Applying the above lemma to the coefficients of $(1 + X)^p$, it is easy to show that all 
 coefficients other than the $0$th and $p$th will be $0$ \<close>
 
 lemma fps_middle_coeffs:
   assumes "prime p"
           "n \<noteq> 0 \<and> n \<noteq> p"
   shows "((1 + fps_X :: int fps) ^p) $ n mod p = 0 mod p"
 proof -
   let ?f = "(1 + fps_X :: int fps)^p"
   have "\<forall> n. n > 0 \<and> n < p \<longrightarrow> (p choose n) mod p = 0"
     using pn_choose_k_modp_0 [of p _ 1] \<open>prime p\<close> by auto
   then have middle_0: "\<forall> n. n > 0 \<and> n < p \<longrightarrow> (?f $ n) mod p = 0" 
     using binomial_coeffs_induct by (metis of_nat_0 zmod_int) 
   have "\<forall> n. n > p \<longrightarrow> ?f $ n mod p = 0" 
     using binomial_eq_0_iff binomial_coeffs_induct mod_0 by (metis of_nat_eq_0_iff) 
   thus ?thesis using middle_0 assms(2) nat_neq_iff by auto
 qed
 
 text \<open>It follows that $(1+ X)^p$ is equivalent to $(1 + X^p)$ under our equivalence relation, 
 as required to prove the freshmans dream lemma. \<close>
 
 lemma fps_freshmans_dream:
   assumes "prime p"
   shows "(((1 + fps_X :: int fps ) ^p), (1 + (fps_X)^(p))) \<in> fpsmodrel p"
 proof -
   let ?f = "(1 + fps_X :: int fps)^p"
   let ?g = "(1 + (fps_X :: int fps)^p)"
   have all_f_coeffs: "\<forall> n. n \<noteq> 0 \<and> n \<noteq> p \<longrightarrow> ?f $ n mod p = 0 mod p" 
     using fps_middle_coeffs assms by blast 
   have "?g $ 0 = 1" using assms by auto 
   then have "?g $ 0 mod p = 1 mod p" 
     using int_ops(2) zmod_int assms by presburger 
   then have "?g $ p mod p = 1 mod p" using assms by auto 
   then have "\<forall> n . ?f $ n mod p = ?g $ n mod p" 
     using all_f_coeffs by (simp add: binomial_coeffs_induct)
   thus ?thesis using fpsrel_iff by blast
 qed
 
 section \<open>Lucas's Theorem Proof\<close>
 
 text \<open>A formalisation of Lucas's theorem based on a generating function proof using the existing formal power series (FPS) Isabelle library\<close>
 
 subsection \<open>Reasoning about Coefficients Helpers\<close>
 
 text \<open>A generating function proof of Lucas's theorem relies on direct comparison between coefficients of FPS which requires a number 
 of helper lemmas to prove formally. In particular it compares the coefficients of 
 $(1 + X)^n \mod p$ to $(1 + X^p)^N * (1 + X) ^rn \mod p$, where $N = n / p$, and $rn = n \mod p$.
 This section proves that the $k$th coefficient of $(1 + X^p)^N * (1 + X) ^rn = (N choose K) * (rn choose rk)$\<close>
 
 text \<open>Applying the @{term "fps_compose"} operator enables reasoning about the coefficients of $(1 + X^p)^n$ 
 using the existing binomial theorem proof with $X^p$ instead of $X$.\<close>
 
 lemma fps_binomial_p_compose: 
   assumes "p \<noteq> 0" 
   shows "(1 + (fps_X:: ('a :: {idom} fps))^p)^n = ((1 + fps_X)^n) oo (fps_X^p)"
 proof -
   have "(1::'a fps) + fps_X ^ p = 1 + fps_X oo fps_X ^ p"
     by (simp add: assms fps_compose_add_distrib)
   then show ?thesis
     by (simp add: assms fps_compose_power)
 qed
 
 text \<open> Next the proof determines the value of the $k$th coefficient of $(1 + X^p)^N$. \<close> 
 
 lemma fps_X_pow_binomial_coeffs: 
   assumes "prime p"
   shows "(1 + (fps_X ::int fps)^p)^N $k = (if p dvd k then (N choose (k div p)) else 0)"
 proof -
   let ?fx = "(fps_X :: int fps)"
   have "(1 + ?fx^p)^N $ k  = (((1 + ?fx)^N) oo (?fx^p)) $k"
     by (metis assms fps_binomial_p_compose not_prime_0)
   also have "... = (\<Sum>i=0..k.((1 + ?fx)^N)$i * ((?fx^p)^i$k))"
     by (simp add: fps_compose_nth) 
   finally have coeffs: "(1 + ?fx^p)^N $ k = (\<Sum>i=0..k. (N choose i) * ((?fx^(p*i))$k))"
     using binomial_coeffs_induct sum.cong by (metis (no_types, lifting) power_mult) 
   thus ?thesis 
   proof (cases "p dvd k")
     case False \<comment> \<open>$p$ does not divide $k$ implies the $k$th term has a coefficient of 0\<close> 
     have "\<forall> i. \<not>(p dvd k) \<longrightarrow> (?fx^(p*i)) $ k = 0"
       by auto 
     thus ?thesis using coeffs by (simp add: False) 
   next
     case True \<comment> \<open>$p$ divides $k$ implies the $k$th term has a non-zero coefficient\<close>
     have contained: "k div p \<in> {0.. k}" by simp
     have "\<forall> i. i \<noteq> k div p \<longrightarrow> (?fx^(p*i)) $ k = 0" using assms by auto
     then have notdivpis0: "\<forall> i \<in> ({0 .. k} - {k div p}). (?fx^(p*i)) $ k = 0" by simp
     have "(1 + ?fx^p)^N $ k = (N choose (k div p)) * (?fx^(p * (k div p))) $ k + (\<Sum>i\<in>({0..k} -{k div p}). (N choose i) * ((?fx^(p*i))$k))"
       using contained coeffs sum.remove by (metis (no_types, lifting) finite_atLeastAtMost)
     thus ?thesis using notdivpis0 True by simp 
   qed
 qed
 
 text \<open> The final helper lemma proves the $k$th coefficient is equivalent to $\binom{?N}{?K}*\binom{?rn}{?rk}$ as required.\<close>
 lemma fps_div_rep_coeffs: 
   assumes "prime p"
   shows "((1 + (fps_X::int fps)^p)^(n div p) * (1 + fps_X)^(n mod p)) $ k = 
           ((n div p) choose (k div p)) * ((n mod p) choose (k mod p))"
     (is "((1 + (fps_X::int fps)^p)^?N * (1 + fps_X)^?rn) $ k = (?N choose ?K) * (?rn choose ?rk)")
 proof -
   \<comment> \<open>Initial facts with results around representation and 0 valued terms\<close>
   let ?fx = "fps_X :: int fps"
   have krep: "k - ?rk = ?K*p"
     by (simp add: minus_mod_eq_mult_div)
   have rk_in_range: "?rk \<in> {0..k}" by simp
   have "\<forall> i \<ge> p. (?rn choose i) = 0" 
     using binomial_eq_0_iff 
     by (metis assms(1) leD le_less_trans linorder_cases mod_le_divisor mod_less_divisor prime_gt_0_nat)
   then have ptok0: "\<forall> i \<in> {p..k}. ((?rn choose i) * (1 + ?fx^p)^?N $ (k - i)) = 0" 
     by simp
   then have notrkis0: "\<forall>i \<in> {0.. k}. i \<noteq> ?rk \<longrightarrow> (?rn choose i) * (1 + ?fx^p)^?N $ (k - i) = 0" 
   proof (cases "k < p")
     case True \<comment> \<open>When $k < p$, it presents a side case with regards to range of reasoning\<close>
     then have k_value: "k = ?rk" by simp
     then have "\<forall> i < k. \<not> (p dvd (k - i))" 
        using True by (metis diff_diff_cancel diff_is_0_eq dvd_imp_mod_0 less_imp_diff_less less_irrefl_nat mod_less)
     then show ?thesis using fps_X_pow_binomial_coeffs assms(1) k_value by simp
   next
     case False
     then have "\<forall> i < p. i \<noteq> ?rk \<longrightarrow> \<not>(p dvd (k - i))"
       using mod_nat_eqI by auto 
     then have "\<forall> i \<in> {0..<p}. i \<noteq> ?rk \<longrightarrow> (1 + ?fx^p)^?N $ (k - i) = 0" 
       using assms fps_X_pow_binomial_coeffs by simp
     then show ?thesis using ptok0 by auto 
   qed
   \<comment> \<open>Main body of the proof, using helper facts above\<close>
   have "((1 + fps_X^p)^?N * (1 + fps_X)^?rn) $ k = (((1 + fps_X)^?rn) * (1 + fps_X^p)^?N) $ k"
     by (metis (no_types, opaque_lifting) distrib_left distrib_right fps_mult_fps_X_commute fps_one_mult(1) 
         fps_one_mult(2) power_commuting_commutes)
   also have "... = (\<Sum>i=0..k.(of_nat(?rn choose i)) * ((1 + (fps_X)^p)^?N $ (k - i)))" 
     by (simp add: fps_mult_nth binomial_coeffs_induct) 
   also have "... =  ((?rn choose ?rk) * (1 + ?fx^p)^?N $ (k - ?rk)) + (\<Sum>i\<in>({0..k} - {?rk}). (?rn choose i) * (1 + ?fx^p)^?N $ (k - i))" 
     using rk_in_range sum.remove by (metis (no_types, lifting) finite_atLeastAtMost)
   finally have "((1 + ?fx^p)^?N * (1 + ?fx)^?rn) $ k = ((?rn choose ?rk) * (1 + ?fx^p)^?N $ (k - ?rk))" 
     using notrkis0 by simp
   thus ?thesis using fps_X_pow_binomial_coeffs assms krep by auto 
 qed
 
 (* Lucas theorem proof *) 
 subsection \<open>Lucas Theorem Proof\<close>
 
 text \<open> The proof of Lucas's theorem combines a generating function approach, based off \<^cite>\<open>"Fine"\<close> with induction.
 For formalisation purposes, it was easier to first prove a well known corollary of the main theorem (also 
 often presented as an alternative statement for Lucas's theorem), which can itself be used to backwards 
 prove the the original statement by induction.
 This approach was adapted from P. Cameron's lecture notes on combinatorics \<^cite>\<open>"petercameronNotesCombinatorics2007"\<close> \<close>
 
 subsubsection \<open> Proof of the Corollary \<close>
 text \<open> This step makes use of the coefficient equivalence arguments proved in the previous sections \<close>
 corollary lucas_corollary: 
   fixes n k :: nat
   assumes "prime p" 
   shows "(n choose k) mod p = (((n div p) choose (k div p)) * ((n mod p) choose (k mod p))) mod p" 
     (is "(n choose k) mod p = ((?N choose ?K) * (?rn choose ?rk)) mod p")
 proof -
   let ?fx = "fps_X :: int fps"
   have n_rep: "n = ?N * p  + ?rn"
     by simp
   have k_rep: "k =?K * p + ?rk" by simp
   have rhs_coeffs: "((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn)) $ k = (?N choose ?K) * (?rn choose ?rk)" 
     using assms fps_div_rep_coeffs k_rep n_rep by blast \<comment> \<open>Application of coefficient reasoning\<close>
   have "((((1 + ?fx)^p)^(?N) * (1 + ?fx)^(?rn)), 
           ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))) \<in> fpsmodrel p"
     using fps_freshmans_dream assms fps_mult_equiv fps_power_equiv by blast \<comment> \<open>Application of equivalence facts and freshmans dream lemma\<close>
   then have modrel2: "((1 + ?fx)^n, ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))) 
                           \<in> fpsmodrel p"
     by (metis (mono_tags, opaque_lifting) mult_div_mod_eq power_add power_mult)
   thus ?thesis
     using fpsrel_iff binomial_coeffs_induct rhs_coeffs by (metis of_nat_eq_iff zmod_int) 
 qed
 
 subsubsection \<open> Proof of the Theorem \<close>
 
 text \<open>The theorem statement requires a formalised way of referring to the base $p$ representation of a number. 
 We use a definition that specifies the $i$th digit of the base $p$ representation. This definition is originally 
 from the Hilbert's 10th Problem Formalisation project \<^cite>\<open>"bayerDPRMTheoremIsabelle2019"\<close> which this work contributes to.\<close>
 definition nth_digit_general :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
   "nth_digit_general num i base = (num div (base ^ i)) mod base"
 
 text \<open>Applying induction on $d$, where $d$ is the highest power required in either $n$ or $k$'s base $p$
 representation, @{thm lucas_corollary} can be used to prove the original theorem.\<close>
 
 theorem lucas_theorem:
   fixes n k d::nat
 assumes "n < p ^ (Suc d)"
 assumes "k < p ^ (Suc d)"
 assumes "prime p"
 shows "(n choose k) mod p = (\<Prod>i\<le>d. ((nth_digit_general n i p) choose (nth_digit_general k i p))) mod p"
   using assms
 proof (induct d arbitrary: n k)
   case 0
   thus ?case using nth_digit_general_def assms by simp
 next
   case (Suc d)
   \<comment> \<open>Representation Variables\<close>
   let ?N = "n div p"   
   let ?K = "k div p"
   let ?nr = "n mod p"
   let ?kr = "k mod p"
   \<comment> \<open>Required assumption facts\<close>
   have Mlessthan: "?N < p ^ (Suc d)" 
     using less_mult_imp_div_less power_Suc2 assms(3) prime_ge_2_nat Suc.prems(1) by metis 
   have Nlessthan: "?K < p ^ (Suc d)" 
     using less_mult_imp_div_less power_Suc2 prime_ge_2_nat Suc.prems(2) assms(3) by metis
   have shift_bounds_fact: "(\<Prod>i=(Suc 0)..(Suc (d )). ((nth_digit_general n i p) choose (nth_digit_general k i p))) = 
                             (\<Prod>i=0..(d).  (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p))"
     using prod.shift_bounds_cl_Suc_ivl by blast \<comment> \<open>Product manipulation helper fact\<close>
   have "(n choose k ) mod p = ((?N choose ?K) * (?nr choose ?kr)) mod p" 
     using lucas_corollary assms(3) by blast \<comment> \<open>Application of corollary\<close>
   also have "...= ((\<Prod>i\<le>d. ((nth_digit_general ?N i p) choose (nth_digit_general ?K i p))) * (?nr choose ?kr)) mod p"
     using Mlessthan Nlessthan Suc.hyps mod_mult_cong assms(3) by blast \<comment> \<open>Using Inductive Hypothesis\<close>
   \<comment> \<open>Product manipulation steps\<close>
   also have "... = ((\<Prod>i=0..(d). (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p)) * (?nr choose ?kr)) mod p"
     using  atMost_atLeast0 nth_digit_general_def div_mult2_eq by auto
   also have "... = ((\<Prod>i=1..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p)) * 
                             ((nth_digit_general n 0 p) choose (nth_digit_general k 0 p))) mod p" 
     using nth_digit_general_def shift_bounds_fact by simp
   finally have "(n choose k ) mod p = ((\<Prod>i=0..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p))) mod p" 
     using One_nat_def atMost_atLeast0 mult.commute prod.atLeast1_atMost_eq prod.atMost_shift
-    by (smt Suc_eq_plus1 shift_bounds_fact)
+    by (smt (verit, ccfv_threshold))
   thus ?case
     using Suc_eq_plus1 atMost_atLeast0 by presburger
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy b/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy
--- a/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy
+++ b/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy
@@ -1,1360 +1,1360 @@
 (*  Title:       An Ordered Resolution Prover for First-Order Clauses
     Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2016, 2017
     Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
     Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
     Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
 *)
 
 section \<open>An Ordered Resolution Prover for First-Order Clauses\<close>
 
 theory FO_Ordered_Resolution_Prover
   imports FO_Ordered_Resolution
 begin
 
 text \<open>
 This material is based on Section 4.3 (``A Simple Resolution Prover for First-Order Clauses'') of
 Bachmair and Ganzinger's chapter. Specifically, it formalizes the RP prover defined in Figure 5 and
 its related lemmas and theorems, including Lemmas 4.10 and 4.11 and Theorem 4.13 (completeness).
 \<close>
 
 definition is_least :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool" where
   "is_least P n \<longleftrightarrow> P n \<and> (\<forall>n' < n. \<not> P n')"
 
 lemma least_exists: "P n \<Longrightarrow> \<exists>n. is_least P n"
   using exists_least_iff unfolding is_least_def by auto
 
 text \<open>
 The following corresponds to page 42 and 43 of Section 4.3, from the explanation of RP to
 Lemma 4.10.
 \<close>
 
 type_synonym 'a state = "'a clause set \<times> 'a clause set \<times> 'a clause set"
 
 locale FO_resolution_prover =
   FO_resolution subst_atm id_subst comp_subst renamings_apart atm_of_atms mgu less_atm +
   selection S
   for
     S :: "('a :: wellorder) clause \<Rightarrow> 'a clause" and
     subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
     id_subst :: "'s" and
     comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" and
     renamings_apart :: "'a clause list \<Rightarrow> 's list" and
     atm_of_atms :: "'a list \<Rightarrow> 'a" and
     mgu :: "'a set set \<Rightarrow> 's option" and
     less_atm :: "'a \<Rightarrow> 'a \<Rightarrow> bool" +
   assumes
     sel_stable: "\<And>\<rho> C. is_renaming \<rho> \<Longrightarrow> S (C \<cdot> \<rho>) = S C \<cdot> \<rho>"
 begin
 
 fun N_of_state :: "'a state \<Rightarrow> 'a clause set" where
   "N_of_state (N, P, Q) = N"
 
 fun P_of_state :: "'a state \<Rightarrow> 'a clause set" where
   "P_of_state (N, P, Q) = P"
 
 text \<open>
 \<open>O\<close> denotes relation composition in Isabelle, so the formalization uses \<open>Q\<close> instead.
 \<close>
 
 fun Q_of_state :: "'a state \<Rightarrow> 'a clause set" where
   "Q_of_state (N, P, Q) = Q"
 
 abbreviation clss_of_state :: "'a state \<Rightarrow> 'a clause set" where
   "clss_of_state St \<equiv> N_of_state St \<union> P_of_state St \<union> Q_of_state St"
 
 abbreviation grounding_of_state :: "'a state \<Rightarrow> 'a clause set" where
   "grounding_of_state St \<equiv> grounding_of_clss (clss_of_state St)"
 
 interpretation ord_FO_resolution: inference_system "ord_FO_\<Gamma> S" .
 
 text \<open>
 The following inductive predicate formalizes the resolution prover in Figure 5.
 \<close>
 
 inductive RP :: "'a state \<Rightarrow> 'a state \<Rightarrow> bool" (infix "\<leadsto>" 50) where
   tautology_deletion: "Neg A \<in># C \<Longrightarrow> Pos A \<in># C \<Longrightarrow> (N \<union> {C}, P, Q) \<leadsto> (N, P, Q)"
 | forward_subsumption: "D \<in> P \<union> Q \<Longrightarrow> subsumes D C \<Longrightarrow> (N \<union> {C}, P, Q) \<leadsto> (N, P, Q)"
 | backward_subsumption_P: "D \<in> N \<Longrightarrow> strictly_subsumes D C \<Longrightarrow> (N, P \<union> {C}, Q) \<leadsto> (N, P, Q)"
 | backward_subsumption_Q: "D \<in> N \<Longrightarrow> strictly_subsumes D C \<Longrightarrow> (N, P, Q \<union> {C}) \<leadsto> (N, P, Q)"
 | forward_reduction: "D + {#L'#} \<in> P \<union> Q \<Longrightarrow> - L = L' \<cdot>l \<sigma> \<Longrightarrow> D \<cdot> \<sigma> \<subseteq># C \<Longrightarrow>
     (N \<union> {C + {#L#}}, P, Q) \<leadsto> (N \<union> {C}, P, Q)"
 | backward_reduction_P: "D + {#L'#} \<in> N \<Longrightarrow> - L = L' \<cdot>l \<sigma> \<Longrightarrow> D \<cdot> \<sigma> \<subseteq># C \<Longrightarrow>
     (N, P \<union> {C + {#L#}}, Q) \<leadsto> (N, P \<union> {C}, Q)"
 | backward_reduction_Q: "D + {#L'#} \<in> N \<Longrightarrow> - L = L' \<cdot>l \<sigma> \<Longrightarrow> D \<cdot> \<sigma> \<subseteq># C \<Longrightarrow>
     (N, P, Q \<union> {C + {#L#}}) \<leadsto> (N, P \<union> {C}, Q)"
 | clause_processing: "(N \<union> {C}, P, Q) \<leadsto> (N, P \<union> {C}, Q)"
 | inference_computation: "N = concls_of (ord_FO_resolution.inferences_between Q C) \<Longrightarrow>
     ({}, P \<union> {C}, Q) \<leadsto> (N, P, Q \<union> {C})"
 
 lemma final_RP: "\<not> ({}, {}, Q) \<leadsto> St"
   by (auto elim: RP.cases)
 
 definition Sup_state :: "'a state llist \<Rightarrow> 'a state" where
   "Sup_state Sts =
    (Sup_llist (lmap N_of_state Sts), Sup_llist (lmap P_of_state Sts),
     Sup_llist (lmap Q_of_state Sts))"
 
 definition Liminf_state :: "'a state llist \<Rightarrow> 'a state" where
   "Liminf_state Sts =
    (Liminf_llist (lmap N_of_state Sts), Liminf_llist (lmap P_of_state Sts),
     Liminf_llist (lmap Q_of_state Sts))"
 
 context
   fixes Sts Sts' :: "'a state llist"
   assumes Sts: "lfinite Sts" "lfinite Sts'" "\<not> lnull Sts" "\<not> lnull Sts'" "llast Sts' = llast Sts"
 begin
 
 lemma
   N_of_Liminf_state_fin: "N_of_state (Liminf_state Sts') = N_of_state (Liminf_state Sts)" and
   P_of_Liminf_state_fin: "P_of_state (Liminf_state Sts') = P_of_state (Liminf_state Sts)" and
   Q_of_Liminf_state_fin: "Q_of_state (Liminf_state Sts') = Q_of_state (Liminf_state Sts)"
   using Sts by (simp_all add: Liminf_state_def lfinite_Liminf_llist llast_lmap)
 
 lemma Liminf_state_fin: "Liminf_state Sts' = Liminf_state Sts"
   using N_of_Liminf_state_fin P_of_Liminf_state_fin Q_of_Liminf_state_fin
   by (simp add: Liminf_state_def)
 
 end
 
 context
   fixes Sts Sts' :: "'a state llist"
   assumes Sts: "\<not> lfinite Sts" "emb Sts Sts'"
 begin
 
 lemma
   N_of_Liminf_state_inf: "N_of_state (Liminf_state Sts') \<subseteq> N_of_state (Liminf_state Sts)" and
   P_of_Liminf_state_inf: "P_of_state (Liminf_state Sts') \<subseteq> P_of_state (Liminf_state Sts)" and
   Q_of_Liminf_state_inf: "Q_of_state (Liminf_state Sts') \<subseteq> Q_of_state (Liminf_state Sts)"
   using Sts by (simp_all add: Liminf_state_def emb_Liminf_llist_infinite emb_lmap)
 
 lemma clss_of_Liminf_state_inf:
   "clss_of_state (Liminf_state Sts') \<subseteq> clss_of_state (Liminf_state Sts)"
   using N_of_Liminf_state_inf P_of_Liminf_state_inf Q_of_Liminf_state_inf by blast
 
 end
 
 definition fair_state_seq :: "'a state llist \<Rightarrow> bool" where
   "fair_state_seq Sts \<longleftrightarrow> N_of_state (Liminf_state Sts) = {} \<and> P_of_state (Liminf_state Sts) = {}"
 
 text \<open>
 The following formalizes Lemma 4.10.
 \<close>
 
 context
   fixes Sts :: "'a state llist"
 begin
 
 definition S_Q :: "'a clause \<Rightarrow> 'a clause" where
   "S_Q = S_M S (Q_of_state (Liminf_state Sts))"
 
 interpretation sq: selection S_Q
   unfolding S_Q_def using S_M_selects_subseteq S_M_selects_neg_lits selection_axioms
   by unfold_locales auto
 
 interpretation gr: ground_resolution_with_selection S_Q
   by unfold_locales
 
 interpretation sr: standard_redundancy_criterion_reductive gr.ord_\<Gamma>
   by unfold_locales
 
 interpretation sr: standard_redundancy_criterion_counterex_reducing gr.ord_\<Gamma>
   "ground_resolution_with_selection.INTERP S_Q"
   by unfold_locales
 
 text \<open>
 The extension of ordered resolution mentioned in 4.10. We let it consist of all sound rules.
 \<close>
 
 definition ground_sound_\<Gamma>:: "'a inference set" where
   "ground_sound_\<Gamma> = {Infer CC D E | CC D E. (\<forall>I. I \<Turnstile>m CC \<longrightarrow> I \<Turnstile> D \<longrightarrow> I \<Turnstile> E)}"
 
 text \<open>
 We prove that we indeed defined an extension.
 \<close>
 
 lemma gd_ord_\<Gamma>_ngd_ord_\<Gamma>: "gr.ord_\<Gamma> \<subseteq> ground_sound_\<Gamma>"
   unfolding ground_sound_\<Gamma>_def using gr.ord_\<Gamma>_def gr.ord_resolve_sound by fastforce
 
 lemma sound_ground_sound_\<Gamma>: "sound_inference_system ground_sound_\<Gamma>"
   unfolding sound_inference_system_def ground_sound_\<Gamma>_def by auto
 
 lemma sat_preserving_ground_sound_\<Gamma>: "sat_preserving_inference_system ground_sound_\<Gamma>"
   using sound_ground_sound_\<Gamma> sat_preserving_inference_system.intro
     sound_inference_system.\<Gamma>_sat_preserving by blast
 
 definition sr_ext_Ri :: "'a clause set \<Rightarrow> 'a inference set" where
   "sr_ext_Ri N = sr.Ri N \<union> (ground_sound_\<Gamma> - gr.ord_\<Gamma>)"
 
 interpretation sr_ext:
   sat_preserving_redundancy_criterion ground_sound_\<Gamma> sr.Rf sr_ext_Ri
   unfolding sat_preserving_redundancy_criterion_def sr_ext_Ri_def
   using sat_preserving_ground_sound_\<Gamma> redundancy_criterion_standard_extension gd_ord_\<Gamma>_ngd_ord_\<Gamma>
     sr.redundancy_criterion_axioms by auto
 
 lemma strict_subset_subsumption_redundant_clause:
   assumes
     sub: "D \<cdot> \<sigma> \<subset># C" and
     ground_\<sigma>: "is_ground_subst \<sigma>"
   shows "C \<in> sr.Rf (grounding_of_cls D)"
 proof -
   from sub have "\<forall>I. I \<Turnstile> D \<cdot> \<sigma> \<longrightarrow> I \<Turnstile> C"
     unfolding true_cls_def by blast
   moreover have "C > D \<cdot> \<sigma>"
     using sub by (simp add: subset_imp_less_mset)
   moreover have "D \<cdot> \<sigma> \<in> grounding_of_cls D"
     using ground_\<sigma> by (metis (mono_tags) mem_Collect_eq substitution_ops.grounding_of_cls_def)
   ultimately have "set_mset {#D \<cdot> \<sigma>#} \<subseteq> grounding_of_cls D"
     "(\<forall>I. I \<Turnstile>m {#D \<cdot> \<sigma>#} \<longrightarrow> I \<Turnstile> C)"
     "(\<forall>D'. D' \<in># {#D \<cdot> \<sigma>#} \<longrightarrow> D' < C)"
     by auto
   then show ?thesis
     using sr.Rf_def by blast
 qed
 
 lemma strict_subset_subsumption_redundant_clss:
   assumes
     "D \<cdot> \<sigma> \<subset># C" and
     "is_ground_subst \<sigma>" and
     "D \<in> CC"
   shows "C \<in> sr.Rf (grounding_of_clss CC)"
   using assms
 proof -
   have "C \<in> sr.Rf (grounding_of_cls D)"
     using strict_subset_subsumption_redundant_clause assms by auto
   then show ?thesis
     using assms unfolding grounding_of_clss_def
     by (metis (no_types) sr.Rf_mono sup_ge1 SUP_absorb contra_subsetD)
 qed
 
 lemma strict_subset_subsumption_grounding_redundant_clss:
   assumes
     D\<sigma>_subset_C: "D \<cdot> \<sigma> \<subset># C" and
     D_in_St: "D \<in> CC"
   shows "grounding_of_cls C \<subseteq> sr.Rf (grounding_of_clss CC)"
 proof
   fix C\<mu>
   assume "C\<mu> \<in> grounding_of_cls C"
   then obtain \<mu> where
     \<mu>_p: "C\<mu> = C \<cdot> \<mu> \<and> is_ground_subst \<mu>"
     unfolding grounding_of_cls_def by auto
   have D\<sigma>\<mu>C\<mu>: "D \<cdot> \<sigma> \<cdot> \<mu> \<subset># C \<cdot> \<mu>"
     using D\<sigma>_subset_C subst_subset_mono by auto
   then show "C\<mu> \<in> sr.Rf (grounding_of_clss CC)"
     using \<mu>_p strict_subset_subsumption_redundant_clss[of D "\<sigma> \<odot> \<mu>" "C \<cdot> \<mu>"] D_in_St by auto
 qed
 
 lemma derive_if_remove_subsumed:
   assumes
     "D \<in> clss_of_state St" and
     "subsumes D C"
   shows "sr_ext.derive (grounding_of_state St \<union> grounding_of_cls C) (grounding_of_state St)"
 proof -
   from assms obtain \<sigma> where
     "D \<cdot> \<sigma> = C \<or> D \<cdot> \<sigma> \<subset># C"
     by (auto simp: subsumes_def subset_mset_def)
   then have "D \<cdot> \<sigma> = C \<or> D \<cdot> \<sigma> \<subset># C"
     by (simp add: subset_mset_def)
   then show ?thesis
   proof
     assume "D \<cdot> \<sigma> = C"
     then have "grounding_of_cls C \<subseteq> grounding_of_cls D"
       using subst_cls_eq_grounding_of_cls_subset_eq
       by (auto dest: sym)
     then have "(grounding_of_state St \<union> grounding_of_cls C) = grounding_of_state St"
       using assms unfolding grounding_of_clss_def by auto
     then show ?thesis
       by (auto intro: sr_ext.derive.intros)
   next
     assume a: "D \<cdot> \<sigma> \<subset># C"
     then have "grounding_of_cls C \<subseteq> sr.Rf (grounding_of_state St)"
       using strict_subset_subsumption_grounding_redundant_clss assms by auto
     then show ?thesis
       unfolding grounding_of_clss_def by (force intro: sr_ext.derive.intros)
   qed
 qed
 
 lemma reduction_in_concls_of:
   assumes
     "C\<mu> \<in> grounding_of_cls C" and
     "D + {#L'#} \<in> CC" and
     "- L = L' \<cdot>l \<sigma>" and
     "D \<cdot> \<sigma> \<subseteq># C"
   shows "C\<mu> \<in> concls_of (sr_ext.inferences_from (grounding_of_clss (CC \<union> {C + {#L#}})))"
 proof -
   from assms
   obtain \<mu> where
     \<mu>_p: "C\<mu> = C \<cdot> \<mu> \<and> is_ground_subst \<mu>"
     unfolding grounding_of_cls_def by auto
 
   define \<gamma> where
     "\<gamma> = Infer {#(C + {#L#}) \<cdot> \<mu>#} ((D + {#L'#}) \<cdot> \<sigma> \<cdot> \<mu>) (C \<cdot> \<mu>)"
 
   have "(D + {#L'#}) \<cdot> \<sigma> \<cdot> \<mu> \<in> grounding_of_clss (CC \<union> {C + {#L#}})"
     unfolding grounding_of_clss_def grounding_of_cls_def
     by (rule UN_I[of "D + {#L'#}"], use assms(2) in simp,
         metis (mono_tags, lifting) \<mu>_p is_ground_comp_subst mem_Collect_eq subst_cls_comp_subst)
   moreover have "(C + {#L#}) \<cdot> \<mu> \<in> grounding_of_clss (CC \<union> {C + {#L#}})"
     using \<mu>_p unfolding  grounding_of_clss_def grounding_of_cls_def by auto
   moreover have
     "\<forall>I. I \<Turnstile> D \<cdot> \<sigma> \<cdot> \<mu> + {#- (L  \<cdot>l \<mu>)#} \<longrightarrow> I \<Turnstile> C  \<cdot> \<mu> + {#L  \<cdot>l \<mu>#} \<longrightarrow> I \<Turnstile> D \<cdot> \<sigma> \<cdot> \<mu> + C \<cdot> \<mu>"
     by auto
   then have "\<forall>I. I \<Turnstile> (D + {#L'#}) \<cdot> \<sigma> \<cdot> \<mu> \<longrightarrow> I \<Turnstile> (C + {#L#}) \<cdot> \<mu> \<longrightarrow> I \<Turnstile> D \<cdot> \<sigma> \<cdot> \<mu> + C \<cdot> \<mu>"
     using assms
     by (metis add_mset_add_single subst_cls_add_mset subst_cls_union subst_minus)
   then have "\<forall>I. I \<Turnstile> (D + {#L'#}) \<cdot> \<sigma> \<cdot> \<mu> \<longrightarrow> I \<Turnstile> (C + {#L#}) \<cdot> \<mu> \<longrightarrow> I \<Turnstile> C \<cdot> \<mu>"
     using assms by (metis (no_types, lifting) subset_mset.le_iff_add subst_cls_union true_cls_union)
   then have "\<forall>I. I \<Turnstile>m {#(D + {#L'#}) \<cdot> \<sigma> \<cdot> \<mu>#} \<longrightarrow> I \<Turnstile> (C + {#L#}) \<cdot> \<mu> \<longrightarrow> I \<Turnstile> C \<cdot> \<mu>"
     by (meson true_cls_mset_singleton)
   ultimately have "\<gamma> \<in> sr_ext.inferences_from (grounding_of_clss (CC \<union> {C + {#L#}}))"
     unfolding sr_ext.inferences_from_def unfolding ground_sound_\<Gamma>_def infer_from_def \<gamma>_def by auto
   then have "C \<cdot> \<mu> \<in> concls_of (sr_ext.inferences_from (grounding_of_clss (CC \<union> {C + {#L#}})))"
     using image_iff unfolding \<gamma>_def by fastforce
   then show "C\<mu> \<in> concls_of (sr_ext.inferences_from (grounding_of_clss (CC \<union> {C + {#L#}})))"
     using \<mu>_p by auto
 qed
 
 lemma reduction_derivable:
   assumes
     "D + {#L'#} \<in> CC" and
     "- L = L' \<cdot>l \<sigma>" and
     "D \<cdot> \<sigma> \<subseteq># C"
   shows "sr_ext.derive (grounding_of_clss (CC \<union> {C + {#L#}})) (grounding_of_clss (CC \<union> {C}))"
 proof -
   from assms have "grounding_of_clss (CC \<union> {C}) - grounding_of_clss (CC \<union> {C + {#L#}})
     \<subseteq> concls_of (sr_ext.inferences_from (grounding_of_clss (CC \<union> {C + {#L#}})))"
     using reduction_in_concls_of unfolding grounding_of_clss_def by auto
   moreover
   have "grounding_of_cls (C + {#L#}) \<subseteq> sr.Rf (grounding_of_clss (CC \<union> {C}))"
     using strict_subset_subsumption_grounding_redundant_clss[of C "id_subst"]
     by auto
   then have "grounding_of_clss (CC \<union> {C + {#L#}}) - grounding_of_clss (CC \<union> {C})
     \<subseteq> sr.Rf (grounding_of_clss (CC \<union> {C}))"
     unfolding grounding_of_clss_def by auto
   ultimately show
     "sr_ext.derive (grounding_of_clss (CC \<union> {C + {#L#}})) (grounding_of_clss (CC \<union> {C}))"
     using sr_ext.derive.intros[of "grounding_of_clss (CC \<union> {C})"
         "grounding_of_clss (CC \<union> {C + {#L#}})"]
     by auto
 qed
 
 text \<open>
 The following corresponds the part of Lemma 4.10 that states we have a theorem proving process:
 \<close>
 
 lemma RP_ground_derive:
   "St \<leadsto> St' \<Longrightarrow> sr_ext.derive (grounding_of_state St) (grounding_of_state St')"
 proof (induction rule: RP.induct)
   case (tautology_deletion A C N P Q)
   {
     fix C\<sigma>
     assume "C\<sigma> \<in> grounding_of_cls C"
     then obtain \<sigma> where
       "C\<sigma> = C \<cdot> \<sigma>"
       unfolding grounding_of_cls_def by auto
     then have "Neg (A \<cdot>a \<sigma>) \<in># C\<sigma> \<and> Pos (A \<cdot>a \<sigma>) \<in># C\<sigma>"
       using tautology_deletion Neg_Melem_subst_atm_subst_cls Pos_Melem_subst_atm_subst_cls by auto
     then have "C\<sigma> \<in> sr.Rf (grounding_of_state (N, P, Q))"
       using sr.tautology_Rf by auto
   }
   then have "grounding_of_state (N \<union> {C}, P, Q) - grounding_of_state (N, P, Q)
     \<subseteq> sr.Rf (grounding_of_state (N, P, Q))"
     unfolding grounding_of_clss_def by auto
   moreover have "grounding_of_state (N, P, Q) - grounding_of_state (N \<union> {C}, P, Q) = {}"
     unfolding grounding_of_clss_def by auto
   ultimately show ?case
     using sr_ext.derive.intros[of "grounding_of_state (N, P, Q)"
       "grounding_of_state (N \<union> {C}, P, Q)"]
     by auto
 next
   case (forward_subsumption D P Q C N)
   then show ?case
     using derive_if_remove_subsumed[of D "(N, P, Q)" C] unfolding grounding_of_clss_def
     by (simp add: sup_commute sup_left_commute)
 next
   case (backward_subsumption_P D N C P Q)
   then show ?case
     using derive_if_remove_subsumed[of D "(N, P, Q)" C] strictly_subsumes_def
     unfolding grounding_of_clss_def by (simp add: sup_commute sup_left_commute)
 next
   case (backward_subsumption_Q D N C P Q)
   then show ?case
     using derive_if_remove_subsumed[of D "(N, P, Q)" C] strictly_subsumes_def
     unfolding grounding_of_clss_def by (simp add: sup_commute sup_left_commute)
 next
   case (forward_reduction D L' P Q L \<sigma> C N)
   then show ?case
     using reduction_derivable[of _ _ "N \<union> P \<union> Q"] by force
 next
   case (backward_reduction_P D L' N L \<sigma> C P Q)
   then show ?case
     using reduction_derivable[of _ _ "N \<union> P \<union> Q"] by force
 next
   case (backward_reduction_Q D L' N L \<sigma> C P Q)
   then show ?case
     using reduction_derivable[of _ _ "N \<union> P \<union> Q"] by force
 next
   case (clause_processing N C P Q)
   then show ?case
     using sr_ext.derive.intros by auto
 next
   case (inference_computation N Q C P)
   {
     fix E\<mu>
     assume "E\<mu> \<in> grounding_of_clss N"
     then obtain \<mu> E where
       E_\<mu>_p: "E\<mu> = E \<cdot> \<mu> \<and> E \<in> N \<and> is_ground_subst \<mu>"
       unfolding grounding_of_clss_def grounding_of_cls_def by auto
     then have E_concl: "E \<in> concls_of (ord_FO_resolution.inferences_between Q C)"
       using inference_computation by auto
     then obtain \<gamma> where
       \<gamma>_p: "\<gamma> \<in> ord_FO_\<Gamma> S \<and> infer_from (Q \<union> {C}) \<gamma> \<and> C \<in># prems_of \<gamma> \<and> concl_of \<gamma> = E"
       unfolding ord_FO_resolution.inferences_between_def by auto
     then obtain CC CAs D AAs As \<sigma> where
       \<gamma>_p2: "\<gamma> = Infer CC D E \<and> ord_resolve_rename S CAs D AAs As \<sigma> E \<and> mset CAs = CC"
       unfolding ord_FO_\<Gamma>_def by auto
     define \<rho> where
       "\<rho> = hd (renamings_apart (D # CAs))"
     define \<rho>s where
       "\<rho>s = tl (renamings_apart (D # CAs))"
     define \<gamma>_ground where
       "\<gamma>_ground = Infer (mset (CAs \<cdot>\<cdot>cl \<rho>s) \<cdot>cm \<sigma> \<cdot>cm \<mu>) (D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu>) (E \<cdot> \<mu>)"
     have "\<forall>I. I \<Turnstile>m mset (CAs \<cdot>\<cdot>cl \<rho>s) \<cdot>cm \<sigma> \<cdot>cm \<mu> \<longrightarrow> I \<Turnstile> D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu> \<longrightarrow> I \<Turnstile> E \<cdot> \<mu>"
       using ord_resolve_rename_ground_inst_sound[of _ _ _ _ _ _ _ _ _ _ \<mu>] \<rho>_def \<rho>s_def E_\<mu>_p \<gamma>_p2
       by auto
     then have "\<gamma>_ground \<in> {Infer cc d e | cc d e. \<forall>I. I \<Turnstile>m cc \<longrightarrow> I \<Turnstile> d \<longrightarrow> I \<Turnstile> e}"
       unfolding \<gamma>_ground_def by auto
     moreover have "set_mset (prems_of \<gamma>_ground) \<subseteq> grounding_of_state ({}, P \<union> {C}, Q)"
     proof -
       have "D = C \<or> D \<in> Q"
         unfolding \<gamma>_ground_def using E_\<mu>_p \<gamma>_p2 \<gamma>_p unfolding infer_from_def
         unfolding grounding_of_clss_def grounding_of_cls_def by simp
       then have "D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu> \<in> grounding_of_cls C \<or> (\<exists>x \<in> Q. D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu> \<in> grounding_of_cls x)"
         using E_\<mu>_p
         unfolding grounding_of_cls_def
         by (metis (mono_tags, lifting) is_ground_comp_subst mem_Collect_eq subst_cls_comp_subst)
       then have "(D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu> \<in> grounding_of_cls C \<or>
         (\<exists>x \<in> P. D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu> \<in> grounding_of_cls x) \<or>
         (\<exists>x \<in> Q. D \<cdot> \<rho> \<cdot> \<sigma> \<cdot> \<mu> \<in> grounding_of_cls x))"
         by metis
       moreover have "\<forall>i < length (CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>). (CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>) ! i \<in>
         {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>} \<union>
         ((\<Union>C \<in> P. {C \<cdot> \<sigma> | \<sigma>. is_ground_subst \<sigma>}) \<union> (\<Union>C\<in>Q. {C \<cdot> \<sigma> | \<sigma>. is_ground_subst \<sigma>}))"
       proof (rule, rule)
         fix i
         assume "i < length (CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>)"
         then have a: "i < length CAs \<and> i < length \<rho>s"
           by simp
         moreover from a have "CAs ! i \<in> {C} \<union> Q"
           using \<gamma>_p2 \<gamma>_p unfolding infer_from_def
           by (metis (no_types, lifting) Un_subset_iff inference.sel(1) set_mset_union
               sup_commute nth_mem_mset subsetCE)
         ultimately have "(CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>) ! i \<in>
           {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>} \<or>
           ((CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>) ! i \<in> (\<Union>C\<in>P. {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>}) \<or>
           (CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>) ! i \<in> (\<Union>C \<in> Q. {C \<cdot> \<sigma> | \<sigma>. is_ground_subst \<sigma>}))"
           using E_\<mu>_p \<gamma>_p2 \<gamma>_p
           unfolding \<gamma>_ground_def infer_from_def grounding_of_clss_def grounding_of_cls_def
           apply -
           apply (cases "CAs ! i = C")
           subgoal
             apply (rule disjI1)
             apply (rule Set.CollectI)
             apply (rule_tac x = "(\<rho>s ! i) \<odot> \<sigma> \<odot> \<mu>" in exI)
             using \<rho>s_def using renamings_apart_length by (auto; fail)
           subgoal
             apply (rule disjI2)
             apply (rule disjI2)
             apply (rule_tac a = "CAs ! i" in UN_I)
             subgoal by blast
             subgoal
               apply (rule Set.CollectI)
               apply (rule_tac x = "(\<rho>s ! i) \<odot> \<sigma> \<odot> \<mu>" in exI)
               using \<rho>s_def using renamings_apart_length by (auto; fail)
             done
           done
         then show "(CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>) ! i \<in> {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>} \<union>
           ((\<Union>C \<in> P. {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>}) \<union> (\<Union>C \<in> Q. {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>}))"
           by blast
       qed
       then have "\<forall>x \<in># mset (CAs \<cdot>\<cdot>cl \<rho>s \<cdot>cl \<sigma> \<cdot>cl \<mu>). x \<in> {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>} \<union>
         ((\<Union>C \<in> P. {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>}) \<union> (\<Union>C \<in> Q. {C \<cdot> \<sigma> |\<sigma>. is_ground_subst \<sigma>}))"
         by (metis (lifting) in_set_conv_nth set_mset_mset)
       then have "set_mset (mset (CAs \<cdot>\<cdot>cl \<rho>s) \<cdot>cm \<sigma> \<cdot>cm \<mu>) \<subseteq>
         grounding_of_cls C \<union> grounding_of_clss P \<union> grounding_of_clss Q"
         unfolding grounding_of_cls_def grounding_of_clss_def
         using mset_subst_cls_list_subst_cls_mset by auto
       ultimately show ?thesis
         unfolding \<gamma>_ground_def grounding_of_clss_def by auto
     qed
     ultimately have
       "E \<cdot> \<mu> \<in> concls_of (sr_ext.inferences_from (grounding_of_state ({}, P \<union> {C}, Q)))"
       unfolding sr_ext.inferences_from_def inference_system.inferences_from_def ground_sound_\<Gamma>_def
         infer_from_def
       using \<gamma>_ground_def by (metis (mono_tags, lifting) image_eqI inference.sel(3) mem_Collect_eq)
     then have "E\<mu> \<in> concls_of (sr_ext.inferences_from (grounding_of_state ({}, P \<union> {C}, Q)))"
       using E_\<mu>_p by auto
   }
   then have "grounding_of_state (N, P, Q \<union> {C}) - grounding_of_state ({}, P \<union> {C}, Q)
     \<subseteq> concls_of (sr_ext.inferences_from (grounding_of_state ({}, P \<union> {C}, Q)))"
     unfolding grounding_of_clss_def by auto
   moreover have "grounding_of_state ({}, P \<union> {C}, Q) - grounding_of_state (N, P, Q \<union> {C}) = {}"
     unfolding grounding_of_clss_def by auto
   ultimately show ?case
     using sr_ext.derive.intros[of "(grounding_of_state (N, P, Q \<union> {C}))"
         "(grounding_of_state ({}, P \<union> {C}, Q))"] by auto
 qed
 
 text \<open>
 A useful consequence:
 \<close>
 
 theorem RP_model: "St \<leadsto> St' \<Longrightarrow> I \<Turnstile>s grounding_of_state St' \<longleftrightarrow> I \<Turnstile>s grounding_of_state St"
 proof (drule RP_ground_derive, erule sr_ext.derive.cases, hypsubst)
   let
     ?gSt = "grounding_of_state St" and
     ?gSt' = "grounding_of_state St'"
 
   assume
     deduct: "?gSt' - ?gSt \<subseteq> concls_of (sr_ext.inferences_from ?gSt)" (is "_ \<subseteq> ?concls") and
     delete: "?gSt - ?gSt' \<subseteq> sr.Rf ?gSt'"
 
   show "I \<Turnstile>s ?gSt' \<longleftrightarrow> I \<Turnstile>s ?gSt"
   proof
     assume bef: "I \<Turnstile>s ?gSt"
     then have "I \<Turnstile>s ?concls"
       unfolding ground_sound_\<Gamma>_def inference_system.inferences_from_def true_clss_def
         true_cls_mset_def
       by (auto simp add: image_def infer_from_def dest!: spec[of _ I])
     then have diff: "I \<Turnstile>s ?gSt' - ?gSt"
       using deduct by (blast intro: true_clss_mono)
     then show "I \<Turnstile>s ?gSt'"
       using bef unfolding true_clss_def by blast
   next
     assume aft: "I \<Turnstile>s ?gSt'"
     have "I \<Turnstile>s ?gSt' \<union> sr.Rf ?gSt'"
-      by (rule sr.Rf_model) (smt Diff_eq_empty_iff Diff_subset Un_Diff aft
+      by (rule sr.Rf_model) (smt (verit) Diff_eq_empty_iff Diff_subset Un_Diff aft
           standard_redundancy_criterion.Rf_mono sup_bot.right_neutral sup_ge1 true_clss_mono)
     then have "I \<Turnstile>s sr.Rf ?gSt'"
       using true_clss_union by blast
     then have diff: "I \<Turnstile>s ?gSt - ?gSt'"
       using delete by (blast intro: true_clss_mono)
     then show "I \<Turnstile>s ?gSt"
       using aft unfolding true_clss_def by blast
   qed
 qed
 
 text \<open>
 Another formulation of the part of Lemma 4.10 that states we have a theorem proving process:
 \<close>
 
 lemma ground_derive_chain: "chain (\<leadsto>) Sts \<Longrightarrow> chain sr_ext.derive (lmap grounding_of_state Sts)"
   using RP_ground_derive by (simp add: chain_lmap[of "(\<leadsto>)"])
 
 text \<open>
 The following is used prove to Lemma 4.11:
 \<close>
 
 lemma Sup_llist_grounding_of_state_ground:
   assumes "C \<in> Sup_llist (lmap grounding_of_state Sts)"
   shows "is_ground_cls C"
 proof -
   have "\<exists>j. enat j < llength (lmap grounding_of_state Sts)
     \<and> C \<in> lnth (lmap grounding_of_state Sts) j"
     using assms Sup_llist_imp_exists_index by fast
   then show ?thesis
     unfolding grounding_of_clss_def grounding_of_cls_def by auto
 qed
 
 lemma Liminf_grounding_of_state_ground:
   "C \<in> Liminf_llist (lmap grounding_of_state Sts) \<Longrightarrow> is_ground_cls C"
   using Liminf_llist_subset_Sup_llist[of "lmap grounding_of_state Sts"]
     Sup_llist_grounding_of_state_ground
   by blast
 
 lemma in_Sup_llist_in_Sup_state:
   assumes "C \<in> Sup_llist (lmap grounding_of_state Sts)"
   shows "\<exists>D \<sigma>. D \<in> clss_of_state (Sup_state Sts) \<and> D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
 proof -
   from assms obtain i where
     i_p: "enat i < llength Sts \<and> C \<in> lnth (lmap grounding_of_state Sts) i"
     using Sup_llist_imp_exists_index by fastforce
   then obtain D \<sigma> where
     "D \<in> clss_of_state (lnth Sts i) \<and> D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using assms unfolding grounding_of_clss_def grounding_of_cls_def by fastforce
   then have "D \<in> clss_of_state (Sup_state Sts) \<and> D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using i_p unfolding Sup_state_def
     by (metis (no_types, lifting) UnCI UnE contra_subsetD N_of_state.simps P_of_state.simps
         Q_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist)
   then show ?thesis
     by auto
 qed
 
 lemma
   N_of_state_Liminf: "N_of_state (Liminf_state Sts) = Liminf_llist (lmap N_of_state Sts)" and
   P_of_state_Liminf: "P_of_state (Liminf_state Sts) = Liminf_llist (lmap P_of_state Sts)"
   unfolding Liminf_state_def by auto
 
 lemma eventually_removed_from_N:
   assumes
     d_in: "D \<in> N_of_state (lnth Sts i)" and
     fair: "fair_state_seq Sts" and
     i_Sts: "enat i < llength Sts"
   shows "\<exists>l. D \<in> N_of_state (lnth Sts l) \<and> D \<notin> N_of_state (lnth Sts (Suc l)) \<and> i \<le> l
     \<and> enat (Suc l) < llength Sts"
 proof (rule ccontr)
   assume a: "\<not> ?thesis"
   have "i \<le> l \<Longrightarrow> enat l < llength Sts \<Longrightarrow> D \<in> N_of_state (lnth Sts l)" for l
     using d_in by (induction l, blast, metis a Suc_ile_eq le_SucE less_imp_le)
   then have "D \<in> Liminf_llist (lmap N_of_state Sts)"
     unfolding Liminf_llist_def using i_Sts by auto
   then show False
     using fair unfolding fair_state_seq_def by (simp add: N_of_state_Liminf)
 qed
 
 lemma eventually_removed_from_P:
   assumes
     d_in: "D \<in> P_of_state (lnth Sts i)" and
     fair: "fair_state_seq Sts" and
     i_Sts: "enat i < llength Sts"
   shows "\<exists>l. D \<in> P_of_state (lnth Sts l) \<and> D \<notin> P_of_state (lnth Sts (Suc l)) \<and> i \<le> l
     \<and> enat (Suc l) < llength Sts"
 proof (rule ccontr)
   assume a: "\<not> ?thesis"
   have "i \<le> l \<Longrightarrow> enat l < llength Sts \<Longrightarrow> D \<in> P_of_state (lnth Sts l)" for l
     using d_in by (induction l, blast, metis a Suc_ile_eq le_SucE less_imp_le)
   then have "D \<in> Liminf_llist (lmap P_of_state Sts)"
     unfolding Liminf_llist_def using i_Sts by auto
   then show False
     using fair unfolding fair_state_seq_def by (simp add: P_of_state_Liminf)
 qed
 
 lemma instance_if_subsumed_and_in_limit:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     ns: "Gs = lmap grounding_of_state Sts" and
     c: "C \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and
     d: "D \<in> clss_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C"
   shows "\<exists>\<sigma>. D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
 proof -
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   have ground_C: "is_ground_cls C"
     using c using Liminf_grounding_of_state_ground ns by auto
 
   have derivns: "chain sr_ext.derive Gs"
     using ground_derive_chain deriv ns by auto
 
   have "\<exists>\<sigma>. D \<cdot> \<sigma> = C"
   proof (rule ccontr)
     assume "\<nexists>\<sigma>. D \<cdot> \<sigma> = C"
     moreover from d(3) obtain \<tau>_proto where
       "D \<cdot> \<tau>_proto \<subseteq># C" unfolding subsumes_def
       by blast
     then obtain \<tau> where
       \<tau>_p: "D \<cdot> \<tau> \<subseteq># C \<and> is_ground_subst \<tau>"
       using ground_C by (metis is_ground_cls_mono make_ground_subst subset_mset.order_refl)
     ultimately have subsub: "D \<cdot> \<tau> \<subset># C"
       using subset_mset.le_imp_less_or_eq by auto
     moreover have "is_ground_subst \<tau>"
       using \<tau>_p by auto
     moreover have "D \<in> clss_of_state (lnth Sts i)"
       using d by auto
     ultimately have "C \<in> sr.Rf (grounding_of_state (lnth Sts i))"
       using strict_subset_subsumption_redundant_clss by auto
     then have "C \<in> sr.Rf (Sup_llist Gs)"
-      using d ns by (smt contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr.Rf_mono)
+      using d ns by (smt (verit) contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr.Rf_mono)
     then have "C \<in> sr.Rf (Liminf_llist Gs)"
       unfolding ns using local.sr_ext.Rf_limit_Sup derivns ns by auto
     then show False
       using c by auto
   qed
   then obtain \<sigma> where
     "D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using ground_C by (metis make_ground_subst)
   then show ?thesis
     by auto
 qed
 
 lemma from_Q_to_Q_inf:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     ns: "Gs = lmap grounding_of_state Sts" and
     c: "C \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and
     d: "D \<in> Q_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" and
     d_least: "\<forall>E \<in> {E. E \<in> (clss_of_state (Sup_state Sts)) \<and> subsumes E C}.
       \<not> strictly_subsumes E D"
   shows "D \<in> Q_of_state (Liminf_state Sts)"
 proof -
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   have ground_C: "is_ground_cls C"
     using c using Liminf_grounding_of_state_ground ns by auto
 
   have derivns: "chain sr_ext.derive Gs"
     using ground_derive_chain deriv ns by auto
 
   have "\<exists>\<sigma>. D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using instance_if_subsumed_and_in_limit[OF deriv] c d unfolding ns by blast
   then obtain \<sigma> where
     \<sigma>: "D \<cdot> \<sigma> = C" "is_ground_subst \<sigma>"
     by auto
 
   have in_Sts_in_Sts_Suc:
     "\<forall>l \<ge> i. enat (Suc l) < llength Sts \<longrightarrow> D \<in> Q_of_state (lnth Sts l) \<longrightarrow>
        D \<in> Q_of_state (lnth Sts (Suc l))"
   proof (rule, rule, rule, rule)
     fix l
     assume
       len: "i \<le> l" and
       llen: "enat (Suc l) < llength Sts" and
       d_in_q: "D \<in> Q_of_state (lnth Sts l)"
 
     have "lnth Sts l \<leadsto> lnth Sts (Suc l)"
       using llen deriv chain_lnth_rel by blast
     then show "D \<in> Q_of_state (lnth Sts (Suc l))"
     proof (cases rule: RP.cases)
       case (backward_subsumption_Q D' N D_removed P Q)
       moreover
       {
         assume "D_removed = D"
         then obtain D_subsumes where
           D_subsumes_p: "D_subsumes \<in> N \<and> strictly_subsumes D_subsumes D"
           using backward_subsumption_Q by auto
         moreover from D_subsumes_p have "subsumes D_subsumes C"
           using d subsumes_trans unfolding strictly_subsumes_def by blast
         moreover from backward_subsumption_Q have "D_subsumes \<in> clss_of_state (Sup_state Sts)"
           using D_subsumes_p llen
           by (metis (no_types) UnI1 N_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist
               rev_subsetD Sup_state_def)
         ultimately have False
           using d_least unfolding subsumes_def by auto
       }
       ultimately show ?thesis
         using d_in_q by auto
     next
       case (backward_reduction_Q E L' N L \<sigma> D' P Q)
       {
         assume "D' + {#L#} = D"
         then have D'_p: "strictly_subsumes D' D \<and> D' \<in> ?Ps (Suc l)"
           using subset_strictly_subsumes[of D' D] backward_reduction_Q by auto
         then have subc: "subsumes D' C"
           using d(3) subsumes_trans unfolding strictly_subsumes_def by auto
         from D'_p have "D' \<in> clss_of_state (Sup_state Sts)"
           using llen by (metis (no_types) UnI1 P_of_state.simps llength_lmap lnth_lmap
               lnth_subset_Sup_llist subsetCE sup_ge2 Sup_state_def)
         then have False
           using d_least D'_p subc by auto
       }
       then show ?thesis
         using backward_reduction_Q d_in_q by auto
     qed (use d_in_q in auto)
   qed
   have D_in_Sts: "D \<in> Q_of_state (lnth Sts l)" and D_in_Sts_Suc: "D \<in> Q_of_state (lnth Sts (Suc l))"
     if l_i: "l \<ge> i" and enat: "enat (Suc l) < llength Sts" for l
   proof -
     show "D \<in> Q_of_state (lnth Sts l)"
       using l_i enat
       apply (induction "l - i" arbitrary: l)
       subgoal using d by auto
       subgoal using d(1) in_Sts_in_Sts_Suc
         by (metis (no_types, lifting) Suc_ile_eq add_Suc_right add_diff_cancel_left' le_SucE
             le_Suc_ex less_imp_le)
       done
     then show "D \<in> Q_of_state (lnth Sts (Suc l))"
       using l_i enat in_Sts_in_Sts_Suc by blast
   qed
   have "i \<le> x \<Longrightarrow> enat x < llength Sts \<Longrightarrow> D \<in> Q_of_state (lnth Sts x)" for x
     apply (cases x)
     subgoal using d(1) by (auto intro!: exI[of _ i] simp: less_Suc_eq)
     subgoal for x'
       using d(1) D_in_Sts_Suc[of x'] by (cases \<open>i \<le> x'\<close>) (auto simp: not_less_eq_eq)
     done
   then have "D \<in> Liminf_llist (lmap Q_of_state Sts)"
     unfolding Liminf_llist_def by (auto intro!: exI[of _ i] simp: d)
   then show ?thesis
     unfolding Liminf_state_def by auto
 qed
 
 lemma from_P_to_Q:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     ns: "Gs = lmap grounding_of_state Sts" and
     c: "C \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and
     d: "D \<in> P_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" and
     d_least: "\<forall>E \<in> {E. E \<in> (clss_of_state (Sup_state Sts)) \<and> subsumes E C}.
       \<not> strictly_subsumes E D"
   shows "\<exists>l. D \<in> Q_of_state (lnth Sts l) \<and> enat l < llength Sts"
 proof -
   let ?Ns = "\<lambda>i. N_of_state (lnth Sts i)"
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   have ground_C: "is_ground_cls C"
     using c using Liminf_grounding_of_state_ground ns by auto
 
   have derivns: "chain sr_ext.derive Gs"
     using ground_derive_chain deriv ns by auto
 
   have "\<exists>\<sigma>. D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using instance_if_subsumed_and_in_limit[OF deriv] ns c d by blast
   then obtain \<sigma> where
     \<sigma>: "D \<cdot> \<sigma> = C" "is_ground_subst \<sigma>"
     by auto
 
   obtain l where
     l_p: "D \<in> P_of_state (lnth Sts l) \<and> D \<notin> P_of_state (lnth Sts (Suc l)) \<and> i \<le> l
       \<and> enat (Suc l) < llength Sts"
     using fair using eventually_removed_from_P d unfolding ns by auto
   then have l_Gs: "enat (Suc l) < llength Gs"
     using ns by auto
   from l_p have "lnth Sts l \<leadsto> lnth Sts (Suc l)"
     using deriv using chain_lnth_rel by auto
   then show ?thesis
   proof (cases rule: RP.cases)
     case (backward_subsumption_P D' N D_twin P Q)
     note lrhs = this(1,2) and D'_p = this(3,4)
     then have twins: "D_twin = D" "?Ns (Suc l) = N" "?Ns l = N"  "?Ps (Suc l) = P"
       "?Ps l = P \<union> {D_twin}" "?Qs (Suc l) = Q" "?Qs l = Q"
       using l_p by auto
     note D'_p = D'_p[unfolded twins(1)]
     then have subc: "subsumes D' C"
       unfolding strictly_subsumes_def subsumes_def using \<sigma>
       by (metis subst_cls_comp_subst subst_cls_mono_mset)
     from D'_p have "D' \<in> clss_of_state (Sup_state Sts)"
       unfolding twins(2)[symmetric] using l_p
       by (metis (no_types) UnI1 N_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist
           subsetCE Sup_state_def)
     then have False
       using d_least D'_p subc by auto
     then show ?thesis
       by auto
   next
     case (backward_reduction_P E L' N L \<sigma> D' P Q)
     then have twins: "D' + {#L#} = D" "?Ns (Suc l) = N" "?Ns l = N"  "?Ps (Suc l) = P \<union> {D'}"
       "?Ps l = P \<union> {D' + {#L#}}" "?Qs (Suc l) = Q" "?Qs l = Q"
       using l_p by auto
     then have D'_p: "strictly_subsumes D' D \<and> D' \<in> ?Ps (Suc l)"
       using subset_strictly_subsumes[of D' D] by auto
     then have subc: "subsumes D' C"
       using d(3) subsumes_trans unfolding strictly_subsumes_def by auto
     from D'_p have "D' \<in> clss_of_state (Sup_state Sts)"
       using l_p by (metis (no_types) UnI1 P_of_state.simps llength_lmap lnth_lmap
           lnth_subset_Sup_llist subsetCE sup_ge2 Sup_state_def)
     then have False
       using d_least D'_p subc by auto
     then show ?thesis
       by auto
   next
     case (inference_computation N Q D_twin P)
     then have twins: "D_twin = D" "?Ps (Suc l) = P" "?Ps l = P \<union> {D_twin}"
       "?Qs (Suc l) = Q \<union> {D_twin}" "?Qs l = Q"
       using l_p by auto
     then show ?thesis
       using d \<sigma> l_p by auto
   qed (use l_p in auto)
 qed
 
 lemma from_N_to_P_or_Q:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     ns: "Gs = lmap grounding_of_state Sts" and
     c: "C \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and
     d: "D \<in> N_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" and
     d_least: "\<forall>E \<in> {E. E \<in> (clss_of_state (Sup_state Sts)) \<and> subsumes E C}. \<not> strictly_subsumes E D"
   shows "\<exists>l D' \<sigma>'. D' \<in> P_of_state (lnth Sts l) \<union> Q_of_state (lnth Sts l) \<and>
     enat l < llength Sts \<and>
     (\<forall>E \<in> {E. E \<in> (clss_of_state (Sup_state Sts)) \<and> subsumes E C}. \<not> strictly_subsumes E D') \<and>
     D' \<cdot> \<sigma>' = C \<and> is_ground_subst \<sigma>' \<and> subsumes D' C"
 proof -
   let ?Ns = "\<lambda>i. N_of_state (lnth Sts i)"
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   have ground_C: "is_ground_cls C"
     using c using Liminf_grounding_of_state_ground ns by auto
 
   have derivns: "chain sr_ext.derive Gs"
     using ground_derive_chain deriv ns by auto
 
   have "\<exists>\<sigma>. D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using instance_if_subsumed_and_in_limit[OF deriv] ns c d by blast
   then obtain \<sigma> where
     \<sigma>: "D \<cdot> \<sigma> = C" "is_ground_subst \<sigma>"
     by auto
 
   from c have no_taut: "\<not> (\<exists>A. Pos A \<in># C \<and> Neg A \<in># C)"
     using sr.tautology_Rf by auto
 
   have "\<exists>l. D \<in> N_of_state (lnth Sts l)
     \<and> D \<notin> N_of_state (lnth Sts (Suc l)) \<and> i \<le> l \<and> enat (Suc l) < llength Sts"
     using fair using eventually_removed_from_N d unfolding ns by auto
   then obtain l where
     l_p: "D \<in> N_of_state (lnth Sts l) \<and> D \<notin> N_of_state (lnth Sts (Suc l)) \<and> i \<le> l
       \<and> enat (Suc l) < llength Sts"
     by auto
   then have l_Gs: "enat (Suc l) < llength Gs"
     using ns by auto
   from l_p have "lnth Sts l \<leadsto> lnth Sts (Suc l)"
     using deriv using chain_lnth_rel by auto
   then show ?thesis
   proof (cases rule: RP.cases)
     case (tautology_deletion A D_twin N P Q)
     then have "D_twin = D"
       using l_p by auto
     then have "Pos (A \<cdot>a \<sigma>) \<in># C \<and> Neg (A \<cdot>a \<sigma>) \<in># C"
       using tautology_deletion(3,4) \<sigma>
       by (metis Melem_subst_cls eql_neg_lit_eql_atm eql_pos_lit_eql_atm)
     then have False
       using no_taut by metis
     then show ?thesis
       by blast
   next
     case (forward_subsumption D' P Q D_twin N)
     note lrhs = this(1,2) and D'_p = this(3,4)
     then have twins: "D_twin = D" "?Ns (Suc l) = N" "?Ns l = N \<union> {D_twin}"  "?Ps (Suc l) = P "
       "?Ps l = P" "?Qs (Suc l) = Q" "?Qs l = Q"
       using l_p by auto
     note D'_p = D'_p[unfolded twins(1)]
     from D'_p(2) have subs: "subsumes D' C"
       using d(3) by (blast intro: subsumes_trans)
     moreover have "D' \<in> clss_of_state (Sup_state Sts)"
       using twins D'_p l_p unfolding Sup_state_def
       by simp (metis (no_types) contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist)
     ultimately have "\<not> strictly_subsumes D' D"
       using d_least by auto
     then have "subsumes D D'"
       unfolding strictly_subsumes_def using D'_p by auto
     then have v: "variants D D'"
       using D'_p unfolding variants_iff_subsumes by auto
     then have mini: "\<forall>E \<in> {E \<in> clss_of_state (Sup_state Sts). subsumes E C}.
       \<not> strictly_subsumes E D'"
       using d_least D'_p neg_strictly_subsumes_variants[of _ D D'] by auto
 
     from v have "\<exists>\<sigma>'. D' \<cdot> \<sigma>' = C"
       using \<sigma> variants_imp_exists_substitution variants_sym by (metis subst_cls_comp_subst)
     then have "\<exists>\<sigma>'. D' \<cdot> \<sigma>' = C \<and> is_ground_subst \<sigma>'"
       using ground_C by (meson make_ground_subst refl)
     then obtain \<sigma>' where
       \<sigma>'_p: "D' \<cdot> \<sigma>' = C \<and> is_ground_subst \<sigma>'"
       by metis
 
     show ?thesis
       using D'_p twins l_p subs mini \<sigma>'_p by auto
   next
     case (forward_reduction E L' P Q L \<sigma> D' N)
     then have twins: "D' + {#L#} = D" "?Ns (Suc l) = N \<union> {D'}" "?Ns l = N \<union> {D' + {#L#}}"
       "?Ps (Suc l) = P " "?Ps l = P" "?Qs (Suc l) = Q" "?Qs l = Q"
       using l_p by auto
     then have D'_p: "strictly_subsumes D' D \<and> D' \<in> ?Ns (Suc l)"
       using subset_strictly_subsumes[of D' D] by auto
     then have subc: "subsumes D' C"
       using d(3) subsumes_trans unfolding strictly_subsumes_def by blast
     from D'_p have "D' \<in> clss_of_state (Sup_state Sts)"
       using l_p by (metis (no_types) UnI1 N_of_state.simps llength_lmap lnth_lmap
           lnth_subset_Sup_llist subsetCE Sup_state_def)
     then have False
       using d_least D'_p subc by auto
     then show ?thesis
       by auto
   next
     case (clause_processing N D_twin P Q)
     then have twins:  "D_twin = D" "?Ns (Suc l) = N" "?Ns l = N \<union> {D}"  "?Ps (Suc l) = P \<union> {D}"
       "?Ps l = P" "?Qs (Suc l) = Q" "?Qs l = Q"
       using l_p by auto
     then show ?thesis
       using d \<sigma> l_p d_least by blast
   qed (use l_p in auto)
 qed
 
 lemma eventually_in_Qinf:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     D_p: "D \<in> clss_of_state (Sup_state Sts)"
       "subsumes D C" "\<forall>E \<in> {E. E \<in> (clss_of_state (Sup_state Sts)) \<and> subsumes E C}.
        \<not> strictly_subsumes E D" and
     fair: "fair_state_seq Sts" and
     ns: "Gs = lmap grounding_of_state Sts" and
     c: "C \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and
     ground_C: "is_ground_cls C"
   shows "\<exists>D' \<sigma>'. D' \<in> Q_of_state (Liminf_state Sts) \<and> D' \<cdot> \<sigma>' = C \<and> is_ground_subst \<sigma>'"
 proof -
   let ?Ns = "\<lambda>i. N_of_state (lnth Sts i)"
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   from D_p obtain i where
     i_p: "i < llength Sts" "D \<in> ?Ns i \<or> D \<in> ?Ps i \<or> D \<in> ?Qs i"
     unfolding Sup_state_def
     by simp_all (metis (no_types) Sup_llist_imp_exists_index llength_lmap lnth_lmap)
 
   have derivns: "chain sr_ext.derive Gs"
     using ground_derive_chain deriv ns by auto
 
   have "\<exists>\<sigma>. D \<cdot> \<sigma> = C \<and> is_ground_subst \<sigma>"
     using instance_if_subsumed_and_in_limit[OF deriv ns c] D_p i_p by blast
   then obtain \<sigma> where
     \<sigma>: "D \<cdot> \<sigma> = C" "is_ground_subst \<sigma>"
     by blast
 
   {
     assume a: "D \<in> ?Ns i"
     then obtain D' \<sigma>' l where D'_p:
       "D' \<in> ?Ps l \<union> ?Qs l"
       "D' \<cdot> \<sigma>' = C"
       "enat l < llength Sts"
       "is_ground_subst \<sigma>'"
       "\<forall>E \<in> {E. E \<in> (clss_of_state (Sup_state Sts)) \<and> subsumes E C}. \<not> strictly_subsumes E D'"
       "subsumes D' C"
       using from_N_to_P_or_Q deriv fair ns c i_p(1) D_p(2) D_p(3) by blast
     then obtain l' where
       l'_p: "D' \<in> ?Qs l'" "l' < llength Sts"
       using from_P_to_Q[OF deriv fair ns c _ D'_p(3) D'_p(6) D'_p(5)] by blast
     then have "D' \<in> Q_of_state (Liminf_state Sts)"
       using from_Q_to_Q_inf[OF deriv fair ns c _ l'_p(2)] D'_p by auto
     then have ?thesis
       using D'_p by auto
   }
   moreover
   {
     assume a: "D \<in> ?Ps i"
     then obtain l' where
       l'_p: "D \<in> ?Qs l'" "l' < llength Sts"
       using from_P_to_Q[OF deriv fair ns c a i_p(1) D_p(2) D_p(3)] by auto
     then have "D \<in> Q_of_state (Liminf_state Sts)"
       using from_Q_to_Q_inf[OF deriv fair ns c l'_p(1) l'_p(2)] D_p(3) \<sigma>(1) \<sigma>(2) D_p(2) by auto
     then have ?thesis
       using D_p \<sigma> by auto
   }
   moreover
   {
     assume a: "D \<in> ?Qs i"
     then have "D \<in> Q_of_state (Liminf_state Sts)"
       using from_Q_to_Q_inf[OF deriv fair ns c a i_p(1)] \<sigma> D_p(2,3) by auto
     then have ?thesis
       using D_p \<sigma> by auto
   }
   ultimately show ?thesis
     using i_p by auto
 qed
 
 text \<open>
 The following corresponds to Lemma 4.11:
 \<close>
 
 lemma fair_imp_Liminf_minus_Rf_subset_ground_Liminf_state:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     ns: "Gs = lmap grounding_of_state Sts"
   shows "Liminf_llist Gs - sr.Rf (Liminf_llist Gs)
     \<subseteq> grounding_of_clss (Q_of_state (Liminf_state Sts))"
 proof
   let ?Ns = "\<lambda>i. N_of_state (lnth Sts i)"
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   have SQinf: "clss_of_state (Liminf_state Sts) = Liminf_llist (lmap Q_of_state Sts)"
     using fair unfolding fair_state_seq_def Liminf_state_def by auto
 
   fix C
   assume C_p: "C \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)"
   then have "C \<in> Sup_llist Gs"
     using Liminf_llist_subset_Sup_llist[of Gs] by blast
   then obtain D_proto where
     "D_proto \<in> clss_of_state (Sup_state Sts) \<and> subsumes D_proto C"
     using in_Sup_llist_in_Sup_state unfolding ns subsumes_def by blast
   then obtain D where
     D_p: "D \<in> clss_of_state (Sup_state Sts)"
     "subsumes D C"
     "\<forall>E \<in> {E. E \<in> clss_of_state (Sup_state Sts) \<and> subsumes E C}. \<not> strictly_subsumes E D"
     using strictly_subsumes_has_minimum[of "{E. E \<in> clss_of_state (Sup_state Sts) \<and> subsumes E C}"]
     by auto
 
   have ground_C: "is_ground_cls C"
     using C_p using Liminf_grounding_of_state_ground ns by auto
 
   have "\<exists>D' \<sigma>'. D' \<in> Q_of_state (Liminf_state Sts) \<and> D' \<cdot> \<sigma>' = C \<and> is_ground_subst \<sigma>'"
     using eventually_in_Qinf[of D C Gs] using D_p(1-3) deriv fair ns C_p ground_C by auto
   then obtain D' \<sigma>' where
     D'_p: "D' \<in> Q_of_state (Liminf_state Sts) \<and> D' \<cdot> \<sigma>' = C \<and> is_ground_subst \<sigma>'"
     by blast
   then have "D' \<in> clss_of_state (Liminf_state Sts)"
     by simp
   then have "C \<in> grounding_of_state (Liminf_state Sts)"
     unfolding grounding_of_clss_def grounding_of_cls_def using D'_p by auto
   then show "C \<in> grounding_of_clss (Q_of_state (Liminf_state Sts))"
     using SQinf fair fair_state_seq_def by auto
 qed
 
 text \<open>
 The following corresponds to (one direction of) Theorem 4.13:
 \<close>
 
 lemma subseteq_Liminf_state_eventually_always:
   fixes CC
   assumes
     "finite CC" and
     "CC \<noteq> {}" and
     "CC \<subseteq> Q_of_state (Liminf_state Sts)"
   shows "\<exists>j. enat j < llength Sts \<and> (\<forall>j' \<ge> enat j. j' < llength Sts \<longrightarrow> CC \<subseteq> Q_of_state (lnth Sts j'))"
 proof -
   from assms(3) have "\<forall>C \<in> CC. \<exists>j. enat j < llength Sts \<and>
     (\<forall>j' \<ge> enat j. j' < llength Sts \<longrightarrow> C \<in> Q_of_state (lnth Sts j'))"
     unfolding Liminf_state_def Liminf_llist_def by force
   then obtain f where
     f_p: "\<forall>C \<in> CC. f C < llength Sts \<and> (\<forall>j' \<ge> enat (f C). j' < llength Sts \<longrightarrow> C \<in> Q_of_state (lnth Sts j'))"
     by moura
 
   define j :: nat where
     "j = Max (f ` CC)"
 
   have "enat j < llength Sts"
     unfolding j_def using f_p assms(1)
     by (metis (mono_tags) Max_in assms(2) finite_imageI imageE image_is_empty)
   moreover have "\<forall>C j'. C \<in> CC \<longrightarrow> enat j \<le> j' \<longrightarrow> j' < llength Sts \<longrightarrow> C \<in> Q_of_state (lnth Sts j')"
   proof (intro allI impI)
     fix C :: "'a clause" and j' :: nat
     assume a: "C \<in> CC" "enat j \<le> enat j'" "enat j' < llength Sts"
     then have "f C \<le> j'"
       unfolding j_def using assms(1) Max.bounded_iff by auto
     then show "C \<in> Q_of_state (lnth Sts j')"
       using f_p a by auto
   qed
   ultimately show ?thesis
     by auto
 qed
 
 lemma empty_clause_in_Q_of_Liminf_state:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     empty_in: "{#} \<in> Liminf_llist (lmap grounding_of_state Sts)"
   shows "{#} \<in> Q_of_state (Liminf_state Sts)"
 proof -
   define Gs :: "'a clause set llist" where
     ns: "Gs = lmap grounding_of_state Sts"
   from empty_in have in_Liminf_not_Rf: "{#} \<in> Liminf_llist Gs - sr.Rf (Liminf_llist Gs)"
     unfolding ns sr.Rf_def by auto
   then have "{#} \<in> grounding_of_clss (Q_of_state (Liminf_state Sts))"
     using fair_imp_Liminf_minus_Rf_subset_ground_Liminf_state[OF deriv fair ns] by auto
   then show ?thesis
     unfolding grounding_of_clss_def grounding_of_cls_def by auto
 qed
 
 lemma grounding_of_state_Liminf_state_subseteq:
   "grounding_of_state (Liminf_state Sts) \<subseteq> Liminf_llist (lmap grounding_of_state Sts)"
 proof
   fix C :: "'a clause"
   assume "C \<in> grounding_of_state (Liminf_state Sts)"
   then obtain D \<sigma> where
     D_\<sigma>_p: "D \<in> clss_of_state (Liminf_state Sts)" "D \<cdot> \<sigma> = C" "is_ground_subst \<sigma>"
     unfolding grounding_of_clss_def grounding_of_cls_def by auto
   then have ii: "D \<in> Liminf_llist (lmap N_of_state Sts)
     \<or> D \<in> Liminf_llist (lmap P_of_state Sts) \<or> D \<in> Liminf_llist (lmap Q_of_state Sts)"
     unfolding Liminf_state_def by simp
   then have "C \<in> Liminf_llist (lmap grounding_of_clss (lmap N_of_state Sts))
     \<or> C \<in> Liminf_llist (lmap grounding_of_clss (lmap P_of_state Sts))
     \<or> C \<in> Liminf_llist (lmap grounding_of_clss (lmap Q_of_state Sts))"
     unfolding Liminf_llist_def grounding_of_clss_def grounding_of_cls_def
     using D_\<sigma>_p
     apply -
     apply (erule disjE)
     subgoal
       apply (rule disjI1)
       using D_\<sigma>_p by auto
     subgoal
       apply (erule disjE)
       subgoal
         apply (rule disjI2)
         apply (rule disjI1)
         using D_\<sigma>_p by auto
       subgoal
         apply (rule disjI2)
         apply (rule disjI2)
         using D_\<sigma>_p by auto
       done
     done
   then show "C \<in> Liminf_llist (lmap grounding_of_state Sts)"
     unfolding Liminf_llist_def grounding_of_clss_def by auto
 qed
 
 theorem RP_sound:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     "{#} \<in> clss_of_state (Liminf_state Sts)"
   shows "\<not> satisfiable (grounding_of_state (lhd Sts))"
 proof -
   from assms have "{#} \<in> grounding_of_state (Liminf_state Sts)"
     unfolding grounding_of_clss_def by (force intro: ex_ground_subst)
   then have "{#} \<in> Liminf_llist (lmap grounding_of_state Sts)"
     using grounding_of_state_Liminf_state_subseteq by auto
   then have "\<not> satisfiable (Liminf_llist (lmap grounding_of_state Sts))"
     using true_clss_def by auto
   then have "\<not> satisfiable (lhd (lmap grounding_of_state Sts))"
     using sr_ext.sat_limit_iff ground_derive_chain deriv by blast
   then show ?thesis
     using chain_not_lnull deriv by fastforce
 qed
 
 theorem RP_saturated_if_fair:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     empty_Q0: "Q_of_state (lhd Sts) = {}"
   shows "sr.saturated_upto (Liminf_llist (lmap grounding_of_state Sts))"
 proof -
   define Gs :: "'a clause set llist" where
     ns: "Gs = lmap grounding_of_state Sts"
 
   let ?N = "\<lambda>i. grounding_of_state (lnth Sts i)"
 
   let ?Ns = "\<lambda>i. N_of_state (lnth Sts i)"
   let ?Ps = "\<lambda>i. P_of_state (lnth Sts i)"
   let ?Qs = "\<lambda>i. Q_of_state (lnth Sts i)"
 
   have ground_ns_in_ground_limit_st:
     "Liminf_llist Gs - sr.Rf (Liminf_llist Gs) \<subseteq> grounding_of_clss (Q_of_state (Liminf_state Sts))"
     using fair deriv fair_imp_Liminf_minus_Rf_subset_ground_Liminf_state ns by blast
 
   have derivns: "chain sr_ext.derive Gs"
     using ground_derive_chain deriv ns by auto
 
   {
     fix \<gamma> :: "'a inference"
     assume \<gamma>_p: "\<gamma> \<in> gr.ord_\<Gamma>"
     let ?CC = "side_prems_of \<gamma>"
     let ?DA = "main_prem_of \<gamma>"
     let ?E = "concl_of \<gamma>"
     assume a: "set_mset ?CC \<union> {?DA}
       \<subseteq> Liminf_llist (lmap grounding_of_state Sts)
         - sr.Rf (Liminf_llist (lmap grounding_of_state Sts))"
 
     have ground_ground_Liminf: "is_ground_clss (Liminf_llist (lmap grounding_of_state Sts))"
       using Liminf_grounding_of_state_ground unfolding is_ground_clss_def by auto
 
     have ground_cc: "is_ground_clss (set_mset ?CC)"
       using a ground_ground_Liminf is_ground_clss_def by auto
 
     have ground_da: "is_ground_cls ?DA"
       using a grounding_ground singletonI ground_ground_Liminf
       by (simp add: Liminf_grounding_of_state_ground)
 
     from \<gamma>_p obtain CAs AAs As where
       CAs_p: "gr.ord_resolve CAs ?DA AAs As ?E \<and> mset CAs = ?CC"
       unfolding gr.ord_\<Gamma>_def by auto
 
     have DA_CAs_in_ground_Liminf:
       "{?DA} \<union> set CAs \<subseteq> grounding_of_clss (Q_of_state (Liminf_state Sts))"
       using a CAs_p fair unfolding fair_state_seq_def
       by (metis (no_types, lifting) Un_empty_left ground_ns_in_ground_limit_st a ns set_mset_mset
           subset_trans sup_commute)
 
     then have ground_cas: "is_ground_cls_list CAs"
       using CAs_p unfolding is_ground_cls_list_def by auto
 
     have "\<exists>\<sigma>. ord_resolve S_Q CAs ?DA AAs As \<sigma> ?E"
       by (rule ground_ord_resolve_imp_ord_resolve[OF ground_da ground_cas
             gr.ground_resolution_with_selection_axioms CAs_p[THEN conjunct1]])
     then obtain \<sigma> where
       \<sigma>_p: "ord_resolve S_Q CAs ?DA AAs As \<sigma> ?E"
       by auto
     then obtain \<eta>s' \<eta>' \<eta>2' CAs' DA' AAs' As' \<tau>' E' where s_p:
       "is_ground_subst \<eta>'"
       "is_ground_subst_list \<eta>s'"
       "is_ground_subst \<eta>2'"
       "ord_resolve_rename S CAs' DA' AAs' As' \<tau>' E'"
       "CAs' \<cdot>\<cdot>cl \<eta>s' = CAs"
       "DA' \<cdot> \<eta>' = ?DA"
       "E' \<cdot> \<eta>2' = ?E"
       "{DA'} \<union> set CAs' \<subseteq> Q_of_state (Liminf_state Sts)"
       using ord_resolve_rename_lifting[OF sel_stable, of "Q_of_state (Liminf_state Sts)" CAs ?DA]
         \<sigma>_p[unfolded S_Q_def] selection_axioms DA_CAs_in_ground_Liminf by metis
     from this(8) have "\<exists>j. enat j < llength Sts \<and> (set CAs' \<union> {DA'} \<subseteq> ?Qs j)"
       unfolding Liminf_llist_def
       using subseteq_Liminf_state_eventually_always[of "{DA'} \<union> set CAs'"] by auto
     then obtain j where
       j_p: "is_least (\<lambda>j. enat j < llength Sts \<and> set CAs' \<union> {DA'} \<subseteq> ?Qs j) j"
       using least_exists[of "\<lambda>j. enat j < llength Sts \<and> set CAs' \<union> {DA'} \<subseteq> ?Qs j"] by force
     then have j_p': "enat j < llength Sts" "set CAs' \<union> {DA'} \<subseteq> ?Qs j"
       unfolding is_least_def by auto
     then have jn0: "j \<noteq> 0"
       using empty_Q0 by (metis bot_eq_sup_iff gr_implies_not_zero insert_not_empty llength_lnull
           lnth_0_conv_lhd sup.orderE)
     then have j_adds_CAs': "\<not> set CAs' \<union> {DA'} \<subseteq> ?Qs (j - 1)" "set CAs' \<union> {DA'} \<subseteq> ?Qs j"
       using j_p unfolding is_least_def
        apply (metis (no_types) One_nat_def Suc_diff_Suc Suc_ile_eq diff_diff_cancel diff_zero
           less_imp_le less_one neq0_conv zero_less_diff)
       using j_p'(2) by blast
     have "lnth Sts (j - 1) \<leadsto> lnth Sts j"
       using j_p'(1) jn0 deriv chain_lnth_rel[of _ _ "j - 1"] by force
     then obtain C' where C'_p:
       "?Ns (j - 1) = {}"
       "?Ps (j - 1) = ?Ps j \<union> {C'}"
       "?Qs j = ?Qs (j - 1) \<union> {C'}"
       "?Ns j = concls_of (ord_FO_resolution.inferences_between (?Qs (j - 1)) C')"
       "C' \<in> set CAs' \<union> {DA'}"
       "C' \<notin> ?Qs (j - 1)"
       using j_adds_CAs' by (induction rule: RP.cases) auto
     have "E' \<in> ?Ns j"
     proof -
       have "E' \<in> concls_of (ord_FO_resolution.inferences_between (Q_of_state (lnth Sts (j - 1))) C')"
         unfolding infer_from_def ord_FO_\<Gamma>_def inference_system.inferences_between_def
         apply (rule_tac x = "Infer (mset CAs') DA' E'" in image_eqI)
         subgoal by auto
         subgoal
           unfolding infer_from_def
           by (rule ord_resolve_rename.cases[OF s_p(4)]) (use s_p(4) C'_p(3,5) j_p'(2) in force)
         done
       then show ?thesis
         using C'_p(4) by auto
     qed
     then have "E' \<in> clss_of_state (lnth Sts j)"
       using j_p' by auto
     then have "?E \<in> grounding_of_state (lnth Sts j)"
       using s_p(7) s_p(3) unfolding grounding_of_clss_def grounding_of_cls_def by force
     then have "\<gamma> \<in> sr.Ri (grounding_of_state (lnth Sts j))"
       using sr.Ri_effective \<gamma>_p by auto
     then have "\<gamma> \<in> sr_ext_Ri (?N j)"
       unfolding sr_ext_Ri_def by auto
     then have "\<gamma> \<in> sr_ext_Ri (Sup_llist (lmap grounding_of_state Sts))"
-      using j_p' contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr_ext.Ri_mono by smt
+      using j_p' contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr_ext.Ri_mono by (smt (verit))
     then have "\<gamma> \<in> sr_ext_Ri (Liminf_llist (lmap grounding_of_state Sts))"
       using sr_ext.Ri_limit_Sup[of Gs] derivns ns by blast
   }
   then have "sr_ext.saturated_upto (Liminf_llist (lmap grounding_of_state Sts))"
     unfolding sr_ext.saturated_upto_def sr_ext.inferences_from_def infer_from_def sr_ext_Ri_def
     by auto
   then show ?thesis
     using gd_ord_\<Gamma>_ngd_ord_\<Gamma> sr.redundancy_criterion_axioms
       redundancy_criterion_standard_extension_saturated_upto_iff[of gr.ord_\<Gamma>]
     unfolding sr_ext_Ri_def by auto
 qed
 
 corollary RP_complete_if_fair:
   assumes
     deriv: "chain (\<leadsto>) Sts" and
     fair: "fair_state_seq Sts" and
     empty_Q0: "Q_of_state (lhd Sts) = {}" and
     unsat: "\<not> satisfiable (grounding_of_state (lhd Sts))"
   shows "{#} \<in> Q_of_state (Liminf_state Sts)"
 proof -
   have "\<not> satisfiable (Liminf_llist (lmap grounding_of_state Sts))"
     using unsat sr_ext.sat_limit_iff[OF ground_derive_chain] chain_not_lnull deriv by fastforce
   moreover have "sr.saturated_upto (Liminf_llist (lmap grounding_of_state Sts))"
     by (rule RP_saturated_if_fair[OF deriv fair empty_Q0, simplified])
   ultimately have "{#} \<in> Liminf_llist (lmap grounding_of_state Sts)"
     using sr.saturated_upto_complete_if by auto
   then show ?thesis
     using empty_clause_in_Q_of_Liminf_state[OF deriv fair] by auto
 qed
 
 end
 
 end
 
 end
diff --git a/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy b/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy
--- a/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy
+++ b/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy
@@ -1,707 +1,707 @@
 (*  Title:       Relational Chains over Lazy Lists
     Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
     Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
     Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
     Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
 *)
 
 section \<open>Relational Chains over Lazy Lists\<close>
 
 theory Lazy_List_Chain
   imports
     "HOL-Library.BNF_Corec"
     Lazy_List_Liminf
 begin
 
 text \<open>
 A chain is a lazy list of elements such that all pairs of consecutive elements are related by a
 given relation. A full chain is either an infinite chain or a finite chain that cannot be extended.
 The inspiration for this theory is Section 4.1 (``Theorem Proving Processes'') of Bachmair and
 Ganzinger's chapter.
 \<close>
 
 
 subsection \<open>Chains\<close>
 
 coinductive chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> bool" for R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
   chain_singleton: "chain R (LCons x LNil)"
 | chain_cons: "chain R xs \<Longrightarrow> R x (lhd xs) \<Longrightarrow> chain R (LCons x xs)"
 
 lemma
   chain_LNil[simp]: "\<not> chain R LNil" and
   chain_not_lnull: "chain R xs \<Longrightarrow> \<not> lnull xs"
   by (auto elim: chain.cases)
 
 lemma chain_lappend:
   assumes
     r_xs: "chain R xs" and
     r_ys: "chain R ys" and
     mid: "R (llast xs) (lhd ys)"
   shows "chain R (lappend xs ys)"
 proof (cases "lfinite xs")
   case True
   then show ?thesis
     using r_xs mid
   proof (induct rule: lfinite.induct)
     case (lfinite_LConsI xs x)
     note fin = this(1) and ih = this(2) and r_xxs = this(3) and mid = this(4)
     show ?case
     proof (cases "xs = LNil")
       case True
       then show ?thesis
         using r_ys mid by simp (rule chain_cons)
     next
       case xs_nnil: False
       have r_xs: "chain R xs"
         by (metis chain.simps ltl_simps(2) r_xxs xs_nnil)
       have mid': "R (llast xs) (lhd ys)"
         by (metis llast_LCons lnull_def mid xs_nnil)
       have start: "R x (lhd (lappend xs ys))"
         by (metis (no_types) chain.simps lhd_LCons lhd_lappend chain_not_lnull ltl_simps(2) r_xxs
             xs_nnil)
       show ?thesis
         unfolding lappend_code(2) using ih[OF r_xs mid'] start by (rule chain_cons)
     qed
   qed simp
 qed (simp add: r_xs lappend_inf)
 
 lemma chain_length_pos: "chain R xs \<Longrightarrow> llength xs > 0"
   by (cases xs) simp+
 
 lemma chain_ldropn:
   assumes "chain R xs" and "enat n < llength xs"
   shows "chain R (ldropn n xs)"
   using assms
   by (induct n arbitrary: xs, simp,
       metis chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less)
 
 lemma inf_chain_ldropn_chain: "chain R xs \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> chain R (ldropn n xs)"
   using chain.simps[of R xs] by (simp add: chain_ldropn not_lfinite_llength)
 
 lemma inf_chain_ltl_chain: "chain R xs \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> chain R (ltl xs)"
   by (metis inf_chain_ldropn_chain ldropn_0 ldropn_ltl)
 
 lemma chain_lnth_rel:
   assumes
     chain: "chain R xs" and
     len: "enat (Suc j) < llength xs"
   shows "R (lnth xs j) (lnth xs (Suc j))"
 proof -
   define ys where "ys = ldropn j xs"
   have "llength ys > 1"
     unfolding ys_def using len
     by (metis One_nat_def funpow_swap1 ldropn_0 ldropn_def ldropn_eq_LNil ldropn_ltl not_less
         one_enat_def)
   obtain y0 y1 ys' where
     ys: "ys = LCons y0 (LCons y1 ys')"
     unfolding ys_def by (metis Suc_ile_eq ldropn_Suc_conv_ldropn len less_imp_not_less not_less)
   have "chain R ys"
     unfolding ys_def using Suc_ile_eq chain chain_ldropn len less_imp_le by blast
   then have "R y0 y1"
     unfolding ys by (auto elim: chain.cases)
   then show ?thesis
     using ys_def unfolding ys by (metis ldropn_Suc_conv_ldropn ldropn_eq_LConsD llist.inject)
 qed
 
 lemma infinite_chain_lnth_rel:
   assumes "\<not> lfinite c" and "chain r c"
   shows "r (lnth c i) (lnth c (Suc i))"
   using assms chain_lnth_rel lfinite_conv_llength_enat by force
 
 lemma lnth_rel_chain:
   assumes
     "\<not> lnull xs" and
     "\<forall>j. enat (j + 1) < llength xs \<longrightarrow> R (lnth xs j) (lnth xs (j + 1))"
   shows "chain R xs"
   using assms
 proof (coinduction arbitrary: xs rule: chain.coinduct)
   case chain
   note nnul = this(1) and nth_chain = this(2)
 
   show ?case
   proof (cases "lnull (ltl xs)")
     case True
     have "xs = LCons (lhd xs) LNil"
       using nnul True by (simp add: llist.expand)
     then show ?thesis
       by blast
   next
     case nnul': False
     moreover have "xs = LCons (lhd xs) (ltl xs)"
       using nnul by simp
     moreover have
       "\<forall>j. enat (j + 1) < llength (ltl xs) \<longrightarrow> R (lnth (ltl xs) j) (lnth (ltl xs) (j + 1))"
       using nnul nth_chain
       by (metis Suc_eq_plus1 ldrop_eSuc_ltl ldropn_Suc_conv_ldropn ldropn_eq_LConsD lnth_ltl)
     moreover have "R (lhd xs) (lhd (ltl xs))"
       using nnul' nnul nth_chain[rule_format, of 0, simplified]
       by (metis ldropn_0 ldropn_Suc_conv_ldropn ldropn_eq_LConsD lhd_LCons_ltl lhd_conv_lnth
           lnth_Suc_LCons ltl_simps(2))
     ultimately show ?thesis
       by blast
   qed
 qed
 
 lemma chain_lmap:
   assumes "\<forall>x y. R x y \<longrightarrow> R' (f x) (f y)" and "chain R xs"
   shows "chain R' (lmap f xs)"
   using assms
 proof (coinduction arbitrary: xs)
   case chain
   then have "(\<exists>y. xs = LCons y LNil) \<or> (\<exists>ys x. xs = LCons x ys \<and> chain R ys \<and> R x (lhd ys))"
     using chain.simps[of R xs] by auto
   then show ?case
   proof
     assume "\<exists>ys x. xs = LCons x ys \<and> chain R ys \<and> R x (lhd ys)"
     then have "\<exists>ys x. lmap f xs = LCons x ys \<and>
       (\<exists>xs. ys = lmap f xs \<and> (\<forall>x y. R x y \<longrightarrow> R' (f x) (f y)) \<and> chain R xs) \<and> R' x (lhd ys)"
       using chain
       by (metis (no_types) lhd_LCons llist.distinct(1) llist.exhaust_sel llist.map_sel(1)
           lmap_eq_LNil chain_not_lnull ltl_lmap ltl_simps(2))
     then show ?thesis
       by auto
   qed auto
 qed
 
 lemma chain_mono:
   assumes "\<forall>x y. R x y \<longrightarrow> R' x y" and "chain R xs"
   shows "chain R' xs"
   using assms by (rule chain_lmap[of _ _ "\<lambda>x. x", unfolded llist.map_ident])
 
 lemma chain_ldropnI:
   assumes
     rel: "\<forall>j. j \<ge> i \<longrightarrow> enat (Suc j) < llength xs \<longrightarrow> R (lnth xs j) (lnth xs (Suc j))" and
     si_lt: "enat (Suc i) < llength xs"
   shows "chain R (ldropn i xs)"
 proof (rule lnth_rel_chain)
   show "\<not> lnull (ldropn i xs)"
     using si_lt by (simp add: Suc_ile_eq less_le_not_le)
 next
   show "\<forall>j. enat (j + 1) < llength (ldropn i xs) \<longrightarrow>
     R (lnth (ldropn i xs) j) (lnth (ldropn i xs) (j + 1))"
-    using rel by (smt (z3) One_nat_def Suc_ile_eq add.commute add.right_neutral add_Suc_right
-        add_le_cancel_right ldropn_eq_LNil ldropn_ldropn less_le_not_le linorder_not_less
-        lnth_ldropn not_less_zero)
+    using rel
+    by (smt (verit, best) Suc_ile_eq add.commute ldropn_eq_LNil ldropn_ldropn leD
+        le_add1 linorder_le_less_linear lnth_ldropn order_less_imp_le plus_1_eq_Suc)
 qed
 
 lemma chain_ldropn_lmapI:
   assumes
     rel: "\<forall>j. j \<ge> i \<longrightarrow> enat (Suc j) < llength xs \<longrightarrow> R (f (lnth xs j)) (f (lnth xs (Suc j)))" and
     si_lt: "enat (Suc i) < llength xs"
   shows "chain R (ldropn i (lmap f xs))"
 proof -
   have "chain R (lmap f (ldropn i xs))"
     using chain_lmap[of "\<lambda>x y. R (f x) (f y)" R f, of "ldropn i xs"] chain_ldropnI[OF rel si_lt]
     by auto
   thus ?thesis
     by auto
 qed
 
 lemma lfinite_chain_imp_rtranclp_lhd_llast: "lfinite xs \<Longrightarrow> chain R xs \<Longrightarrow> R\<^sup>*\<^sup>* (lhd xs) (llast xs)"
 proof (induct rule: lfinite.induct)
   case (lfinite_LConsI xs x)
   note fin_xs = this(1) and ih = this(2) and r_x_xs = this(3)
   show ?case
   proof (cases "xs = LNil")
     case xs_nnil: False
     then have r_xs: "chain R xs"
       using r_x_xs by (blast elim: chain.cases)
     then show ?thesis
       using ih[OF r_xs] xs_nnil r_x_xs
       by (metis chain.cases converse_rtranclp_into_rtranclp lhd_LCons llast_LCons chain_not_lnull
           ltl_simps(2))
   qed simp
 qed simp
 
 lemma tranclp_imp_exists_finite_chain_list:
   "R\<^sup>+\<^sup>+ x y \<Longrightarrow> \<exists>xs. chain R (llist_of (x # xs @ [y]))"
 proof (induct rule: tranclp.induct)
   case (r_into_trancl x y)
   then have "chain R (llist_of (x # [] @ [y]))"
     by (auto intro: chain.intros)
   then show ?case
     by blast
 next
   case (trancl_into_trancl x y z)
   note rstar_xy = this(1) and ih = this(2) and r_yz = this(3)
 
   obtain xs where
     xs: "chain R (llist_of (x # xs @ [y]))"
     using ih by blast
   define ys where
     "ys = xs @ [y]"
 
   have "chain R (llist_of (x # ys @ [z]))"
     unfolding ys_def using r_yz chain_lappend[OF xs chain_singleton, of z]
     by (auto simp: lappend_llist_of_LCons llast_LCons)
   then show ?case
     by blast
 qed
 
 inductive_cases chain_consE: "chain R (LCons x xs)"
 inductive_cases chain_nontrivE: "chain R (LCons x (LCons y xs))"
 
 
 subsection \<open>A Coinductive Puzzle\<close>
 
 primrec prepend where
   "prepend [] ys = ys"
 | "prepend (x # xs) ys = LCons x (prepend xs ys)"
 
 lemma lnull_prepend[simp]: "lnull (prepend xs ys) = (xs = [] \<and> lnull ys)"
   by (induct xs) auto
 
 lemma lhd_prepend[simp]: "lhd (prepend xs ys) = (if xs \<noteq> [] then hd xs else lhd ys)"
   by (induct xs) auto
 
 lemma prepend_LNil[simp]: "prepend xs LNil = llist_of xs"
   by (induct xs) auto
 
 lemma lfinite_prepend[simp]: "lfinite (prepend xs ys) \<longleftrightarrow> lfinite ys"
   by (induct xs) auto
 
 lemma llength_prepend[simp]: "llength (prepend xs ys) = length xs + llength ys"
   by (induct xs) (auto simp: enat_0 iadd_Suc eSuc_enat[symmetric])
 
 lemma llast_prepend[simp]: "\<not> lnull ys \<Longrightarrow> llast (prepend xs ys) = llast ys"
   by (induct xs) (auto simp: llast_LCons)
 
 lemma prepend_prepend: "prepend xs (prepend ys zs) = prepend (xs @ ys) zs"
   by (induct xs) auto
 
 lemma chain_prepend:
   "chain R (llist_of zs) \<Longrightarrow> last zs = lhd xs \<Longrightarrow> chain R xs \<Longrightarrow> chain R (prepend zs (ltl xs))"
   by (induct zs; cases xs)
     (auto split: if_splits simp: lnull_def[symmetric] intro!: chain_cons elim!: chain_consE)
 
 lemma lmap_prepend[simp]: "lmap f (prepend xs ys) = prepend (map f xs) (lmap f ys)"
   by (induct xs) auto
 
 lemma lset_prepend[simp]: "lset (prepend xs ys) = set xs \<union> lset ys"
   by (induct xs) auto
 
 lemma prepend_LCons: "prepend xs (LCons y ys) = prepend (xs @ [y]) ys"
   by (induct xs) auto
 
 lemma lnth_prepend:
   "lnth (prepend xs ys) i = (if i < length xs then nth xs i else lnth ys (i - length xs))"
   by (induct xs arbitrary: i) (auto simp: lnth_LCons' nth_Cons')
 
 theorem lfinite_less_induct[consumes 1, case_names less]:
   assumes fin: "lfinite xs"
     and step: "\<And>xs. lfinite xs \<Longrightarrow> (\<And>zs. llength zs < llength xs \<Longrightarrow> P zs) \<Longrightarrow> P xs"
   shows "P xs"
 using fin proof (induct "the_enat (llength xs)" arbitrary: xs rule: less_induct)
   case (less xs)
   show ?case
     using less(2) by (intro step[OF less(2)] less(1))
       (auto dest!: lfinite_llength_enat simp: eSuc_enat elim!: less_enatE llength_eq_enat_lfiniteD)
 qed
 
 theorem lfinite_prepend_induct[consumes 1, case_names LNil prepend]:
   assumes "lfinite xs"
     and LNil: "P LNil"
     and prepend: "\<And>xs. lfinite xs \<Longrightarrow> (\<And>zs. (\<exists>ys. xs = prepend ys zs \<and> ys \<noteq> []) \<Longrightarrow> P zs) \<Longrightarrow> P xs"
   shows "P xs"
 using assms(1) proof (induct xs rule: lfinite_less_induct)
   case (less xs)
   from less(1) show ?case
     by (cases xs)
       (force simp: LNil neq_Nil_conv dest: lfinite_llength_enat intro!: prepend[of "LCons _ _"] intro: less)+
 qed
 
 coinductive emb :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> bool" where
   "lfinite xs \<Longrightarrow> emb LNil xs"
 | "emb xs ys \<Longrightarrow> emb (LCons x xs) (prepend zs (LCons x ys))"
 
 inductive_cases emb_LConsE: "emb (LCons z zs) ys"
 inductive_cases emb_LNil1E: "emb LNil ys"
 inductive_cases emb_LNil2E: "emb xs LNil"
 
 lemma emb_lfinite:
   assumes "emb xs ys"
   shows "lfinite ys \<longleftrightarrow> lfinite xs"
 proof
   assume "lfinite xs"
   then show "lfinite ys" using assms
     by (induct xs arbitrary: ys rule: lfinite_induct)
       (auto simp: lnull_def neq_LNil_conv elim!: emb_LNil1E emb_LConsE)
 next
   assume "lfinite ys"
   then show "lfinite xs" using assms
   proof (induction ys arbitrary: xs rule: lfinite_less_induct)
     case (less ys)
     from less.prems \<open>lfinite ys\<close> show ?case
       by (cases xs)
         (auto simp: eSuc_enat elim!: emb_LNil1E emb_LConsE less.IH[rotated]
           dest!: lfinite_llength_enat)
   qed
 qed
 
 inductive prepend_cong1 for X where
   prepend_cong1_base: "X xs \<Longrightarrow> prepend_cong1 X xs"
 | prepend_cong1_prepend: "prepend_cong1 X ys \<Longrightarrow> prepend_cong1 X (prepend xs ys)"
 
 lemma prepend_cong1_alt: "prepend_cong1 X xs \<longleftrightarrow> (\<exists>ys zs. xs = prepend ys zs \<and> X zs)"
   by (rule iffI, induct xs rule: prepend_cong1.induct)
     (force simp: prepend_prepend intro: prepend_cong1.intros exI[of _ "[]"])+
 
 lemma emb_prepend_coinduct_cong[rotated, case_names emb]:
   assumes "(\<And>x1 x2. X x1 x2 \<Longrightarrow>
     (\<exists>xs. x1 = LNil \<and> x2 = xs \<and> lfinite xs)
      \<or> (\<exists>xs ys x zs. x1 = LCons x xs \<and> x2 = prepend zs (LCons x ys)
        \<and> (prepend_cong1 (X xs) ys \<or> emb xs ys)))" (is "\<And>x1 x2. X x1 x2 \<Longrightarrow> ?bisim x1 x2")
   shows "X x1 x2 \<Longrightarrow> emb x1 x2"
 proof (erule emb.coinduct[OF prepend_cong1_base])
   fix xs zs
   assume "prepend_cong1 (X xs) zs"
   then show "?bisim xs zs"
     by (induct zs rule: prepend_cong1.induct) (erule assms, force simp: prepend_prepend)
 qed
 
 lemma emb_prepend: "emb xs ys \<Longrightarrow> emb xs (prepend zs ys)"
   by (coinduction arbitrary: xs zs ys rule: emb_prepend_coinduct_cong)
     (force elim: emb.cases simp: prepend_prepend)
 
 lemma prepend_cong1_emb: "prepend_cong1 (emb xs) ys = emb xs ys"
   by (rule iffI, induct ys rule: prepend_cong1.induct)
     (simp_all add: emb_prepend prepend_cong1_base)
 
 lemma prepend_cong_distrib:
   "prepend_cong1 (P \<squnion> Q) xs \<longleftrightarrow> prepend_cong1 P xs \<or> prepend_cong1 Q xs"
   unfolding prepend_cong1_alt by auto
 
 lemma emb_prepend_coinduct_aux[case_names emb]:
   assumes "X x1 x2 " "(\<And>x1 x2. X x1 x2 \<Longrightarrow>
     (\<exists>xs. x1 = LNil \<and> x2 = xs \<and> lfinite xs)
      \<or> (\<exists>xs ys x zs. x1 = LCons x xs \<and> x2 = prepend zs (LCons x ys)
        \<and> (prepend_cong1 (X xs \<squnion> emb xs) ys)))"
   shows "emb x1 x2"
   using assms unfolding prepend_cong_distrib prepend_cong1_emb
   by (rule emb_prepend_coinduct_cong)
 
 lemma emb_prepend_coinduct[rotated, case_names emb]:
   assumes "(\<And>x1 x2. X x1 x2 \<Longrightarrow>
     (\<exists>xs. x1 = LNil \<and> x2 = xs \<and> lfinite xs)
      \<or> (\<exists>xs ys x zs zs'. x1 = LCons x xs \<and> x2 = prepend zs (LCons x (prepend zs' ys))
        \<and> (X xs ys \<or> emb xs ys)))"
   shows "X x1 x2 \<Longrightarrow> emb x1 x2"
   by (erule emb_prepend_coinduct_aux[of X]) (force simp: prepend_cong1_alt dest: assms)
 
 
 context
 begin
 
 private coinductive chain' for R where
   "chain' R (LCons x LNil)"
 | "chain R (llist_of (x # zs @ [lhd xs])) \<Longrightarrow>
    chain' R xs \<Longrightarrow> chain' R (LCons x (prepend zs xs))"
 
 private lemma chain_imp_chain': "chain R xs \<Longrightarrow> chain' R xs"
 proof (coinduction arbitrary: xs rule: chain'.coinduct)
   case chain'
   then show ?case
   proof (cases rule: chain.cases)
     case (chain_cons zs z)
     then show ?thesis
       by (intro disjI2 exI[of _ z] exI[of _ "[]"] exI[of _ "zs"])
         (auto intro: chain.intros)
   qed simp
 qed
 
 private lemma chain'_imp_chain: "chain' R xs \<Longrightarrow> chain R xs"
 proof (coinduction arbitrary: xs rule: chain.coinduct)
   case chain
   then show ?case
   proof (cases rule: chain'.cases)
     case (2 y zs ys)
     then show ?thesis
       by (intro disjI2 exI[of _ "prepend zs ys"] exI[of _ y])
         (force dest!: neq_Nil_conv[THEN iffD1] elim: chain.cases chain_nontrivE
           intro: chain'.intros)
   qed simp
 qed
 
 private lemma chain_chain': "chain = chain'"
   unfolding fun_eq_iff by (metis chain_imp_chain' chain'_imp_chain)
 
 lemma chain_prepend_coinduct[case_names chain]:
   "X x \<Longrightarrow> (\<And>x. X x \<Longrightarrow>
     (\<exists>z. x = LCons z LNil) \<or>
     (\<exists>y xs zs. x = LCons y (prepend zs xs) \<and>
       (X xs \<or> chain R xs) \<and> chain R (llist_of (y # zs @ [lhd xs])))) \<Longrightarrow> chain R x"
   by (subst chain_chain', erule chain'.coinduct) (force simp: chain_chain')
 
 end
 
 context
   fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
 begin
 
 private definition pick where
   "pick x y = (SOME xs. chain R (llist_of (x # xs @ [y])))"
 
 private lemma pick[simp]:
   assumes "R\<^sup>+\<^sup>+ x y"
   shows "chain R (llist_of (x # pick x y @ [y]))"
   unfolding pick_def using tranclp_imp_exists_finite_chain_list[THEN someI_ex, OF assms] by auto
 
 private friend_of_corec prepend where
   "prepend xs ys = (case xs of [] \<Rightarrow>
     (case ys of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons x xs) | x # xs' \<Rightarrow> LCons x (prepend xs' ys))"
   by (simp split: list.splits llist.splits) transfer_prover
 
 private corec wit where
   "wit xs = (case xs of LCons x (LCons y xs) \<Rightarrow>
      LCons x (prepend (pick x y) (wit (LCons y xs))) | _ \<Rightarrow> xs)"
 
 private lemma
   wit_LNil[simp]: "wit LNil = LNil" and
   wit_lsingleton[simp]: "wit (LCons x LNil) = LCons x LNil" and
   wit_LCons2: "wit (LCons x (LCons y xs)) =
      (LCons x (prepend (pick x y) (wit (LCons y xs))))"
   by (subst wit.code; auto)+
 
 private lemma lnull_wit[simp]: "lnull (wit xs) \<longleftrightarrow> lnull xs"
   by (subst wit.code) (auto split: llist.splits simp: Let_def)
 
 private lemma lhd_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow> lhd (wit xs) = lhd xs"
   by (erule chain.cases; subst wit.code) (auto split: llist.splits simp: Let_def)
 
 private lemma LNil_eq_iff_lnull: "LNil = xs \<longleftrightarrow> lnull xs"
   by (cases xs) auto
 
 lemma emb_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow> emb xs (wit xs)"
 proof (coinduction arbitrary: xs rule: emb_prepend_coinduct)
   case (emb xs)
   then show ?case
   proof (cases rule: chain.cases)
     case (chain_cons zs z)
     then show ?thesis
       by (subst (2) wit.code)
         (auto 0 3 split: llist.splits intro: exI[of _ "[]"] exI[of _ "pick z _"]
            intro!: exI[of _ "_ :: _ llist"])
   qed (auto intro!: exI[of _ LNil] exI[of _ "[]"] emb.intros)
 qed
 
 private lemma lfinite_wit[simp]:
   assumes "chain R\<^sup>+\<^sup>+ xs"
   shows "lfinite (wit xs) \<longleftrightarrow> lfinite xs"
   using emb_wit emb_lfinite assms by blast
 
 private lemma llast_wit[simp]:
   assumes "chain R\<^sup>+\<^sup>+ xs"
   shows "llast (wit xs) = llast xs"
 proof (cases "lfinite xs")
   case True
   from this assms show ?thesis
   proof (induct rule: lfinite.induct)
     case (lfinite_LConsI xs x)
     then show ?case
       by (cases xs) (auto simp: wit_LCons2 llast_LCons elim: chain_nontrivE)
   qed auto
 qed (auto simp: llast_linfinite assms)
 
 lemma chain_tranclp_imp_exists_chain:
   "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow>
    \<exists>ys. chain R ys \<and> emb xs ys \<and> lhd ys = lhd xs \<and> llast ys = llast xs"
 proof (intro exI[of _ "wit xs"] conjI, coinduction arbitrary: xs rule: chain_prepend_coinduct)
   case chain
   then show ?case
     by (subst (1 2) wit.code) (erule chain.cases; force split: llist.splits dest: pick)
 qed auto
 
 lemma emb_lset_mono[rotated]: "x \<in> lset xs \<Longrightarrow> emb xs ys \<Longrightarrow> x \<in> lset ys"
   by (induct x xs arbitrary: ys rule: llist.set_induct) (auto elim!: emb_LConsE)
 
 lemma emb_Ball_lset_antimono:
   assumes "emb Xs Ys"
   shows "\<forall>Y \<in> lset Ys. x \<in> Y \<Longrightarrow> \<forall>X \<in> lset Xs. x \<in> X"
   using emb_lset_mono[OF assms] by blast
 
 lemma emb_lfinite_antimono[rotated]: "lfinite ys \<Longrightarrow> emb xs ys \<Longrightarrow> lfinite xs"
   by (induct ys arbitrary: xs rule: lfinite_prepend_induct)
     (force elim!: emb_LNil2E simp: LNil_eq_iff_lnull prepend_LCons elim: emb.cases)+
 
 lemma emb_Liminf_llist_mono_aux:
   assumes "emb Xs Ys" and "\<not> lfinite Xs" and "\<not> lfinite Ys" and "\<forall>j\<ge>i. x \<in> lnth Ys j"
   shows "\<forall>j\<ge>i. x \<in> lnth Xs j"
 using assms proof (induct i arbitrary: Xs Ys rule: less_induct)
   case (less i)
   then show ?case
   proof (cases i)
     case 0
     then show ?thesis
       using emb_Ball_lset_antimono[OF less(2), of x] less(5)
       unfolding Ball_def in_lset_conv_lnth simp_thms
         not_lfinite_llength[OF less(3)] not_lfinite_llength[OF less(4)] enat_ord_code subset_eq
       by blast
   next
     case [simp]: (Suc nat)
     from less(2,3) obtain xs as b bs where
       [simp]: "Xs = LCons b xs" "Ys = prepend as (LCons b bs)" and "emb xs bs"
       by (auto elim: emb.cases)
     have IH: "\<forall>k\<ge>j. x \<in> lnth xs k" if "\<forall>k\<ge>j. x \<in> lnth bs k" "j < i" for j
       using that less(1)[OF _ \<open>emb xs bs\<close>] less(3,4) by auto
     from less(5) have "\<forall>k\<ge>i - length as - 1. x \<in> lnth xs k"
       by (intro IH allI)
         (drule spec[of _ "_ + length as + 1"], auto simp: lnth_prepend lnth_LCons')
     then show ?thesis
       by (auto simp: lnth_LCons')
   qed
 qed
 
 lemma emb_Liminf_llist_infinite:
   assumes "emb Xs Ys" and "\<not> lfinite Xs"
   shows "Liminf_llist Ys \<subseteq> Liminf_llist Xs"
 proof -
   from assms have "\<not> lfinite Ys"
     using emb_lfinite_antimono by blast
   with assms show ?thesis
     unfolding Liminf_llist_def by (auto simp: not_lfinite_llength dest: emb_Liminf_llist_mono_aux)
 qed
 
 lemma emb_lmap: "emb xs ys \<Longrightarrow> emb (lmap f xs) (lmap f ys)"
 proof (coinduction arbitrary: xs ys rule: emb.coinduct)
   case emb
   show ?case
   proof (cases xs)
     case xs: (LCons x xs')
 
     obtain ysa0 and zs0 where
       ys: "ys = prepend zs0 (LCons x ysa0)" and
       emb': "emb xs' ysa0"
       using emb_LConsE[OF emb[unfolded xs]] by metis
 
     let ?xa = "f x"
     let ?xsa = "lmap f xs'"
     let ?zs = "map f zs0"
     let ?ysa = "lmap f ysa0"
 
     have "lmap f xs = LCons ?xa ?xsa"
       unfolding xs by simp
     moreover have "lmap f ys = prepend ?zs (LCons ?xa ?ysa)"
       unfolding ys by simp
     moreover have "\<exists>xsa ysa. ?xsa = lmap f xsa \<and> ?ysa = lmap f ysa \<and> emb xsa ysa"
       using emb' by blast
     ultimately show ?thesis
       by blast
   qed (simp add: emb_lfinite[OF emb])
 qed
 
 end
 
 lemma chain_inf_llist_if_infinite_chain_function:
   assumes "\<forall>i. r (f (Suc i)) (f i)"
   shows "\<not> lfinite (inf_llist f) \<and> chain r\<inverse>\<inverse> (inf_llist f)"
   using assms by (simp add: lnth_rel_chain)
 
 lemma infinite_chain_function_iff_infinite_chain_llist:
   "(\<exists>f. \<forall>i. r (f (Suc i)) (f i)) \<longleftrightarrow> (\<exists>c. \<not> lfinite c \<and> chain r\<inverse>\<inverse> c)"
   using chain_inf_llist_if_infinite_chain_function infinite_chain_lnth_rel by blast
 
 lemma wfP_iff_no_infinite_down_chain_llist: "wfP r \<longleftrightarrow> (\<nexists>c. \<not> lfinite c \<and> chain r\<inverse>\<inverse> c)"
 proof -
   have "wfP r \<longleftrightarrow>  wf {(x, y). r x y}"
     unfolding wfP_def by auto
   also have "\<dots> \<longleftrightarrow> (\<nexists>f. \<forall>i. (f (Suc i), f i) \<in> {(x, y). r x y})"
     using wf_iff_no_infinite_down_chain by blast
   also have "\<dots> \<longleftrightarrow> (\<nexists>f. \<forall>i. r (f (Suc i)) (f i))"
     by auto
   also have "\<dots> \<longleftrightarrow> (\<nexists>c. \<not>lfinite c \<and> chain r\<inverse>\<inverse> c)"
     using infinite_chain_function_iff_infinite_chain_llist by blast
   finally show ?thesis
     by auto
 qed
 
 
 subsection \<open>Full Chains\<close>
 
 coinductive full_chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> bool" for R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
   full_chain_singleton: "(\<forall>y. \<not> R x y) \<Longrightarrow> full_chain R (LCons x LNil)"
 | full_chain_cons: "full_chain R xs \<Longrightarrow> R x (lhd xs) \<Longrightarrow> full_chain R (LCons x xs)"
 
 lemma
   full_chain_LNil[simp]: "\<not> full_chain R LNil" and
   full_chain_not_lnull: "full_chain R xs \<Longrightarrow> \<not> lnull xs"
   by (auto elim: full_chain.cases)
 
 lemma full_chain_ldropn:
   assumes full: "full_chain R xs" and "enat n < llength xs"
   shows "full_chain R (ldropn n xs)"
   using assms
   by (induct n arbitrary: xs, simp,
       metis full_chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less)
 
 lemma full_chain_iff_chain:
   "full_chain R xs \<longleftrightarrow> chain R xs \<and> (lfinite xs \<longrightarrow> (\<forall>y. \<not> R (llast xs) y))"
 proof (intro iffI conjI impI allI; (elim conjE)?)
   assume full: "full_chain R xs"
 
   show chain: "chain R xs"
     using full by (coinduction arbitrary: xs) (auto elim: full_chain.cases)
 
   {
     fix y
     assume "lfinite xs"
     then obtain n where
       suc_n: "Suc n = llength xs"
       by (metis chain chain_length_pos lessE less_enatE lfinite_conv_llength_enat)
 
     have "full_chain R (ldropn n xs)"
       by (rule full_chain_ldropn[OF full]) (use suc_n Suc_ile_eq in force)
     moreover have "ldropn n xs = LCons (llast xs) LNil"
       using suc_n by (metis enat_le_plus_same(2) enat_ord_simps(2) gen_llength_def
           ldropn_Suc_conv_ldropn ldropn_all lessI llast_ldropn llast_singleton llength_code)
     ultimately show "\<not> R (llast xs) y"
       by (auto elim: full_chain.cases)
   }
 next
   assume
     "chain R xs" and
     "lfinite xs \<longrightarrow> (\<forall>y. \<not> R (llast xs) y)"
   then show "full_chain R xs"
     by (coinduction arbitrary: xs) (erule chain.cases, simp, metis lfinite_LConsI llast_LCons)
 qed
 
 lemma full_chain_imp_chain: "full_chain R xs \<Longrightarrow> chain R xs"
   using full_chain_iff_chain by blast
 
 lemma full_chain_length_pos: "full_chain R xs \<Longrightarrow> llength xs > 0"
   by (fact chain_length_pos[OF full_chain_imp_chain])
 
 lemma full_chain_lnth_rel:
   "full_chain R xs \<Longrightarrow> enat (Suc j) < llength xs \<Longrightarrow> R (lnth xs j) (lnth xs (Suc j))"
   by (fact chain_lnth_rel[OF full_chain_imp_chain])
 
 lemma full_chain_lnth_not_rel:
   assumes
     full: "full_chain R xs" and
     sj: "enat (Suc j) = llength xs"
   shows "\<not> R (lnth xs j) y"
 proof -
   have "lfinite xs"
     by (metis llength_eq_enat_lfiniteD sj)
   hence "\<not> R (llast xs) y"
     using full_chain_iff_chain full by metis
   thus ?thesis
     by (metis eSuc_enat llast_conv_lnth sj)
 qed
 
 inductive_cases full_chain_consE: "full_chain R (LCons x xs)"
 inductive_cases full_chain_nontrivE: "full_chain R (LCons x (LCons y xs))"
 
 lemma full_chain_tranclp_imp_exists_full_chain:
   assumes full: "full_chain R\<^sup>+\<^sup>+ xs"
   shows "\<exists>ys. full_chain R ys \<and> emb xs ys \<and> lhd ys = lhd xs \<and> llast ys = llast xs"
 proof -
   obtain ys where ys:
     "chain R ys" "emb xs ys" "lhd ys = lhd xs" "llast ys = llast xs"
     using full_chain_imp_chain[OF full] chain_tranclp_imp_exists_chain by blast
   have "full_chain R ys"
     using ys(1,4) emb_lfinite[OF ys(2)] full unfolding full_chain_iff_chain by auto
   then show ?thesis
     using ys(2-4) by auto
 qed
 
 end
diff --git a/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy b/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy
--- a/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy
+++ b/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy
@@ -1,389 +1,389 @@
 (*  Title:       Supremum and Liminf of Lazy Lists
     Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017, 2020
     Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
     Maintainer:  Jasmin Blanchette <j.c.blanchette at vu.nl>
 *)
 
 section \<open>Supremum and Liminf of Lazy Lists\<close>
 
 theory Lazy_List_Liminf
   imports Coinductive.Coinductive_List
 begin
 
 text \<open>
 Lazy lists, as defined in the \emph{Archive of Formal Proofs}, provide finite and infinite lists in
 one type, defined coinductively. The present theory introduces the concept of the union of all
 elements of a lazy list of sets and the limit of such a lazy list. The definitions are stated more
 generally in terms of lattices. The basis for this theory is Section 4.1 (``Theorem Proving
 Processes'') of Bachmair and Ganzinger's chapter.
 \<close>
 
 
 subsection \<open>Library\<close>
 
 lemma less_llength_ltake: "i < llength (ltake k Xs) \<longleftrightarrow> i < k \<and> i < llength Xs"
   by simp
 
 
 subsection \<open>Supremum\<close>
 
 definition Sup_llist :: "'a set llist \<Rightarrow> 'a set" where
   "Sup_llist Xs = (\<Union>i \<in> {i. enat i < llength Xs}. lnth Xs i)"
 
 lemma lnth_subset_Sup_llist: "enat i < llength Xs \<Longrightarrow> lnth Xs i \<subseteq> Sup_llist Xs"
   unfolding Sup_llist_def by auto
 
 lemma Sup_llist_imp_exists_index: "x \<in> Sup_llist Xs \<Longrightarrow> \<exists>i. enat i < llength Xs \<and> x \<in> lnth Xs i"
   unfolding Sup_llist_def by auto
 
 lemma exists_index_imp_Sup_llist: "enat i < llength Xs \<Longrightarrow> x \<in> lnth Xs i \<Longrightarrow> x \<in> Sup_llist Xs"
   unfolding Sup_llist_def by auto
 
 lemma Sup_llist_LNil[simp]: "Sup_llist LNil = {}"
   unfolding Sup_llist_def by auto
 
 lemma Sup_llist_LCons[simp]: "Sup_llist (LCons X Xs) = X \<union> Sup_llist Xs"
   unfolding Sup_llist_def
 proof (intro subset_antisym subsetI)
   fix x
   assume "x \<in> (\<Union>i \<in> {i. enat i < llength (LCons X Xs)}. lnth (LCons X Xs) i)"
   then obtain i where len: "enat i < llength (LCons X Xs)" and nth: "x \<in> lnth (LCons X Xs) i"
     by blast
   from nth have "x \<in> X \<or> i > 0 \<and> x \<in> lnth Xs (i - 1)"
     by (metis lnth_LCons' neq0_conv)
   then have "x \<in> X \<or> (\<exists>i. enat i < llength Xs \<and> x \<in> lnth Xs i)"
     by (metis len Suc_pred' eSuc_enat iless_Suc_eq less_irrefl llength_LCons not_less order_trans)
   then show "x \<in> X \<union> (\<Union>i \<in> {i. enat i < llength Xs}. lnth Xs i)"
     by blast
 qed ((auto)[], metis i0_lb lnth_0 zero_enat_def, metis Suc_ile_eq lnth_Suc_LCons)
 
 lemma lhd_subset_Sup_llist: "\<not> lnull Xs \<Longrightarrow> lhd Xs \<subseteq> Sup_llist Xs"
   by (cases Xs) simp_all
 
 
 subsection \<open>Supremum up-to\<close>
 
 definition Sup_upto_llist :: "'a set llist \<Rightarrow> enat \<Rightarrow> 'a set" where
   "Sup_upto_llist Xs j = (\<Union>i \<in> {i. enat i < llength Xs \<and> enat i \<le> j}. lnth Xs i)"
 
 lemma Sup_upto_llist_eq_Sup_llist_ltake: "Sup_upto_llist Xs j = Sup_llist (ltake (eSuc j) Xs)"
   unfolding Sup_upto_llist_def Sup_llist_def
-  by (smt Collect_cong Sup.SUP_cong iless_Suc_eq lnth_ltake less_llength_ltake mem_Collect_eq)
+  by (smt (verit) Collect_cong Sup.SUP_cong iless_Suc_eq lnth_ltake less_llength_ltake mem_Collect_eq)
 
 lemma Sup_upto_llist_enat_0[simp]:
   "Sup_upto_llist Xs (enat 0) = (if lnull Xs then {} else lhd Xs)"
 proof (cases "lnull Xs")
   case True
   then show ?thesis
     unfolding Sup_upto_llist_def by auto
 next
   case False
   show ?thesis
     unfolding Sup_upto_llist_def image_def by (simp add: lhd_conv_lnth enat_0 enat_0_iff)
 qed
 
 lemma Sup_upto_llist_Suc[simp]:
   "Sup_upto_llist Xs (enat (Suc j)) =
    Sup_upto_llist Xs (enat j) \<union> (if enat (Suc j) < llength Xs then lnth Xs (Suc j) else {})"
   unfolding Sup_upto_llist_def image_def by (auto intro: le_SucI elim: le_SucE)
 
 lemma Sup_upto_llist_infinity[simp]: "Sup_upto_llist Xs \<infinity> = Sup_llist Xs"
   unfolding Sup_upto_llist_def Sup_llist_def by simp
 
 lemma Sup_upto_llist_0[simp]: "Sup_upto_llist Xs 0 = (if lnull Xs then {} else lhd Xs)"
   unfolding zero_enat_def by (rule Sup_upto_llist_enat_0)
 
 lemma Sup_upto_llist_eSuc[simp]:
   "Sup_upto_llist Xs (eSuc j) =
    (case j of
       enat k \<Rightarrow> Sup_upto_llist Xs (enat (Suc k))
     | \<infinity> \<Rightarrow> Sup_llist Xs)"
   by (auto simp: eSuc_enat split: enat.split)
 
 lemma Sup_upto_llist_mono[simp]: "j \<le> k \<Longrightarrow> Sup_upto_llist Xs j \<subseteq> Sup_upto_llist Xs k"
   unfolding Sup_upto_llist_def by auto
 
 lemma Sup_upto_llist_subset_Sup_llist: "Sup_upto_llist Xs j \<subseteq> Sup_llist Xs"
   unfolding Sup_llist_def Sup_upto_llist_def by auto
 
 lemma elem_Sup_llist_imp_Sup_upto_llist:
   "x \<in> Sup_llist Xs \<Longrightarrow> \<exists>j < llength Xs. x \<in> Sup_upto_llist Xs (enat j)"
   unfolding Sup_llist_def Sup_upto_llist_def by blast
 
 lemma lnth_subset_Sup_upto_llist: "j < llength Xs \<Longrightarrow> lnth Xs j \<subseteq> Sup_upto_llist Xs j"
   unfolding Sup_upto_llist_def by auto
 
 lemma finite_Sup_llist_imp_Sup_upto_llist:
   assumes "finite X" and "X \<subseteq> Sup_llist Xs"
   shows "\<exists>k. X \<subseteq> Sup_upto_llist Xs (enat k)"
   using assms
 proof induct
   case (insert x X)
   then have x: "x \<in> Sup_llist Xs" and X: "X \<subseteq> Sup_llist Xs"
     by simp+
   from x obtain k where k: "x \<in> Sup_upto_llist Xs (enat k)"
     using elem_Sup_llist_imp_Sup_upto_llist by fast
   from X obtain k' where k': "X \<subseteq> Sup_upto_llist Xs (enat k')"
     using insert.hyps(3) by fast
   have "insert x X \<subseteq> Sup_upto_llist Xs (max k k')"
     using k k' by (metis (mono_tags) Sup_upto_llist_mono enat_ord_simps(1) insert_subset
       max.cobounded1 max.cobounded2 subset_iff)
   then show ?case
     by fast
 qed simp
 
 
 subsection \<open>Liminf\<close>
 
 definition Liminf_llist :: "'a set llist \<Rightarrow> 'a set" where
   "Liminf_llist Xs =
    (\<Union>i \<in> {i. enat i < llength Xs}. \<Inter>j \<in> {j. i \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
 
 lemma Liminf_llist_LNil[simp]: "Liminf_llist LNil = {}"
   unfolding Liminf_llist_def by simp
 
 lemma Liminf_llist_LCons:
   "Liminf_llist (LCons X Xs) = (if lnull Xs then X else Liminf_llist Xs)" (is "?lhs = ?rhs")
 proof (cases "lnull Xs")
   case nnull: False
   show ?thesis
   proof
     {
       fix x
       assume "\<exists>i. enat i \<le> llength Xs
         \<and> (\<forall>j. i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow> x \<in> lnth (LCons X Xs) j)"
       then have "\<exists>i. enat (Suc i) \<le> llength Xs
         \<and> (\<forall>j. Suc i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow> x \<in> lnth (LCons X Xs) j)"
         by (cases "llength Xs",
             metis not_lnull_conv[THEN iffD1, OF nnull] Suc_le_D eSuc_enat eSuc_ile_mono
               llength_LCons not_less_eq_eq zero_enat_def zero_le,
             metis Suc_leD enat_ord_code(3))
       then have "\<exists>i. enat i < llength Xs \<and> (\<forall>j. i \<le> j \<and> enat j < llength Xs \<longrightarrow> x \<in> lnth Xs j)"
         by (metis Suc_ile_eq Suc_n_not_le_n lift_Suc_mono_le lnth_Suc_LCons nat_le_linear)
     }
     then show "?lhs \<subseteq> ?rhs"
       by (simp add: Liminf_llist_def nnull) (rule subsetI, simp)
 
     {
       fix x
       assume "\<exists>i. enat i < llength Xs \<and> (\<forall>j. i \<le> j \<and> enat j < llength Xs \<longrightarrow> x \<in> lnth Xs j)"
       then obtain i where
         i: "enat i < llength Xs" and
         j: "\<forall>j. i \<le> j \<and> enat j < llength Xs \<longrightarrow> x \<in> lnth Xs j"
         by blast
 
       have "enat (Suc i) \<le> llength Xs"
         using i by (simp add: Suc_ile_eq)
       moreover have "\<forall>j. Suc i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow> x \<in> lnth (LCons X Xs) j"
         using Suc_ile_eq Suc_le_D j by force
       ultimately have "\<exists>i. enat i \<le> llength Xs \<and> (\<forall>j. i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow>
         x \<in> lnth (LCons X Xs) j)"
         by blast
     }
     then show "?rhs \<subseteq> ?lhs"
       by (simp add: Liminf_llist_def nnull) (rule subsetI, simp)
   qed
 qed (simp add: Liminf_llist_def enat_0_iff(1))
 
 lemma lfinite_Liminf_llist: "lfinite Xs \<Longrightarrow> Liminf_llist Xs = (if lnull Xs then {} else llast Xs)"
 proof (induction rule: lfinite_induct)
   case (LCons xs)
   then obtain y ys where
     xs: "xs = LCons y ys"
     by (meson not_lnull_conv)
   show ?case
     unfolding xs by (simp add: Liminf_llist_LCons LCons.IH[unfolded xs, simplified] llast_LCons)
 qed (simp add: Liminf_llist_def)
 
 lemma Liminf_llist_ltl: "\<not> lnull (ltl Xs) \<Longrightarrow> Liminf_llist Xs = Liminf_llist (ltl Xs)"
   by (metis Liminf_llist_LCons lhd_LCons_ltl lnull_ltlI)
 
 lemma Liminf_llist_subset_Sup_llist: "Liminf_llist Xs \<subseteq> Sup_llist Xs"
   unfolding Liminf_llist_def Sup_llist_def by fast
 
 lemma image_Liminf_llist_subset: "f ` Liminf_llist Ns \<subseteq> Liminf_llist (lmap ((`) f) Ns)"
   unfolding Liminf_llist_def by auto
 
 lemma Liminf_llist_imp_exists_index:
   "x \<in> Liminf_llist Xs \<Longrightarrow> \<exists>i. enat i < llength Xs \<and> x \<in> lnth Xs i"
   unfolding Liminf_llist_def by auto
 
 lemma not_Liminf_llist_imp_exists_index:
   "\<not> lnull Xs \<Longrightarrow> x \<notin> Liminf_llist Xs \<Longrightarrow> enat i < llength Xs \<Longrightarrow>
    (\<exists>j. i \<le> j \<and> enat j < llength Xs \<and> x \<notin> lnth Xs j)"
   unfolding Liminf_llist_def by auto
 
 lemma finite_subset_Liminf_llist_imp_exists_index:
   assumes
     nnil: "\<not> lnull Xs" and
     fin: "finite X" and
     in_lim: "X \<subseteq> Liminf_llist Xs"
   shows "\<exists>i. enat i < llength Xs \<and> X \<subseteq> (\<Inter>j \<in> {j. i \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
 proof -
   show ?thesis
   proof (cases "X = {}")
     case True
     then show ?thesis
       using nnil by (auto intro: exI[of _ 0] simp: zero_enat_def[symmetric])
   next
     case nemp: False
 
     have in_lim':
       "\<forall>x \<in> X. \<exists>i. enat i < llength Xs \<and> x \<in> (\<Inter>j \<in> {j. i \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
       using in_lim[unfolded Liminf_llist_def] in_mono by fastforce
     obtain i_of where
       i_of_lt: "\<forall>x \<in> X. enat (i_of x) < llength Xs" and
       in_inter: "\<forall>x \<in> X. x \<in> (\<Inter>j \<in> {j. i_of x \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
       using bchoice[OF in_lim'] by blast
 
     define i_max where
       "i_max = Max (i_of ` X)"
 
     have "i_max \<in> i_of ` X"
       by (simp add: fin i_max_def nemp)
     then obtain x_max where
       x_max_in: "x_max \<in> X" and
       i_max_is: "i_max = i_of x_max"
       unfolding i_max_def by blast
     have le_i_max: "\<forall>x \<in> X. i_of x \<le> i_max"
       unfolding i_max_def by (simp add: fin)
     have "enat i_max < llength Xs"
       using i_of_lt x_max_in i_max_is by auto
     moreover have "X \<subseteq> (\<Inter>j \<in> {j. i_max \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
     proof
       fix x
       assume x_in: "x \<in> X"
       then have x_in_inter: "x \<in> (\<Inter>j \<in> {j. i_of x \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
         using in_inter by auto
       moreover have "{j. i_max \<le> j \<and> enat j < llength Xs}
         \<subseteq> {j. i_of x \<le> j \<and> enat j < llength Xs}"
         using x_in le_i_max by auto
       ultimately show "x \<in> (\<Inter>j \<in> {j. i_max \<le> j \<and> enat j < llength Xs}. lnth Xs j)"
         by auto
     qed
     ultimately show ?thesis
       by auto
   qed
 qed
 
 lemma Liminf_llist_lmap_image:
   assumes f_inj: "inj_on f (Sup_llist (lmap g xs))"
   shows "Liminf_llist (lmap (\<lambda>x. f ` g x) xs) = f ` Liminf_llist (lmap g xs)" (is "?lhs = ?rhs")
 proof
   show "?lhs \<subseteq> ?rhs"
   proof
     fix x
     assume "x \<in> Liminf_llist (lmap (\<lambda>x. f ` g x) xs)"
     then obtain i where
       i_lt: "enat i < llength xs" and
       x_in_fgj: "\<forall>j. i \<le> j \<longrightarrow> enat j < llength xs \<longrightarrow> x \<in> f ` g (lnth xs j)"
       unfolding Liminf_llist_def by auto
 
     have ex_in_gi: "\<exists>y. y \<in> g (lnth xs i) \<and> x = f y"
       using f_inj i_lt x_in_fgj unfolding inj_on_def Sup_llist_def by auto
     have "\<exists>y. \<forall>j. i \<le> j \<longrightarrow> enat j < llength xs \<longrightarrow> y \<in> g (lnth xs j) \<and> x = f y"
       apply (rule exI[of _ "SOME y. y \<in> g (lnth xs i) \<and> x = f y"])
       using someI_ex[OF ex_in_gi] x_in_fgj f_inj i_lt x_in_fgj unfolding inj_on_def Sup_llist_def
       by simp (metis (no_types, lifting) imageE)
     then show "x \<in> f ` Liminf_llist (lmap g xs)"
       using i_lt unfolding Liminf_llist_def by auto
   qed
 next
   show "?rhs \<subseteq> ?lhs"
     using image_Liminf_llist_subset[of f "lmap g xs", unfolded llist.map_comp] by auto
 qed
 
 lemma Liminf_llist_lmap_union:
   assumes "\<forall>x \<in> lset xs. \<forall>Y \<in> lset xs. g x \<inter> h Y = {}"
   shows "Liminf_llist (lmap (\<lambda>x. g x \<union> h x) xs) =
     Liminf_llist (lmap g xs) \<union> Liminf_llist (lmap h xs)" (is "?lhs = ?rhs")
 proof (intro equalityI subsetI)
   fix x
   assume x_in: "x \<in> ?lhs"
   then obtain i where
     i_lt: "enat i < llength xs" and
     j: "\<forall>j. i \<le> j \<and> enat j < llength xs \<longrightarrow> x \<in> g (lnth xs j) \<or> x \<in> h (lnth xs j)"
     using x_in[unfolded Liminf_llist_def, simplified] by blast
 
   then have "(\<exists>i'. enat i' < llength xs \<and> (\<forall>j. i' \<le> j \<and> enat j < llength xs \<longrightarrow> x \<in> g (lnth xs j)))
      \<or> (\<exists>i'. enat i' < llength xs \<and> (\<forall>j. i' \<le> j \<and> enat j < llength xs \<longrightarrow> x \<in> h (lnth xs j)))"
     using assms[unfolded disjoint_iff_not_equal] by (metis in_lset_conv_lnth)
   then show "x \<in> ?rhs"
     unfolding Liminf_llist_def by simp
 next
   fix x
   show "x \<in> ?rhs \<Longrightarrow> x \<in> ?lhs"
     using assms unfolding Liminf_llist_def by auto
 qed
 
 lemma Liminf_set_filter_commute:
   "Liminf_llist (lmap (\<lambda>X. {x \<in> X. p x}) Xs) = {x \<in> Liminf_llist Xs. p x}"
   unfolding Liminf_llist_def by force
 
 
 subsection \<open>Liminf up-to\<close>
 
 definition Liminf_upto_llist :: "'a set llist \<Rightarrow> enat \<Rightarrow> 'a set" where
   "Liminf_upto_llist Xs k =
    (\<Union>i \<in> {i. enat i < llength Xs \<and> enat i \<le> k}.
       \<Inter>j \<in> {j. i \<le> j \<and> enat j < llength Xs \<and> enat j \<le> k}. lnth Xs j)"
 
 lemma Liminf_upto_llist_eq_Liminf_llist_ltake:
   "Liminf_upto_llist Xs j = Liminf_llist (ltake (eSuc j) Xs)"
   unfolding Liminf_upto_llist_def Liminf_llist_def
   by (smt Collect_cong Sup.SUP_cong iless_Suc_eq lnth_ltake less_llength_ltake mem_Collect_eq)
 
 lemma Liminf_upto_llist_enat[simp]:
   "Liminf_upto_llist Xs (enat k) =
    (if enat k < llength Xs then lnth Xs k else if lnull Xs then {} else llast Xs)"
 proof (cases "enat k < llength Xs")
   case True
   then show ?thesis
     unfolding Liminf_upto_llist_def by force
 next
   case k_ge: False
   show ?thesis
 proof (cases "lnull Xs")
   case nil: True
   then show ?thesis
     unfolding Liminf_upto_llist_def by simp
 next
   case nnil: False
   then obtain j where
     j: "eSuc (enat j) = llength Xs"
     using k_ge by (metis eSuc_enat_iff enat_ile le_less_linear lhd_LCons_ltl llength_LCons)
 
   have fin: "lfinite Xs"
     using k_ge not_lfinite_llength by fastforce
   have le_k: "enat i < llength Xs \<and> i \<le> k \<longleftrightarrow> enat i < llength Xs" for i
     using k_ge linear order_le_less_subst2 by fastforce
   have "Liminf_upto_llist Xs (enat k) = llast Xs"
     using j nnil lfinite_Liminf_llist[OF fin] nnil
     unfolding Liminf_upto_llist_def Liminf_llist_def using llast_conv_lnth[OF j[symmetric]]
     by (simp add: le_k)
   then show ?thesis
     using k_ge nnil by simp
   qed
 qed
 
 lemma Liminf_upto_llist_infinity[simp]: "Liminf_upto_llist Xs \<infinity> = Liminf_llist Xs"
   unfolding Liminf_upto_llist_def Liminf_llist_def by simp
 
 lemma Liminf_upto_llist_0[simp]:
   "Liminf_upto_llist Xs 0 = (if lnull Xs then {} else lhd Xs)"
   unfolding Liminf_upto_llist_def image_def
   by (simp add: enat_0[symmetric]) (simp add: enat_0 lnth_0_conv_lhd)
 
 lemma Liminf_upto_llist_eSuc[simp]:
   "Liminf_upto_llist Xs (eSuc j) =
    (case j of
       enat k \<Rightarrow> Liminf_upto_llist Xs (enat (Suc k))
     | \<infinity> \<Rightarrow> Liminf_llist Xs)"
   by (auto simp: eSuc_enat split: enat.split)
 
 lemma elem_Liminf_llist_imp_Liminf_upto_llist:
   "x \<in> Liminf_llist Xs \<Longrightarrow>
    \<exists>i < llength Xs. \<forall>j. i \<le> j \<and> j < llength Xs \<longrightarrow> x \<in> Liminf_upto_llist Xs (enat j)"
   unfolding Liminf_llist_def Liminf_upto_llist_def using enat_ord_simps(1) by force
 
 end
diff --git a/thys/Relational-Incorrectness-Logic/ROOT b/thys/Relational-Incorrectness-Logic/ROOT
--- a/thys/Relational-Incorrectness-Logic/ROOT
+++ b/thys/Relational-Incorrectness-Logic/ROOT
@@ -1,10 +1,9 @@
 chapter AFP
 
 session "Relational-Incorrectness-Logic" = "HOL-IMP" +
   options [timeout = 600]
   theories
-      RelationalIncorrectness
-
+    RelationalIncorrectness
   document_files
-      "root.bib"
-      "root.tex"
+    "root.bib"
+    "root.tex"
diff --git a/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy b/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy
--- a/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy
+++ b/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy
@@ -1,834 +1,834 @@
 theory RelationalIncorrectness
   imports "HOL-IMP.Big_Step"
 begin
 
 (* Author: Toby Murray *)
 
 section "Under-Approximate Relational Judgement"
 
 text \<open>
   This is the relational analogue of OHearn's~\<^cite>\<open>"OHearn_19"\<close> and de Vries \& Koutavas'~\<^cite>\<open>"deVries_Koutavas_11"\<close>
   judgements.
 
   Note that in our case it doesn't really make sense to talk about ``erroneous'' states: the
   presence of an error can be seen only by the violation of a relation. Unlike O'Hearn, we cannot
   encode it directly into the semantics of our programs, without giving them a relational semantics.
   We use the standard big step semantics of IMP unchanged.
 \<close>
 
 type_synonym rassn = "state \<Rightarrow> state \<Rightarrow> bool"
 
 definition 
   ir_valid :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
   where
   "ir_valid P c c' Q \<equiv> (\<forall> t t'. Q t t' \<longrightarrow> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"
 
 
 section "Rules of the Logic"
 
 definition
   flip :: "rassn \<Rightarrow> rassn"
   where
   "flip P \<equiv> \<lambda>s s'. P s' s"
 
 
 inductive
   ir_hoare :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
   where
   ir_Skip: "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c',s') \<Rightarrow> t') \<Longrightarrow>
             ir_hoare P SKIP c' Q" |
   ir_If_True:   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) c\<^sub>1 c' Q \<Longrightarrow> 
                  ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
   ir_If_False:   "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) c\<^sub>2 c' Q \<Longrightarrow> 
                   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
   ir_Seq1: "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d SKIP R \<Longrightarrow> ir_hoare P (Seq c d) c' R" |
   ir_Assign: "ir_hoare (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow>
               ir_hoare P (Assign x e) c' Q" |
   ir_While_False: "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                   ir_hoare P (WHILE b DO c) c' Q" |
   ir_While_True: "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) (c;; WHILE b DO c) c' Q \<Longrightarrow>
                   ir_hoare P (WHILE b DO c) c' Q" |
   ir_While_backwards_frontier: "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                                 ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
                                 ir_hoare (P 0) (WHILE b DO c) c' Q" |
   ir_conseq:      "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                    ir_hoare P' c c' Q'" |
   ir_disj:        "ir_hoare P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_hoare P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                    ir_hoare (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')" |
   ir_sym: "ir_hoare (flip P) c c' (flip Q) \<Longrightarrow> ir_hoare P c' c Q"
 
 section "Simple Derived Rules"
 
 lemma meh_simp[simp]: "(SKIP, s') \<Rightarrow> t' = (s' = t')"
   by auto
 
 
 lemma ir_pre: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s')  \<Longrightarrow>
                   ir_hoare P' c c' Q"
   by(erule ir_conseq, blast+)
 
 lemma ir_post: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s')  \<Longrightarrow>
                   ir_hoare P c c' Q'"
   by(erule ir_conseq, blast+)
 
 section "Soundness"
 
 lemma Skip_ir_valid[intro]:
   "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c', s') \<Rightarrow> t') \<Longrightarrow> ir_valid P SKIP c' Q"
   by(auto simp: ir_valid_def)
 
 lemma sym_ir_valid[intro]:
   "ir_valid (flip P) c' c (flip Q) \<Longrightarrow> ir_valid P c c' Q"
   by(fastforce simp: ir_valid_def flip_def)
 
 lemma If_True_ir_valid[intro]:
   "ir_valid (\<lambda>a c. P a c \<and> bval b a) c\<^sub>1 c' Q \<Longrightarrow>
    ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
   by(fastforce simp: ir_valid_def)
 
 lemma If_False_ir_valid[intro]:
   "ir_valid (\<lambda>a c. P a c \<and> \<not> bval b a) c\<^sub>2 c' Q \<Longrightarrow>
    ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
   by(fastforce simp: ir_valid_def)
 
 lemma Seq1_ir_valid[intro]:
   "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d SKIP R \<Longrightarrow> ir_valid P (c;; d) c' R"
   by(fastforce simp: ir_valid_def)
 
 lemma Seq2_ir_valid[intro]:
   "ir_valid P c SKIP Q \<Longrightarrow> ir_valid Q d c' R \<Longrightarrow> ir_valid P (c;; d) c' R"
   by(fastforce simp: ir_valid_def)
 
 lemma Seq_ir_valid[intro]:
   "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d d' R \<Longrightarrow> ir_valid P (c;; d) (c';; d') R"
   by(fastforce simp: ir_valid_def)
 
 lemma Assign_blah[intro]:
   "t x = aval e (t(x := v))
        \<Longrightarrow> (x ::= e, t(x := v)) \<Rightarrow> t"
   using Assign 
   by (metis fun_upd_triv fun_upd_upd)
 
 lemma Assign_ir_valid[intro]:
   "ir_valid (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow> ir_valid P (Assign x e) c' Q"
   by(fastforce simp: ir_valid_def)
 
 lemma While_False_ir_valid[intro]:
   "ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
    ir_valid P (WHILE b DO c) c' Q"
   by(fastforce simp: ir_valid_def)
 
 lemma While_True_ir_valid[intro]:
   "ir_valid (\<lambda>s s'. P s s' \<and> bval b s) (Seq c (WHILE b DO c)) c' Q \<Longrightarrow>
    ir_valid P (WHILE b DO c) c' Q"
   by(clarsimp simp: ir_valid_def, blast)
 
 
 lemma While_backwards_frontier_ir_valid':
   assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                     (\<exists>s. P (k + n) s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t)"
   assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
   assumes post: "Q t t'"
   shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t'"
 proof -
   from post last obtain s s' n where 
     "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(c', s') \<Rightarrow> t'"
     by blast
   with asm  show ?thesis
   proof(induction n arbitrary: k t t')
     case 0 
     then show ?case 
       by (metis WhileFalse WhileTrue add.right_neutral)
   next
     case (Suc n)
     from Suc
     obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(c', r') \<Rightarrow> t'"
       by (metis add_Suc_shift)
     from final_iteration(1) obtain q q' where
      "P k q r' \<and> bval b q \<and>  (c, q) \<Rightarrow> r" 
       by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
     with final_iteration show ?case by blast
   qed
 qed
 
 
 lemma While_backwards_frontier_ir_valid[intro]:
   "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
    ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
    ir_valid (P 0) (WHILE b DO c) c' Q"
   by(auto simp: meh_simp ir_valid_def intro: While_backwards_frontier_ir_valid')
 
 lemma conseq_ir_valid:
   "ir_valid P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                   ir_valid P' c c' Q'"
   by(clarsimp simp: ir_valid_def, blast)
 
 lemma disj_ir_valid[intro]:
   "ir_valid P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_valid P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                   ir_valid (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
   by(fastforce simp: ir_valid_def)
 
 
 theorem soundness:
   "ir_hoare P c c' Q \<Longrightarrow> ir_valid P c c' Q"
   apply(induction rule: ir_hoare.induct)
               apply(blast intro!: Skip_ir_valid)
   by (blast intro: conseq_ir_valid)+
 
 section "Completeness"
 
 lemma ir_Skip_Skip[intro]:
   "ir_hoare P SKIP SKIP P"
   by(rule ir_Skip, simp)
 
 lemma ir_hoare_Skip_Skip[simp]:
   "ir_hoare P SKIP SKIP Q = (\<forall>s s'. Q s s' \<longrightarrow> P s s')"
   using soundness ir_valid_def meh_simp ir_conseq ir_Skip by metis
 
 lemma ir_valid_Seq1:
   "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t'))"
   by(auto simp: ir_valid_def)
 
 lemma ir_valid_Seq1':
   "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t')) c2 SKIP Q"
   by(clarsimp simp: ir_valid_def, meson SeqE)
 
 lemma ir_valid_track_history:
   "ir_valid P c c' Q \<Longrightarrow>
    ir_valid P c c' (\<lambda>t t'. Q s s' \<and> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"
   by(auto simp: ir_valid_def)
 
 lemma ir_valid_If:
   "ir_valid (\<lambda>s s'. P s s') (IF b THEN c1 ELSE c2) c' Q \<Longrightarrow>
    ir_valid (\<lambda>s s'. P s s' \<and> bval b s) c1 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> bval b s)) \<and>
    ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) c2 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> \<not> bval b s))"
   by(clarsimp simp: ir_valid_def, blast)
 
 text \<open>
   Inspired by the 
   ``@{text "p(n) = {\<sigma> | you can get back from \<sigma> to some state in p by executing C backwards n times}"}''
   part of OHearn~\<^cite>\<open>"OHearn_19"\<close>.
 \<close>
 primrec get_back where
   "get_back P b c 0 = (\<lambda>t t'. P t t')" |
   "get_back P b c (Suc n) = (\<lambda>t t'. \<exists>s. (c,s) \<Rightarrow> t \<and> bval b s \<and> get_back P b c n s t')"
 
 (* Currently not used anywhere *)
 lemma ir_valid_get_back:
   "ir_valid (get_back P b c (Suc k)) (WHILE b DO c) c' Q \<Longrightarrow>
    ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
 proof(induct k)
   case 0
   then show ?case by(clarsimp simp: ir_valid_def, blast)
 next
   case (Suc k)
-  then show ?case  using  WhileTrue get_back.simps(2) ir_valid_def by smt 
+  then show ?case  using  WhileTrue get_back.simps(2) ir_valid_def by (smt (verit))
 qed
 
 (* both this an the next one get used in the completeness proof *)
 lemma ir_valid_While1:
   "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
    (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c SKIP (\<lambda>t t'. get_back P b c (Suc k) t t' \<and> (\<exists>u u'. (WHILE b DO c,t) \<Rightarrow> u \<and> (c',t') \<Rightarrow> u' \<and> Q u u')))"
 proof (subst ir_valid_def, clarsimp)
   fix t t' s u u'
   assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q" 
          "(WHILE b DO c, t) \<Rightarrow> u"
          "(c, s) \<Rightarrow> t" 
          "(c', t') \<Rightarrow> u'"
          "Q u u'"
          "bval b s"
          "get_back P b c k s t'"
   thus "\<exists>s. get_back P b c k s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t"
   proof(induction k arbitrary: t t' s u u')
     case 0
     then show ?case 
       by auto
   next
     case (Suc k)
     show ?case
       using Suc.prems(3) Suc.prems(6) Suc.prems(7) by blast
   qed
 qed
 
 lemma ir_valid_While3:
   "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
    (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c c' (\<lambda>t t'. (\<exists>s'. (c',s') \<Rightarrow> t' \<and> get_back P b c (Suc k) t s' \<and> (\<exists>u. (WHILE b DO c,t) \<Rightarrow> u \<and>  Q u t'))))"
   apply(subst ir_valid_def, clarsimp)
 proof -
   fix t t' s' s u
   assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q" 
          "(WHILE b DO c, t) \<Rightarrow> u"
          "(c, s) \<Rightarrow> t" 
          "(c', s') \<Rightarrow> t'"
          "Q u t'"
          "bval b s"
          "get_back P b c k s s'"
   thus "\<exists>s s'. get_back P b c k s s' \<and> bval b s \<and> (c, s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
   proof(induction k arbitrary: t t' s' s u)
     case 0
     then show ?case 
       by auto
   next
     case (Suc k)
     show ?case
       using Suc.prems(3) Suc.prems(4) Suc.prems(6) Suc.prems(7) by blast
   qed
 qed
 
 (* not used anywhere *)
 lemma ir_valid_While2:
    "ir_valid P (WHILE b DO c) c' Q \<Longrightarrow>
    ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' (\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c',s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval b t))"  
   by(clarsimp simp: ir_valid_def, blast)
 
 lemma assign_upd_blah:
   "(\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) = s"
   by(rule ext, auto)
 
 lemma Assign_complete:
   assumes v: "ir_valid P (x1 ::= x2) c' Q"
   assumes q: "Q t t'"
   shows  "\<exists>s'. (\<exists>v. P (t(x1 := v)) s' \<and> t x1 = aval x2 (t(x1 := v))) \<and> (c', s') \<Rightarrow> t'"
 proof -
   from v and q obtain s s' where a: "P s s' \<and> (x1 ::= x2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
-    using ir_valid_def by smt
+    using ir_valid_def by (smt (verit))
   hence "P (\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) s' \<and> aval x2 s = aval x2 (s(x1 := s x1))"
     using assign_upd_blah 
     by simp
   thus ?thesis 
     using assign_upd_blah a 
     by (metis AssignE fun_upd_same fun_upd_triv fun_upd_upd)
 qed
 
 lemmas ir_Skip_sym = ir_sym[OF ir_Skip, simplified flip_def]
 
 theorem completeness:
   "ir_valid P c c' Q \<Longrightarrow> ir_hoare P c c' Q"
 proof(induct c arbitrary: P c' Q)
 case SKIP
   show ?case 
     apply(rule ir_Skip)
     using SKIP by(fastforce simp: ir_valid_def)
 next
   case (Assign x1 x2)
   show ?case
     apply(rule ir_Assign)
     apply(rule ir_Skip)
     using Assign_complete Assign by blast
 next
   case (Seq c1 c2)
   have a: "ir_hoare P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> (\<exists>u. (c2, t) \<Rightarrow> u \<and> Q u t'))"
     using ir_valid_Seq1 Seq by blast
   show ?case 
     apply(rule ir_Seq1)
      apply (blast intro: a)
     apply(rule ir_Skip_sym)
     by(metis SeqE ir_valid_def Seq)
 next
   case (If x1 c1 c2)
   have t: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c1 c'
       (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> bval x1 s))" and
        f: " ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval x1 s) c2 c'
       (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> \<not> bval x1 s))"
     using ir_valid_If If by blast+
   show ?case 
     (* consider both cases of the if via conseq, disj, then _True and _False *)
     apply(rule ir_conseq)
       apply(rule ir_disj)
        apply(rule ir_If_True,fastforce intro: t)
       apply(rule ir_If_False, fastforce intro: f)    
      apply blast
-    by (smt IfE ir_valid_def If)
+    by (smt (verit) IfE ir_valid_def If)
 next
   case (While x1 c)
   have a: "\<And>n. ir_hoare (\<lambda>s s'. get_back P x1 c n s s' \<and> bval x1 s) c SKIP (get_back P x1 c (Suc n))"
-    using ir_valid_While1  While
-    by (smt get_back.simps(2) ir_valid_def meh_simp)
+    using ir_valid_While1 While
+    by (smt (verit, ccfv_threshold) get_back.simps(2) ir_Skip_sym)
   have b: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c c'
                     (\<lambda>t t'.  \<exists>s'. (c', s') \<Rightarrow> t' \<and> (\<exists>s. (c, s) \<Rightarrow> t \<and> bval x1 s \<and> P s s') \<and> 
                     (\<exists>u. (WHILE x1 DO c, t) \<Rightarrow> u \<and> Q u t'))"
     using ir_valid_While3[where k=0,simplified] While by blast
   have gb: "\<And>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t) \<Longrightarrow>
                     \<exists>s'. ((\<exists>n. get_back P x1 c n t s') \<and> \<not> bval x1 t) \<and> (c', s') \<Rightarrow> t'"
     by (meson get_back.simps(1))
   
   show ?case 
     (* use the frontier rule much as in OHearn POPL *)
     apply(rule ir_conseq)
       apply(rule_tac P="get_back P x1 c" in ir_While_backwards_frontier)
        apply(blast intro: a)
       (* consider both cases of the While via conseq, disj, then _True and _False *)
       apply(rule ir_conseq)
         apply(rule ir_disj)
          apply(rule_tac P="\<lambda>s s'. \<exists>n. get_back P x1 c n s s'" and Q="(\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t))" in ir_While_False)
          apply(rule ir_Skip, blast intro: gb)
         apply(rule ir_While_True)
         apply(rule ir_Seq1[OF b])
         apply(rule ir_Skip_sym)
         apply(fastforce)
        apply (metis get_back.simps(1))
       apply assumption
      apply simp
     by (metis While.prems WhileE ir_valid_def)
 qed
 
 
 
 
 section "A Decomposition Principle: Proofs via Under-Approximate Hoare Logic"
 
 text \<open>
   We show the under-approximate analogue holds for Beringer's~\<^cite>\<open>"Beringer_11"\<close> decomposition
   principle for over-approximate relational logic.
 \<close>
 
 
 definition
   decomp :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> rassn" where
   "decomp P c c' Q \<equiv> \<lambda>t s'. \<exists>s t'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> Q t t'"
 
 
 lemma ir_valid_decomp1:
   "ir_valid P c c' Q \<Longrightarrow> ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q"
   by(fastforce simp: ir_valid_def meh_simp decomp_def)
 
 lemma ir_valid_decomp2:
   "ir_valid P c SKIP R \<and> ir_valid R SKIP c' Q \<Longrightarrow> ir_valid P c c' Q"
   by(fastforce simp: ir_valid_def meh_simp decomp_def)
 
 lemma ir_valid_decomp:
   "ir_valid P c c' Q = (ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q)"
   using ir_valid_decomp1 ir_valid_decomp2 by blast
 
 text \<open>
   Completeness with soundness means we can prove proof rules about @{term ir_hoare} in terms
   of @{term ir_valid}.
 \<close>
 
 lemma ir_to_Skip:     
   "ir_hoare P c c' Q = (ir_hoare P c SKIP (decomp P c c' Q) \<and> ir_hoare (decomp P c c' Q) SKIP c' Q)"
   using soundness completeness ir_valid_decomp 
   by meson
 
 text \<open>
   O'Hearn's under-approximate Hoare triple, for the ``ok'' case (since that is the only case we have)
   This is also likely the same as from the "Reverse Hoare Logic" paper (SEFM).
 \<close>
 type_synonym assn = "state \<Rightarrow> bool"
 definition
   ohearn :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
   where
   "ohearn P c Q \<equiv> (\<forall>t. Q t \<longrightarrow> (\<exists>s. P s \<and> (c,s) \<Rightarrow> t))"
 
 lemma fold_ohearn1:
   "ir_valid P c SKIP Q = (\<forall>t'. ohearn (\<lambda>t. P t t') c (\<lambda>t. Q t t'))"
   by(fastforce simp add: ir_valid_def ohearn_def)
 
 lemma fold_ohearn2:
   "ir_valid P SKIP c' Q = (\<forall>t. ohearn (P t) c' (Q t))"
   by(simp add: ir_valid_def ohearn_def)
 
 theorem relational_via_hoare:
   "ir_hoare P c c' Q = ((\<forall>t'. ohearn (\<lambda>t. P t t') c (\<lambda>t. decomp P c c' Q t t')) \<and> (\<forall>t. ohearn (decomp P c c' Q t) c' (Q t)))"
 proof -
   have a: "\<And>P c c' Q. ir_hoare P c c' Q = ir_valid P c c' Q"
     using soundness completeness by auto
   show ?thesis
     using ir_to_Skip a fold_ohearn1 fold_ohearn2 by metis
 qed
 
 section "Deriving Proof Rules from Completeness"
 
 text \<open>
   Note that we can more easily derive proof rules sometimes by appealing to the
    corresponding properties of @{term ir_valid} than from the proof rules directly.
 
   We see more examples of this later on when we consider examples.
 \<close>
 
 lemma ir_Seq2: 
   "ir_hoare P c SKIP Q \<Longrightarrow> ir_hoare Q d c' R \<Longrightarrow> ir_hoare P (Seq c d) c' R"
   using soundness completeness Seq2_ir_valid by metis
 
 lemma ir_Seq: 
   "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d d' R \<Longrightarrow> ir_hoare P (Seq c d) (Seq c' d') R"
   using soundness completeness Seq_ir_valid by metis
 
 section "Examples"
 
 subsection "Some Derived Proof Rules"
 
 text \<open>
 First derive some proof rules -- here not by appealing to completeness but just using
 the existing rules 
 \<close>
 
 lemma ir_If_True_False:   
   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> \<not> bval b' s') c\<^sub>1 c\<^sub>2' Q \<Longrightarrow> 
    ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') Q"
   apply(rule ir_If_True)
   apply(rule ir_sym)
   apply(rule ir_If_False)
   apply(rule ir_sym)
   by(simp add: flip_def)
 
 
 lemma ir_Assign_Assign:
   "ir_hoare P (x ::= e) (x' ::= e') (\<lambda>t t'. \<exists>v v'. P (t(x := v)) (t'(x' := v')) \<and> t x = aval e (t(x := v)) \<and> t' x' = aval e' (t'(x' := v')))"
   apply(rule ir_Assign)
   apply(rule ir_sym)
   apply(rule ir_Assign)
   by(simp add: flip_def, auto)
 
 subsection "prog1"
 
 text \<open>
   A tiny insecure program. Note that we only need to reason on one path through this program to
   detect that it is insecure. 
 \<close>
 
 abbreviation low_eq :: rassn where "low_eq s s' \<equiv> s ''low'' = s' ''low''"
 abbreviation low_neq :: rassn where "low_neq s s' \<equiv> \<not> low_eq s s'"
 definition prog1 :: com where
   "prog1 \<equiv> (IF (Less (N 0) (V ''x'')) THEN (Assign ''low'' (N 1)) ELSE (Assign ''low'' (N 0)))"
 
 text \<open>
   We prove that @{term prog1} is definitely insecure. To do that, we need to find some non-empty
   post-relation that implies insecurity. The following property encodes the idea that the 
   post-relation is non-empty, i.e. represents a feasible pair of execution paths.
 \<close>
 definition
   nontrivial :: "rassn \<Rightarrow> bool"
   where
   "nontrivial Q \<equiv> (\<exists>t t'. Q t t')"
 
 text \<open>
   Note the property we prove here explicitly encodes the fact that the postcondition can be anything
   that implies insecurity, i.e. implies @{term low_neq}. In particular we should not necessarily
   expect it to cover the entirely of all states that satisfy @{term low_neq}. 
 
   Also note that we also have to prove that the postcondition is non-trivial. This is necessary to 
   make sure that the violation we find is not an infeasible path.
 \<close>
 lemma prog1:
   "\<exists>Q. ir_hoare low_eq prog1 prog1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
   apply(rule exI)
   apply(rule conjI)
    apply(simp add: prog1_def)
    apply(rule ir_If_True_False)
    apply(rule ir_Assign_Assign)
   apply(rule conjI)
    apply auto[1]
   apply(clarsimp simp: nontrivial_def)
   apply(rule_tac x="\<lambda>v. 1" in exI)
   apply simp
   apply(rule_tac x="\<lambda>v. 0" in exI)
   by auto
 
 subsection "More Derived Proof Rules for Examples"
 
 definition BEq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
   "BEq a b \<equiv> And (Less a (Plus b (N 1))) (Less b (Plus a (N 1)))"
 
 
 lemma BEq_aval[simp]: 
   "bval (BEq a b) s = ((aval a s) = (aval b s))"
   by(auto simp add: BEq_def)
 
 lemma ir_If_True_True:
   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
    ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t')"
   by(simp add: ir_If_True ir_sym flip_def)
 
 lemma ir_If_False_False:
   "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
    ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>2 t t')"
   by(simp add: ir_If_False ir_sym flip_def)
 
 lemma ir_If':
   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
    ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
    ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
   apply(rule ir_pre)
    apply(rule ir_disj)
     apply(rule ir_If_True_True)
     apply assumption
    apply(rule ir_If_False_False)
    apply assumption
   apply blast
   done
 
 lemma ir_While_triv:
   "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
    ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>2 s s'))"
   by(simp add: ir_While_False ir_sym flip_def)
 
 lemma ir_While':
   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') (c;;WHILE b DO c) (c';;WHILE b' DO c') Q\<^sub>1 \<Longrightarrow>
    ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
    ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>1 s s' \<or> Q\<^sub>2 s s'))"
   apply(rule ir_pre)
    apply(rule ir_disj)
      apply(rule ir_While_True)
      apply(rule ir_sym)
      apply(simp add: flip_def)
      apply(rule ir_While_True)
      apply(rule ir_sym)
     apply(simp add: flip_def)
    apply(rule ir_While_triv)
    apply assumption
   apply simp
   done 
 
 subsection "client0"   
 
 definition low_eq_strong where
   "low_eq_strong s s' \<equiv> (s ''high'' \<noteq> s' ''high'') \<and> low_eq s s'"
 
 lemma low_eq_strong_upd[simp]:
   "var \<noteq> ''high'' \<and> var \<noteq> ''low'' \<Longrightarrow> low_eq_strong(s(var := v)) (s'(var := v')) = low_eq_strong s s'"
   by(auto simp: low_eq_strong_def)
 
 text \<open>
   A variation on client0 from O'Hearn~\<^cite>\<open>"OHearn_19"\<close>: how to reason about loops via a single unfolding
 \<close>
 definition client0 :: com where
   "client0 \<equiv> (Assign ''x'' (N 0);;
               (While (Less (N 0) (V ''n''))
                      ((Assign ''x'' (Plus (V ''x'') (V ''n'')));;
                       (Assign ''n'' (V ''nondet''))));;
               (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"
 
 
 
 lemma client0:
   "\<exists>Q. ir_hoare low_eq client0 client0 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
   apply(rule exI, rule conjI, simp add: client0_def)
    apply(rule_tac P=low_eq_strong in ir_pre)  
    apply(rule ir_Seq)
     apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
      apply clarsimp
 
     apply(rule ir_While')
       apply clarsimp
 
       apply(rule ir_Seq)
        apply(rule ir_Seq)
         apply(rule ir_Assign_Assign)
        apply(rule ir_Assign_Assign)
       apply clarsimp
 
       apply(rule ir_While_triv)
       apply clarsimp
       apply assumption
 
      apply clarsimp
      apply assumption
 
 
     apply(rule ir_If_True_True)
     apply(rule ir_Assign_Assign)
    apply(fastforce simp: low_eq_strong_def)
   apply(rule conjI)
    apply(clarsimp simp: low_eq_strong_def split: if_splits)
 
   (* ugh having to manually do constraint solving here... *)
   apply(clarsimp simp: low_eq_strong_def nontrivial_def)
   apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
   apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
   apply clarsimp
   done
 
 (* Not needed? *)
 lemma ir_While_backwards:
   "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                        ir_hoare (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                        ir_hoare (P 0) (WHILE b DO c) c' Q"
   apply(rule ir_While_backwards_frontier)
    apply assumption
   apply(rule ir_While_False)
   apply auto
   done
 
 subsection "Derive a variant of the backwards variant rule"
 
 text \<open>Here we appeal to completeness again to derive this rule from the corresponding
         property about @{term ir_valid}.\<close>
 
 subsection "A variant of the frontier rule"
 
 text \<open>
   Agin we derive this rule by appealing to completeness and the corresponding property of
   @{term ir_valid}
 \<close>
 
 lemma While_backwards_frontier_both_ir_valid':
   assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                     (\<exists>s s'. P (k + n) s s' \<and> bval b s \<and> bval b' s' \<and> (c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
   assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t')"
   assumes post: "Q t t'"
   shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t'"
 proof -
   from post last obtain s s' n where 
     "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(WHILE b' DO c', s') \<Rightarrow> t'"
     by blast
   with asm  show ?thesis
   proof(induction n arbitrary: k t t')
     case 0 
     then show ?case 
       by (metis WhileFalse WhileTrue add.right_neutral)
   next
     case (Suc n)
     from Suc
     obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(WHILE b' DO c', r') \<Rightarrow> t'"
       by (metis add_Suc_shift)
     from final_iteration(1) obtain q q' where
      "P k q q' \<and> bval b q \<and> bval b' q' \<and> (c, q) \<Rightarrow> r \<and> (c', q') \<Rightarrow> r'" 
       by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
     with final_iteration show ?case by blast
   qed
 qed
 
 lemma While_backwards_frontier_both_ir_valid[intro]:
   "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
    ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q \<Longrightarrow>
    ir_valid (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
   by(auto simp: ir_valid_def intro: While_backwards_frontier_both_ir_valid')
 
 lemma ir_While_backwards_frontier_both:
   "\<lbrakk>\<And>n. ir_hoare (\<lambda>s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n));
    ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q\<rbrakk>
    \<Longrightarrow> ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
   using soundness completeness While_backwards_frontier_both_ir_valid by auto
 
 text \<open>
   The following rule then follows easily as a special case
 \<close>
 lemma ir_While_backwards_both:
   "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
                        ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s \<and> \<not> bval b' s')"
   apply(rule ir_While_backwards_frontier_both)
    apply blast
   by(simp add: ir_While_False ir_sym flip_def)
 
 
 subsection "client1"
 
 
 text \<open>
   An example roughly equivalent to cient1 from O'Hearn~\<^cite>\<open>"OHearn_19"\<close>0 
 
   In particular we use the backwards variant rule to reason about the loop.
 \<close>
 definition client1 :: com where
   "client1 \<equiv> (Assign ''x'' (N 0);;
               (While (Less (V ''x'') (V ''n''))
                      ((Assign ''x'' (Plus (V ''x'') (N 1)))));;
               (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"
 
 
 lemma client1:
   "\<exists>Q. ir_hoare low_eq client1 client1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
   apply(rule exI, rule conjI, simp add: client1_def)
    apply(rule_tac P=low_eq_strong in ir_pre)  
    apply(rule ir_Seq)
     apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
      apply clarsimp
 
   apply(rule ir_pre)
       apply(rule ir_While_backwards_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> int n \<le> s ''n'' \<and> int n \<le> s' ''n''"])
       apply(rule ir_post)
        apply(rule ir_Assign_Assign)
       apply clarsimp
   
      apply clarsimp
 
     apply(rule ir_If_True_True)
     apply(rule ir_Assign_Assign)
    apply(fastforce simp: low_eq_strong_def)
   apply(rule conjI)
    apply(clarsimp simp: low_eq_strong_def split: if_splits)
 
   apply clarsimp
   (* ugh having to manually do constraint solving here... *)
   apply(clarsimp simp: low_eq_strong_def nontrivial_def)
   apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
   apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
   apply clarsimp
   done
 
 
 subsection "client2"
 
 text \<open>
   An example akin to client2 from O'Hearn~\<^cite>\<open>"OHearn_19"\<close>. 
 
   Note that this example is carefully written to show use of the frontier rule first to
   reason up to the broken loop iteration, and then we unfold the loop at that point to
   reason about the broken iteration, and then use the plain backwards variant rule to
   reason over the remainder of the loop.
 \<close>
 definition client2 :: com where
   "client2 \<equiv> (Assign ''x'' (N 0);;
               (While (Less (V ''x'') (N 4000000))
                      ((Assign ''x'' (Plus (V ''x'') (N 1)));;
                        (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))
                        )
               )"
 
 lemma client2:
   "\<exists>Q. ir_hoare low_eq client2 client2 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
   apply(rule exI, rule conjI, simp add: client2_def)
    apply(rule_tac P=low_eq_strong in ir_pre)  
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp
 
   apply(rule ir_pre)
      apply(rule ir_While_backwards_frontier_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> s ''x'' \<ge> 0 \<and> s ''x'' \<le> 2000000 - 1 \<and> s' ''x'' \<ge> 0 \<and> s' ''x'' \<le> 2000000 - 1"])
       apply(rule ir_Seq)
        apply(rule ir_Assign_Assign)
   apply clarsimp
       apply(rule ir_post)
        apply(rule ir_If')
         apply(rule ir_Assign_Assign)
        apply(rule ir_Skip_Skip)
       apply clarsimp
 
      apply clarsimp
      apply(rule ir_While')
       apply clarsimp
       apply(rule ir_Seq)
        apply(rule ir_Seq)
        apply(rule ir_Assign_Assign)
       apply(rule ir_If_True_True)
       apply(rule ir_Assign_Assign)
      apply clarsimp
 
   apply(rule ir_pre)
      apply(rule ir_While_backwards_both[where P="\<lambda>n s s'.  s ''x'' = 2000000 + int n \<and> s' ''x'' = 2000000 + int n \<and> s ''x'' \<ge> 2000000 \<and> s ''x'' \<le> 4000000 \<and> s' ''x'' \<ge> 2000000 \<and> s' ''x'' \<le> 4000000 \<and> s ''low'' = s ''high'' \<and> s' ''low'' = s' ''high'' \<and> s ''high'' \<noteq> s' ''high''"])
 
 
      apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
       apply(rule ir_If_False_False)
        apply fastforce
       apply (fastforce simp: low_eq_strong_def)
      apply fastforce
     apply(fastforce simp: low_eq_strong_def)
    apply(fastforce simp: low_eq_strong_def)
 
   apply(rule conjI)
    apply(clarsimp simp: low_eq_strong_def split: if_splits)
 
   apply clarsimp
   (* ugh having to manually do constraint solving here... *)
   apply(clarsimp simp: low_eq_strong_def nontrivial_def)
   apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
   apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
   apply clarsimp
   done
 
 end
diff --git a/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy b/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy
--- a/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy
+++ b/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy
@@ -1,3439 +1,3438 @@
 section \<open>Overview\<close>
 
 text \<open>
   Computing the maximal strongly connected components (SCCs) of a 
   finite directed graph is a celebrated problem in the
   theory of graph algorithms. Although Tarjan's algorithm~\<^cite>\<open>"tarjan:depth-first"\<close> 
   is perhaps the best-known solution, there are many others. In his PhD 
   thesis, Bloemen~\<^cite>\<open>"bloemen:strong"\<close> presents an algorithm that is itself based
   on earlier algorithms by Munro~\<^cite>\<open>"munro:efficient"\<close> and
   Dijkstra~\<^cite>\<open>"dijkstra:finding"\<close>. Just like these algorithms, Bloemen's
   solution is based on enumerating SCCs in a depth-first traversal of the graph.
   Gabow's algorithm that has already been formalized in Isabelle~\<^cite>\<open>"lammich:gabow"\<close>
   also falls into this category of solutions.
   Nevertheless, Bloemen goes on to present a parallel variant of the algorithm
   suitable for execution on multi-core processors, based on clever data structures
   that minimize locking.
 
   In the following, we encode the sequential version of the algorithm in the
   proof assistant Isabelle/HOL, and prove its correctness. Bloemen's thesis
   briefly and informally explains why the algorithm is correct. Our proof expands
   on these arguments, making them completely formal. The encoding is based on
   a direct representation of the algorithm as a pair of mutually recursive
   functions; we are not aiming at extracting executable code.
 \<close>
 
 theory SCC_Bloemen_Sequential
 imports Main
 begin
 
 text \<open>
   The record below represents the variables of the
   algorithm. Most variables correspond to those used in
   Bloemen's presentation. Thus, the variable @{text \<S>}
   associates to every node the set of nodes that have
   already been determined to be part of the same SCC. A core
   invariant of the algorithm will be that this mapping represents
   equivalence classes of nodes: for all nodes @{text v} and @{text w},
   we maintain the relationship
 
   @{text "v \<in> \<S> w \<longleftrightarrow> \<S> v = \<S> w."}
 
   In an actual implementation of this algorithm, this variable
   could conveniently be represented by a union-find structure.
   Variable @{text stack} holds the list of roots of these 
   (not yet maximal) SCCs, in depth-first order,
   @{text visited} and @{text explored}
   represent the nodes that have already been seen, respectively
   that have been completely explored, by the algorithm, and
   @{text sccs} is the set of maximal SCCs that the algorithm
   has found so far.
 
   Additionally, the record holds some auxiliary variables that
   are used in the proof of correctness. In particular,
   @{text root} denotes the node on which the algorithm was called,
   @{text cstack} represents the call stack of the recursion of
   function @{text dfs},
   and @{text vsuccs} stores the successors of each node
   that have already been visited by the function @{text dfss}
   that loops over all successors of a given node.
 \<close>
 record 'v env =
   root :: "'v"
   \<S> :: "'v \<Rightarrow> 'v set"
   explored :: "'v set"
   visited :: "'v set"
   vsuccs :: "'v \<Rightarrow> 'v set"
   sccs :: "'v set set"
   stack :: "'v list"
   cstack :: "'v list"
 
 text \<open>
   The algorithm is initially called with an environment that
   initializes the root node and trivializes all other components.
 \<close>
 definition init_env where
   "init_env v = \<lparr>
     root = v,
     \<S> = (\<lambda>u. {u}),
     explored = {},
     visited = {},
     vsuccs = (\<lambda>u. {}),
     sccs = {},
     stack = [],
     cstack = []
    \<rparr>"
 
 \<comment> \<open>Make the simplifier expand let-constructions automatically.\<close>
 declare Let_def[simp]
 
 
 
 section \<open>Auxiliary lemmas about lists\<close>
 
 text \<open>
   We use the precedence order on the elements that appear
   in a list. In particular, stacks are represented as lists,
   and a node @{text x} precedes another node @{text y} on the
   stack if @{text x} was pushed on the stack later
   than @{text y}.
 \<close>
 
 definition precedes ("_ \<preceq> _ in _" [100,100,100] 39) where
   "x \<preceq> y in xs \<equiv> \<exists>l r. xs = l @ (x # r) \<and> y \<in> set (x # r)"
 
 lemma precedes_mem:
   assumes "x \<preceq> y in xs"
   shows "x \<in> set xs" "y \<in> set xs"
   using assms unfolding precedes_def by auto
 
 lemma head_precedes:
   assumes "y \<in> set (x # xs)"
   shows "x \<preceq> y in (x # xs)"
   using assms unfolding precedes_def by force
 
 lemma precedes_in_tail:
   assumes "x \<noteq> z"
   shows "x \<preceq> y in (z # zs) \<longleftrightarrow> x \<preceq> y in zs"
   using assms unfolding precedes_def by (auto simp: Cons_eq_append_conv)
 
 lemma tail_not_precedes:
   assumes "y \<preceq> x in (x # xs)" "x \<notin> set xs"
   shows "x = y"
   using assms unfolding precedes_def
   by (metis Cons_eq_append_conv Un_iff list.inject set_append)
 
 lemma split_list_precedes:
   assumes "y \<in> set (ys @ [x])"
   shows "y \<preceq> x in (ys @ x # xs)"
   using assms unfolding precedes_def
   by (metis append_Cons append_assoc in_set_conv_decomp
             rotate1.simps(2) set_ConsD set_rotate1)
 
 lemma precedes_refl [simp]: "(x \<preceq> x in xs) = (x \<in> set xs)"
 proof
   assume "x \<preceq> x in xs" thus "x \<in> set xs"
     by (simp add: precedes_mem)
 next
   assume "x \<in> set xs"
   from this[THEN split_list] show "x \<preceq> x in xs"
     unfolding precedes_def by auto
 qed
 
 lemma precedes_append_left:
   assumes "x \<preceq> y in xs"
   shows "x \<preceq> y in (ys @ xs)"
   using assms unfolding precedes_def by (metis append.assoc)
 
 lemma precedes_append_left_iff:
   assumes "x \<notin> set ys"
   shows "x \<preceq> y in (ys @ xs) \<longleftrightarrow> x \<preceq> y in xs" (is "?lhs = ?rhs")
 proof
   assume "?lhs"
   then obtain l r where lr: "ys @ xs = l @ (x # r)" "y \<in> set (x # r)"
     unfolding precedes_def by blast
   then obtain us where
     "(ys = l @ us \<and> us @ xs = x # r) \<or> (ys @ us = l \<and> xs = us @ (x # r))"
     by (auto simp: append_eq_append_conv2)
   thus ?rhs
   proof
     assume us: "ys = l @ us \<and> us @ xs = x # r"
     with assms have "us = []"
       by (metis Cons_eq_append_conv in_set_conv_decomp)
     with us lr show ?rhs
       unfolding precedes_def by auto
   next
     assume us: "ys @ us = l \<and> xs = us @ (x # r)"
     with \<open>y \<in> set (x # r)\<close> show ?rhs
       unfolding precedes_def by blast
   qed
 next
   assume "?rhs" thus "?lhs" by (rule precedes_append_left)
 qed
 
 lemma precedes_append_right:
   assumes "x \<preceq> y in xs"
   shows "x \<preceq> y in (xs @ ys)"
   using assms unfolding precedes_def by force
 
 lemma precedes_append_right_iff:
   assumes "y \<notin> set ys"
   shows "x \<preceq> y in (xs @ ys) \<longleftrightarrow> x \<preceq> y in xs" (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then obtain l r where lr: "xs @ ys = l @ (x # r)" "y \<in> set (x # r)"
     unfolding precedes_def by blast
   then obtain us where
     "(xs = l @ us \<and> us @ ys = x # r) \<or> (xs @ us = l \<and> ys = us @ (x # r))"
     by (auto simp: append_eq_append_conv2)
   thus ?rhs
   proof
     assume us: "xs = l @ us \<and> us @ ys = x # r"
     with \<open>y \<in> set (x # r)\<close> assms show ?rhs
       unfolding precedes_def by (metis Cons_eq_append_conv Un_iff set_append)
   next
     assume us: "xs @ us = l \<and> ys = us @ (x # r)"
     with \<open>y \<in> set (x # r)\<close> assms 
     show ?rhs by auto \<comment> \<open>contradiction\<close>
   qed
 next
   assume ?rhs thus ?lhs by (rule precedes_append_right)
 qed
 
 text \<open>
   Precedence determines an order on the elements of a list,
   provided elements have unique occurrences. However, consider
   a list such as @{text "[2,3,1,2]"}: then $1$ precedes $2$ and
   $2$ precedes $3$, but $1$ does not precede $3$.
 \<close>
 lemma precedes_trans:
   assumes "x \<preceq> y in xs" and "y \<preceq> z in xs" and "distinct xs"
   shows "x \<preceq> z in xs"
   using assms unfolding precedes_def
-  by (smt Un_iff append.assoc append_Cons_eq_iff distinct_append 
-          not_distinct_conv_prefix set_append split_list_last)
+  by (metis assms(2) disjoint_iff distinct_append precedes_append_left_iff precedes_mem(2))
 
 lemma precedes_antisym:
   assumes "x \<preceq> y in xs" and "y \<preceq> x in xs" and "distinct xs"
   shows "x = y"
 proof -
   from \<open>x \<preceq> y in xs\<close> \<open>distinct xs\<close> obtain as bs where
     1: "xs = as @ (x # bs)" "y \<in> set (x # bs)" "y \<notin> set as"
     unfolding precedes_def by force
   from \<open>y \<preceq> x in xs\<close> \<open>distinct xs\<close> obtain cs ds where
     2: "xs = cs @ (y # ds)" "x \<in> set (y # ds)" "x \<notin> set cs"
     unfolding precedes_def by force
   from 1 2 have "as @ (x # bs) = cs @ (y # ds)"
     by simp
   then obtain zs where
     "(as = cs @ zs \<and> zs @ (x # bs) = y # ds) 
      \<or> (as @ zs = cs \<and> x # bs = zs @ (y # ds))"  (is "?P \<or> ?Q")
     by (auto simp: append_eq_append_conv2)
   then show ?thesis
   proof
     assume "?P" with \<open>y \<notin> set as\<close> show ?thesis 
       by (cases "zs") auto
   next
     assume "?Q" with \<open>x \<notin> set cs\<close> show ?thesis
       by (cases "zs") auto
   qed
 qed
 
 
 section \<open>Finite directed graphs\<close>
 
 text \<open>
   We represent a graph as an Isabelle locale that identifies a finite
   set of vertices (of some base type @{text "'v"}) and associates to
   each vertex its set of successor vertices.
 \<close>
 
 locale graph =
   fixes vertices :: "'v set"
     and successors :: "'v \<Rightarrow> 'v set"
   assumes vfin: "finite vertices"
     and sclosed: "\<forall>x \<in> vertices. successors x \<subseteq> vertices"
 
 context graph
 begin
 
 abbreviation edge where
   "edge x y \<equiv> y \<in> successors x"
 
 text \<open>
   We inductively define reachability of nodes in the graph.
 \<close>
 inductive reachable where
   reachable_refl[iff]: "reachable x x"
 | reachable_succ[elim]: "\<lbrakk>edge x y; reachable y z\<rbrakk> \<Longrightarrow> reachable x z"
 
 lemma reachable_edge: "edge x y \<Longrightarrow> reachable x y"
   by auto
 
 lemma succ_reachable:
   assumes "reachable x y" and "edge y z"
   shows "reachable x z"
   using assms by induct auto
 
 lemma reachable_trans:
   assumes y: "reachable x y" and z: "reachable y z"
   shows "reachable x z"
   using assms by induct auto
 
 text \<open>
   In order to derive a ``reverse'' induction rule for @{const "reachable"},
   we define an alternative reachability predicate and prove that the two
   coincide.
 \<close>
 inductive reachable_end where
   re_refl[iff]: "reachable_end x x"
 | re_succ: "\<lbrakk>reachable_end x y; edge y z\<rbrakk> \<Longrightarrow> reachable_end x z"
 
 lemma succ_re:
   assumes y: "edge x y" and z: "reachable_end y z"
   shows "reachable_end x z"
   using z y by (induction) (auto intro: re_succ)
 
 lemma reachable_re:
   assumes "reachable x y"
   shows "reachable_end x y"
   using assms by (induction) (auto intro: succ_re)
 
 lemma re_reachable:
   assumes "reachable_end x y"
   shows "reachable x y"
   using assms by (induction) (auto intro: succ_reachable)
 
 lemma reachable_end_induct:
   assumes r: "reachable x y"
       and base: "\<And>x. P x x"
       and step: "\<And>x y z. \<lbrakk>P x y; edge y z\<rbrakk> \<Longrightarrow> P x z"
   shows "P x y"
 using r[THEN reachable_re] proof (induction)
   case (re_refl x)
   from base show ?case .
 next
   case (re_succ x y z)
   with step show ?case by blast
 qed
 
 text \<open>
   We also need the following variant of reachability avoiding
   certain edges. More precisely, @{text y} is reachable from @{text x}
   avoiding a set @{text E} of edges if there exists a path such that
   no edge from @{text E} appears along the path.
 \<close>
 inductive reachable_avoiding where
   ra_refl[iff]: "reachable_avoiding x x E"
 | ra_succ[elim]: "\<lbrakk>reachable_avoiding x y E; edge y z; (y,z) \<notin> E\<rbrakk> \<Longrightarrow> reachable_avoiding x z E"
 
 lemma edge_ra:
   assumes "edge x y" and "(x,y) \<notin> E"
   shows "reachable_avoiding x y E"
   using assms by (meson reachable_avoiding.simps)
 
 lemma ra_trans:
   assumes 1: "reachable_avoiding x y E" and 2: "reachable_avoiding y z E"
   shows "reachable_avoiding x z E"
   using 2 1 by induction auto
 
 lemma ra_cases:
   assumes "reachable_avoiding x y E"
   shows "x=y \<or> (\<exists>z. z \<in> successors x \<and> (x,z) \<notin> E \<and> reachable_avoiding z y E)"
 using assms proof (induction)
   case (ra_refl x S)
   then show ?case by simp
 next
   case (ra_succ x y S z)
   then show ?case
     by (metis ra_refl reachable_avoiding.ra_succ)
 qed
 
 lemma ra_mono: 
   assumes "reachable_avoiding x y E" and "E' \<subseteq> E"
   shows "reachable_avoiding x y E'"
 using assms by induction auto
 
 lemma ra_add_edge:
   assumes "reachable_avoiding x y E"
   shows "reachable_avoiding x y (E \<union> {(v,w)})
          \<or> (reachable_avoiding x v (E \<union> {(v,w)}) \<and> reachable_avoiding w y (E \<union> {(v,w)}))"
 using assms proof (induction)
   case (ra_refl x E)
   then show ?case by simp
 next
   case (ra_succ x y E z)
   then show ?case
     using reachable_avoiding.ra_succ by auto
 qed
 
 
 text \<open>
   Reachability avoiding some edges obviously implies reachability.
   Conversely, reachability implies reachability avoiding the empty set.
 \<close>
 lemma ra_reachable:
   "reachable_avoiding x y E \<Longrightarrow> reachable x y"
   by (induction rule: reachable_avoiding.induct) (auto intro: succ_reachable)
 
 lemma ra_empty:
   "reachable_avoiding x y {} = reachable x y"
 proof
   assume "reachable_avoiding x y {}"
   thus "reachable x y"
     by (rule ra_reachable)
 next
   assume "reachable x y"
   hence "reachable_end x y"
     by (rule reachable_re)
   thus "reachable_avoiding x y {}"
     by induction auto
 qed
 
 
 section \<open>Strongly connected components\<close>
 
 text \<open>
   A strongly connected component is a set @{text S} of nodes
   such that any two nodes in @{text S} are reachable from each other.
   This concept is represented by the predicate @{text "is_subscc"} below.
   We are ultimately interested in non-empty, maximal strongly connected
   components, represented by the predicate @{text "is_scc"}.
 \<close>
 
 definition is_subscc where
   "is_subscc S \<equiv> \<forall>x \<in> S. \<forall>y \<in> S. reachable x y"
 
 definition is_scc where
   "is_scc S \<equiv> S \<noteq> {} \<and> is_subscc S \<and> (\<forall>S'. S \<subseteq> S' \<and> is_subscc S' \<longrightarrow> S' = S)"
 
 lemma subscc_add:
   assumes "is_subscc S" and "x \<in> S"
       and "reachable x y" and "reachable y x"
   shows "is_subscc (insert y S)"
 using assms unfolding is_subscc_def by (metis insert_iff reachable_trans)
 
 lemma sccE:
   \<comment> \<open>Two nodes that are reachable from each other are in the same SCC.\<close>
   assumes "is_scc S" and "x \<in> S"
       and "reachable x y" and "reachable y x"
   shows "y \<in> S"
   using assms unfolding is_scc_def 
   by (metis insertI1 subscc_add subset_insertI)
 
 lemma scc_partition:
   \<comment> \<open>Two SCCs that contain a common element are identical.\<close>
   assumes "is_scc S" and "is_scc S'" and "x \<in> S \<inter> S'"
   shows "S = S'"
   using assms unfolding is_scc_def is_subscc_def
   by (metis IntE assms(2) sccE subsetI)
 
 
 section \<open>Algorithm for computing strongly connected components\<close>
 
 text \<open>
   We now introduce our representation of Bloemen's algorithm in Isabelle/HOL.
   The auxiliary function @{text unite} corresponds to the inner \textsf{while}
   loop in Bloemen's pseudo-code~\<^cite>\<open>\<open>p.32\<close> in "bloemen:strong"\<close>. It is applied to
   two nodes @{text v} and @{text w} (and the environment @{text e} holding the
   current values of the program variables) when a loop is found, i.e.\ when
   @{text w} is a successor of @{text v} in the graph that has already been
   visited in the depth-first search. In that case, the root of the SCC
   of node @{text w} determined so far must appear below the root of
   @{text v}'s SCC in the @{text stack} maintained by the algorithm. 
   The effect of the function is to merge the SCCs of all nodes on the
   top of the stack above (and including) @{text w}. Node @{text w}'s root
   will be the root of the merged SCC.
 \<close>
 
 definition unite :: "'v \<Rightarrow> 'v \<Rightarrow> 'v env \<Rightarrow> 'v env" where
   "unite v w e \<equiv>
      let pfx = takeWhile (\<lambda>x. w \<notin> \<S> e x) (stack e);
          sfx = dropWhile (\<lambda>x. w \<notin> \<S> e x) (stack e);
          cc = \<Union> { \<S> e x | x . x \<in> set pfx \<union> {hd sfx} }
      in  e\<lparr>\<S> := \<lambda>x. if x \<in> cc then cc else \<S> e x,
            stack := sfx\<rparr>"
 
 text \<open>
   We now represent the algorithm as two mutually recursive functions @{text dfs} and
   @{text dfss} in Isabelle/HOL. The function @{text dfs} corresponds to Bloemen's
   function \textsf{SetBased}, whereas @{text dfss} corresponds to the \textsf{forall}
   loop over the successors of the node on which @{text dfs} was called. Instead of
   using global program variables in imperative style, our functions explicitly pass
   environments that hold the current values of these variables.
 
   A technical complication in the development of the algorithm in Isabelle is the
   fact that the functions need not terminate when their pre-conditions (introduced
   below) are violated, for example when @{text dfs} is called for a node that was
   already visited previously. We therefore cannot prove termination at this point, 
   but will later show that the explicitly given pre-conditions ensure termination.
 \<close>
 
 function (domintros) dfs :: "'v \<Rightarrow> 'v env \<Rightarrow> 'v env" 
 and dfss :: "'v \<Rightarrow> 'v env \<Rightarrow> 'v env" where
   "dfs v e =
   (let e1 = e\<lparr>visited := visited e \<union> {v}, 
               stack := (v # stack e), 
               cstack := (v # cstack e)\<rparr>;
        e' = dfss v e1
    in if v = hd(stack e')
       then e'\<lparr>sccs := sccs e' \<union> {\<S> e' v}, 
               explored := explored e' \<union> (\<S> e' v), 
               stack := tl(stack e'), 
               cstack := tl(cstack e')\<rparr>
       else e'\<lparr>cstack := tl(cstack e')\<rparr>)"
 | "dfss v e =
    (let vs = successors v - vsuccs e v
     in  if vs = {} then e
         else let w = SOME x. x \<in> vs;
                  e' = (if w \<in> explored e then e
                        else if w \<notin> visited e
                        then dfs w e
                        else unite v w e);
                  e'' = (e'\<lparr>vsuccs := 
                              (\<lambda>x. if x=v then vsuccs e' v \<union> {w} 
                                   else vsuccs e' x)\<rparr>)
              in  dfss v e'')"
   by pat_completeness (force+)
 
 
 section \<open>Definition of the predicates used in the correctness proof\<close>
 
 text \<open>
   Environments are partially ordered according to the following definition.
 \<close>
 definition sub_env where
   "sub_env e e' \<equiv> 
      root e' = root e
    \<and> visited e \<subseteq> visited e'
    \<and> explored e \<subseteq> explored e'
    \<and> (\<forall>v. vsuccs e v \<subseteq> vsuccs e' v)
    \<and> (\<forall> v. \<S> e v \<subseteq> \<S> e' v)
    \<and> (\<Union> {\<S> e v | v . v \<in> set (stack e)})
      \<subseteq> (\<Union> {\<S> e' v | v . v \<in> set (stack e')})
 "
 
 lemma sub_env_trans:
   assumes "sub_env e e'" and "sub_env e' e''"
   shows "sub_env e e''"
   using assms unfolding sub_env_def
   by (metis (no_types, lifting) subset_trans)
 
 text \<open>
   The set @{text "unvisited e u"} contains all edges @{text "(a,b)"}
   such that node @{text a} is in the same SCC as
   node @{text u} and the edge has not yet been followed, in the
   sense represented by variable @{text vsuccs}.
 \<close>
 definition unvisited where
   "unvisited e u \<equiv> 
    {(a,b) | a b. a \<in> \<S> e u \<and> b \<in> successors a - vsuccs e a}"
 
 subsection \<open>Main invariant\<close>
 
 text \<open>
   The following definition characterizes well-formed environments.
   This predicate will be shown to hold throughout the execution
   of the algorithm. In words, it asserts the following facts:
   \begin{itemize}
   \item Only nodes reachable from the root (for which the algorithm
     was originally called) are visited.
   \item The two stacks @{text stack} and @{text cstack} do not
     contain duplicate nodes, and @{text stack} contains a subset
     of the nodes on @{text cstack}, in the same order.
   \item Any node higher on the @{text stack} (i.e., that was pushed
     later) is reachable from nodes lower in the @{text stack}.
     This property also holds for nodes on the call stack,
     but this is not needed for the correctness proof.
   \item Every explored node, and every node on the call stack,
     has been visited.
   \item Nodes reachable from fully explored nodes have 
     themselves been fully explored.
   \item The set @{text "vsuccs e n"}, for any node @{text n},
     is a subset of @{text n}'s successors, and all these nodes
     are in @{text visited}. The set is empty if @{text "n \<notin> visited"},
     and it contains all successors if @{text n} has been fully 
     explored or if @{text n} has been visited, but is no longer
     on the call stack.
   \item The sets @{text "\<S> e n"} represent an equivalence relation.
     The equivalence classes of nodes that have not yet been visited 
     are singletons. Also, equivalence classes for two distinct nodes
     on the @{text stack} are disjoint because the stack only stores
     roots of SCCs, and the union of the equivalence classes for these
     root nodes corresponds to the set of live nodes, i.e. those nodes
     that have already been visited but not yet fully explored.
   \item More precisely, an equivalence class is represented on the
     stack by the oldest node in the sense of the call order: any
     node in the class that is still on the call stack precedes the
     representative on the call stack and was therefore pushed later.
   \item Equivalence classes represent the maximal available
     information about strong connectedness: nodes represented by
     some node @{text n} on the @{text stack} can reach some node
     @{text m} that is lower in the stack only by taking an
     edge from some node in @{text n}'s equivalence class that 
     has not yet been followed. (Remember that @{text m} can reach
     @{text n} by one of the previous conjuncts.)
   \item Equivalence classes represent partial SCCs in the sense
     of the predicate @{text is_subscc}. Variable @{text sccs}
     holds maximal SCCs in the sense of the predicate @{text is_scc},
     and their union corresponds to the set of explored nodes.
   \end{itemize}
 \<close>
 definition wf_env where
   "wf_env e \<equiv>
     (\<forall>n \<in> visited e. reachable (root e) n)
   \<and> distinct (stack e)
   \<and> distinct (cstack e)
   \<and> (\<forall>n m. n \<preceq> m in stack e \<longrightarrow> n \<preceq> m in cstack e)
   \<and> (\<forall>n m. n \<preceq> m in stack e \<longrightarrow> reachable m n)
   \<and> explored e \<subseteq> visited e
   \<and> set (cstack e) \<subseteq> visited e
   \<and> (\<forall>n \<in> explored e. \<forall>m. reachable n m \<longrightarrow> m \<in> explored e)  
   \<and> (\<forall>n. vsuccs e n \<subseteq> successors n \<inter> visited e)
   \<and> (\<forall>n. n \<notin> visited e \<longrightarrow> vsuccs e n = {})
   \<and> (\<forall>n \<in> explored e. vsuccs e n = successors n)
   \<and> (\<forall>n \<in> visited e - set (cstack e). vsuccs e n = successors n)
   \<and> (\<forall>n m. m \<in> \<S> e n \<longleftrightarrow> (\<S> e n = \<S> e m))
   \<and> (\<forall>n. n \<notin> visited e \<longrightarrow> \<S> e n = {n})
   \<and> (\<forall>n \<in> set (stack e). \<forall>m \<in> set (stack e). n \<noteq> m \<longrightarrow> \<S> e n \<inter> \<S> e m = {})
   \<and> \<Union> {\<S> e n | n. n \<in> set (stack e)} = visited e - explored e
   \<and> (\<forall>n \<in> set (stack e). \<forall>m \<in> \<S> e n. m \<in> set (cstack e) \<longrightarrow> m \<preceq> n in cstack e)
   \<and> (\<forall>n m. n \<preceq> m in stack e \<and> n \<noteq> m \<longrightarrow>
         (\<forall>u \<in> \<S> e n. \<not> reachable_avoiding u m (unvisited e n)))
   \<and> (\<forall>n. is_subscc (\<S> e n))
   \<and> (\<forall>S \<in> sccs e. is_scc S)
   \<and> \<Union> (sccs e) = explored e"
 
 subsection \<open>Consequences of the invariant\<close>
 
 text \<open>
   Since every node on the call stack is an element
   of @{text visited} and every node on the @{text stack}
   also appears on @{text cstack}, all these nodes are
   also in @{text visited}.
 \<close>
 lemma stack_visited:
   assumes "wf_env e" "n \<in> set (stack e)"
   shows "n \<in> visited e"
   using assms unfolding wf_env_def
   by (meson precedes_refl subset_iff)
 
 text \<open>
   Classes represented on the stack consist of visited nodes
   that have not yet been fully explored.
 \<close>
 lemma stack_class:
   assumes "wf_env e" "n \<in> set (stack e)" "m \<in> \<S> e n"
   shows "m \<in> visited e - explored e"
   using assms unfolding wf_env_def by blast
 
 text \<open>
   Conversely, every such node belongs to some class
   represented on the stack.
 \<close>
 lemma visited_unexplored:
   assumes "wf_env e" "m \<in> visited e" "m \<notin> explored e"
   obtains n where "n \<in> set (stack e)" "m \<in> \<S> e n"
   using assms unfolding wf_env_def
   by (smt (verit, ccfv_threshold) Diff_iff Union_iff mem_Collect_eq)
 
 text \<open>
   Every node belongs to its own equivalence class.
 \<close>
 lemma S_reflexive:
   assumes "wf_env e"
   shows "n \<in> \<S> e n"
   using assms by (auto simp: wf_env_def)
 
 text \<open>
   No node on the stack has been fully explored.
 \<close>
 lemma stack_unexplored:
   assumes 1: "wf_env e"
       and 2: "n \<in> set (stack e)"
       and 3: "n \<in> explored e"
   shows "P"
   using stack_class[OF 1 2] S_reflexive[OF 1] 3
   by blast
 
 text \<open>
   If @{text w} is reachable from visited node @{text v}, but
   no unvisited successor of a node reachable from @{text v}
   can reach @{text w}, then @{text w} must be visited.
 \<close>
 lemma reachable_visited:
   assumes e: "wf_env e"
       and v: "v \<in> visited e"
       and w: "reachable v w"
       and s: "\<forall>n \<in> visited e. \<forall>m \<in> successors n - vsuccs e n. 
                  reachable v n \<longrightarrow> \<not> reachable m w"
   shows "w \<in> visited e"
 using w v s proof (induction)
   case (reachable_refl x)
   then show ?case by simp
 next
   case (reachable_succ x y z)
   then have "y \<in> vsuccs e x" by blast
   with e have "y \<in> visited e" 
     unfolding wf_env_def by (meson le_infE subset_eq)
   with reachable_succ reachable.reachable_succ show ?case
     by blast
 qed
 
 text \<open>
   Edges towards explored nodes do not contribute to reachability
   of unexplored nodes avoiding some set of edges.
 \<close>
 lemma avoiding_explored:
   assumes e: "wf_env e"
       and xy: "reachable_avoiding x y E"
       and y: "y \<notin> explored e"
       and w: "w \<in> explored e"
     shows "reachable_avoiding x y (E \<union> {(v,w)})"
 using xy y proof (induction)
   case (ra_refl x E)
   then show ?case by simp
 next
   case (ra_succ x y E z)
   from e \<open>z \<in> successors y\<close> \<open>z \<notin> explored e\<close>
   have "y \<notin> explored e"
     unfolding wf_env_def by (meson reachable_edge)
   with ra_succ.IH have "reachable_avoiding x y (E \<union> {(v,w)})" .
   moreover
   from w \<open>(y,z) \<notin> E\<close> \<open>z \<notin> explored e\<close> have "(y,z) \<notin> E \<union> {(v,w)}"
     by auto
   ultimately show ?case 
     using  \<open>z \<in> successors y\<close> by auto
 qed
 
 subsection \<open>Pre- and post-conditions of function @{text dfs}\<close>
 
 text \<open>
   Function @{text dfs} should be called for a well-formed
   environment and a node @{text v} that has not yet been
   visited and that is reachable from the root node, 
   as well as from all nodes in the stack. No outgoing edges
   from node @{text v} have yet been followed.
 \<close>
 
 definition pre_dfs where 
   "pre_dfs v e \<equiv> 
      wf_env e
    \<and> v \<notin> visited e
    \<and> reachable (root e) v
    \<and> vsuccs e v = {}
    \<and> (\<forall>n \<in> set (stack e). reachable n v)"
 
 text \<open>
   Function @{text dfs} maintains the invariant
   @{text wf_env} and returns an environment @{text e'} that
   extends the input environment @{text e}. Node @{text v} has been 
   visited and all its outgoing edges have been followed.
   Because the algorithm works in depth-first fashion, no 
   new outgoing edges of nodes that had already been
   visited in the input environment have been followed, and
   the stack of @{text e'} is a suffix of the one of @{text e}
   such that @{text v} is still reachable from all nodes on the
   stack. The stack may have been shortened because SCCs
   represented at the top of the stack may have been
   merged. The call stack is reestablished as it was in @{text e}.
   There are two possible outcomes of the algorithm:
   \begin{itemize}
   \item Either @{text v} has been fully explored, in which case
     the stacks of @{text e} and @{text e'} are the same, and
     the equivalence classes of all nodes represented on the
     stack are unchanged. This corresponds to the case where
     @{text v} is the root node of its (maximal) SCC.
   \item Alternatively, the stack of @{text e'} must be
     non-empty and @{text v} must be represented by the node at
     the top of the stack. The SCCs of the nodes
     lower on the stack are unchanged. This corresponds to the
     case where @{text v} is not the root node of its SCC, but
     some SCCs at the top of the stack may have been merged.
   \end{itemize}
 \<close>
 definition post_dfs where 
   "post_dfs v e e' \<equiv> 
      wf_env e'
    \<and> v \<in> visited e'
    \<and> sub_env e e'
    \<and> vsuccs e' v = successors v
    \<and> (\<forall>w \<in> visited e. vsuccs e' w = vsuccs e w)
    \<and> (\<forall>n \<in> set (stack e'). reachable n v)
    \<and> (\<exists>ns. stack e = ns @ (stack e'))
    \<and> (  (v \<in> explored e' \<and> stack e' = stack e 
          \<and> (\<forall>n \<in> set (stack e'). \<S> e' n = \<S> e n)) 
      \<or> (stack e' \<noteq> [] \<and> v \<in> \<S> e' (hd (stack e')) 
          \<and> (\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n)))
    \<and> cstack e' = cstack e"
 
 text \<open>
   The initial environment is easily seen to satisfy @{text dfs}'s
   pre-condition.
 \<close>
 lemma init_env_pre_dfs: "pre_dfs v (init_env v)"
   by (auto simp: pre_dfs_def wf_env_def init_env_def is_subscc_def 
            dest: precedes_mem)
 
 text \<open>
   Any node represented by the top stack element of the
   input environment is still represented by the top
   element of the output stack.
 \<close>
 lemma dfs_S_hd_stack:
   assumes wf: "wf_env e"
       and post: "post_dfs v e e'"
       and n: "stack e \<noteq> []" "n \<in> \<S> e (hd (stack e))"
     shows "stack e' \<noteq> []" "n \<in> \<S> e' (hd (stack e'))"
 proof -
   have 1: "stack e' \<noteq> [] \<and> n \<in> \<S> e' (hd (stack e'))"
   proof (cases "stack e' = stack e \<and> (\<forall>n \<in> set (stack e'). \<S> e' n = \<S> e n)")
     case True
     with n show ?thesis 
       by auto
   next
     case 2: False
     with post have "stack e' \<noteq> []"
       by (simp add: post_dfs_def)
     from n have "hd (stack e) \<in> set (stack e)"
       by simp
     with 2 n post obtain u where
       u: "u \<in> set (stack e')" "n \<in> \<S> e' u"
       unfolding post_dfs_def sub_env_def by blast
     show ?thesis
     proof (cases "u = hd (stack e')")
       case True
       with u \<open>stack e' \<noteq> []\<close> show ?thesis
         by simp
     next
       case False
       with u have "u \<in> set (tl (stack e'))"
         by (metis empty_set equals0D list.collapse set_ConsD)
       with u 2 post have "u \<in> set (tl (stack e)) \<and> n \<in> \<S> e u"
         unfolding post_dfs_def
         by (metis Un_iff append_self_conv2 set_append tl_append2)
       with n wf \<open>hd (stack e) \<in> set (stack e)\<close> show ?thesis
         unfolding wf_env_def
         by (metis (no_types, opaque_lifting) disjoint_iff_not_equal distinct.simps(2) list.collapse list.set_sel(2))
     qed
   qed
   from 1 show "stack e' \<noteq> []" by simp
   from 1 show "n \<in> \<S> e' (hd (stack e'))" by simp
 qed
 
 text \<open>
   Function @{text dfs} leaves the SCCs represented
   by elements in the (new) tail of the @{text stack} unchanged.
 \<close>
 lemma dfs_S_tl_stack:
   assumes post: "post_dfs v e e'"
     and nempty: "stack e \<noteq> []"
   shows "stack e' \<noteq> []" "\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n"
 proof -
   have 1: "stack e' \<noteq> [] \<and> (\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n)"
   proof (cases "stack e' = stack e \<and> (\<forall>n \<in> set (stack e'). \<S> e' n = \<S> e n)")
     case True
     with nempty show ?thesis
       by (simp add: list.set_sel(2))
   next
     case False
     with post show ?thesis
       by (auto simp: post_dfs_def)
   qed
   from 1 show "stack e' \<noteq> []"
     by simp
   from 1 show "\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n"
     by simp
 qed
 
 subsection \<open>Pre- and post-conditions of function @{text dfss}\<close>
 
 text \<open>
   The pre- and post-conditions of function @{text dfss}
   correspond to the invariant of the loop over all outgoing
   edges from node @{text v}. The environment must be
   well-formed, node @{text v} must be visited and represented
   by the top element of the (non-empty) stack. Node @{text v}
   must be reachable from all nodes on the stack, and it must be
   the top node on the call stack. All outgoing
   edges of node @{text v} that have already been followed must
   either lead to completely explored nodes (that are no longer
   represented on the stack) or to nodes that are part of the
   same SCC as @{text v}.
 \<close>
 definition pre_dfss where 
   "pre_dfss v e \<equiv> 
      wf_env e 
    \<and> v \<in> visited e
    \<and> (stack e \<noteq> [])
    \<and> (v \<in> \<S> e (hd (stack e)))
    \<and> (\<forall>w \<in> vsuccs e v. w \<in> explored e \<union> \<S> e (hd (stack e)))
    \<and> (\<forall>n \<in> set (stack e). reachable n v)
    \<and> (\<exists>ns. cstack e = v # ns)"
 
 text \<open>
   The post-condition establishes that all outgoing edges
   of node @{text v} have been followed. As for function
   @{text dfs}, no new outgoing edges of previously visited
   nodes have been followed. Also as before, the new stack
   is a suffix of the old one, and the call stack is restored.
   In case node @{text v} is still on the stack (and therefore
   is the root node of its SCC), no node that is lower on the stack
   can be reachable from @{text v}. This condition guarantees
   the maximality of the computed SCCs.
 \<close>
 definition post_dfss where 
   "post_dfss v e e' \<equiv> 
      wf_env e'
    \<and> vsuccs e' v = successors v
    \<and> (\<forall>w \<in> visited e - {v}. vsuccs e' w = vsuccs e w)
    \<and> sub_env e e'
    \<and> (\<forall>w \<in> successors v. w \<in> explored e' \<union> \<S> e' (hd (stack e')))
    \<and> (\<forall>n \<in> set (stack e'). reachable n v)
    \<and> (stack e' \<noteq> [])
    \<and> (\<exists>ns. stack e = ns @ (stack e'))
    \<and> v \<in> \<S> e' (hd (stack e'))
    \<and> (\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n)
    \<and> (hd (stack e') = v \<longrightarrow> (\<forall>n \<in> set (tl (stack e')). \<not> reachable v n))
    \<and> cstack e' = cstack e"
 
 
 section \<open>Proof of partial correctness\<close>
 
 subsection \<open>Lemmas about function @{text unite}\<close>
 
 text \<open>
   We start by establishing a few lemmas about function @{text unite}
   in the context where it is called.
 \<close>
 lemma unite_stack:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   assumes wf: "wf_env e"
       and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
   obtains pfx where "stack e = pfx @ (stack e')" 
                     "stack e' \<noteq> []"
                     "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
                      in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
                     "w \<in> \<S> e' (hd (stack e'))"
 proof -
   define pfx where "pfx = takeWhile (\<lambda>x. w \<notin> \<S> e x) (stack e)"
   define sfx where "sfx = dropWhile (\<lambda>x. w \<notin> \<S> e x) (stack e)"
   define cc where "cc = \<Union> {\<S> e x |x. x \<in> set pfx \<union> {hd sfx}}"
 
   have "stack e = pfx @ sfx"
     by (simp add: pfx_def sfx_def)
   moreover
   have "stack e' = sfx"
     by (simp add: e'_def unite_def sfx_def)
   moreover
   from wf w have "w \<in> \<Union> {\<S> e n | n. n \<in> set (stack e)}"
     by (simp add: wf_env_def)
   then obtain n where "n \<in> set (stack e)" "w \<in> \<S> e n"
     by auto
   hence sfx: "sfx \<noteq> [] \<and> w \<in> \<S> e (hd sfx)"
     unfolding sfx_def
     by (metis dropWhile_eq_Nil_conv hd_dropWhile)
   moreover
   have "\<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
     by (rule,
         auto simp add: e'_def unite_def pfx_def sfx_def cc_def)
   moreover
   from sfx have "w \<in> cc"
     by (auto simp: cc_def)
   from S_reflexive[OF wf, of "hd sfx"]
   have "hd sfx \<in> cc"
     by (auto simp: cc_def)
   with \<open>w \<in> cc\<close> \<open>\<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)\<close>
   have "w \<in> \<S> e' (hd sfx)"
     by simp
   ultimately show ?thesis
     using that e'_def unite_def pfx_def sfx_def cc_def
     by meson
 qed
 
 text \<open>
   Function @{text unite} leaves intact the equivalence classes
   represented by the tail of the new stack.
 \<close>
 lemma unite_S_tl:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   assumes wf: "wf_env e"
       and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
       and n: "n \<in> set (tl (stack e'))"
   shows "\<S> e' n = \<S> e n"
 proof -
   from assms obtain pfx where
     pfx: "stack e = pfx @ (stack e')" "stack e' \<noteq> []"
          "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
           in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
     by (blast dest: unite_stack)
   define cc where "cc \<equiv> \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}"
 
   have "n \<notin> cc"
   proof
     assume "n \<in> cc"
     then obtain m where
       "m \<in> set pfx \<union> {hd (stack e')}" "n \<in> \<S> e m"
       by (auto simp: cc_def)
     with S_reflexive[OF wf, of n] n wf \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
     show "False"
       unfolding wf_env_def
       by (smt (z3) Diff_triv Un_iff Un_insert_right append.right_neutral disjoint_insert(1) 
                    distinct.simps(2) distinct_append empty_set insertE insert_Diff list.exhaust_sel 
                    list.simps(15) set_append)
   qed
   with pfx show "\<S> e' n = \<S> e n"
     by (auto simp add: cc_def)
 qed
 
 text \<open>
   The stack of the result of @{text unite} represents the
   same vertices as the input stack, potentially in fewer
   equivalence classes.
 \<close>
 lemma unite_S_equal:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   assumes wf: "wf_env e"
       and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
   shows "(\<Union> {\<S> e' n | n. n \<in> set (stack e')}) = (\<Union> {\<S> e n | n. n \<in> set (stack e)})"
 proof -
   from assms obtain pfx where
     pfx: "stack e = pfx @ (stack e')" "stack e' \<noteq> []"
          "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
           in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
     by (blast dest: unite_stack)
   define cc where "cc \<equiv> \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}"
 
   from pfx have Se': "\<forall>x. \<S> e' x = (if x \<in> cc then cc else \<S> e x)"
     by (auto simp: cc_def)
   from S_reflexive[OF wf, of "hd (stack e')"]
   have S_hd: "\<S> e' (hd (stack e')) = cc"
     by (auto simp: Se' cc_def)
   from \<open>stack e' \<noteq> []\<close>
   have ste': "set (stack e') = {hd (stack e')} \<union> set (tl (stack e'))"
     by (metis insert_is_Un list.exhaust_sel list.simps(15))
 
   from \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
   have "stack e = pfx @ (hd (stack e') # tl (stack e'))"
     by auto
   hence "\<Union> {\<S> e n | n. n \<in> set (stack e)}
         = cc \<union> (\<Union> {\<S> e n | n. n \<in> set (tl (stack e'))})"
     by (auto simp add: cc_def)
   also from S_hd unite_S_tl[OF wf w]
   have "\<dots> = \<S> e' (hd (stack e')) \<union> (\<Union> {\<S> e' n | n. n \<in> set (tl (stack e'))})"
     by (auto simp: e'_def)
   also from ste'
   have "\<dots> = \<Union> {\<S> e' n | n. n \<in> set (stack e')}"
     by auto
   finally show ?thesis
     by simp
 qed
 
 text \<open>
   The head of the stack represents a (not necessarily maximal) SCC.
 \<close>
 lemma unite_subscc:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   assumes pre: "pre_dfss v e"
       and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
     shows "is_subscc (\<S> e' (hd (stack e')))"
 proof -
   from pre have wf: "wf_env e"
     by (simp add: pre_dfss_def)
   from assms obtain pfx where
     pfx: "stack e = pfx @ (stack e')" "stack e' \<noteq> []"
          "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
           in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
     by (blast dest: unite_stack[OF wf])
 
   define cc where "cc \<equiv> \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}"
 
   from wf w have "w \<in> \<Union> {\<S> e n | n. n \<in> set (stack e)}"
     by (simp add: wf_env_def)
   hence "w \<in> \<S> e (hd (stack e'))"
     apply (simp add: e'_def unite_def)
     by (metis dropWhile_eq_Nil_conv hd_dropWhile)
 
   have "is_subscc cc"
   proof (clarsimp simp: is_subscc_def)
     fix x y
     assume "x \<in> cc" "y \<in> cc"
     then obtain nx ny where
       nx: "nx \<in> set pfx \<union> {hd (stack e')}" "x \<in> \<S> e nx" and
       ny: "ny \<in> set pfx \<union> {hd (stack e')}" "y \<in> \<S> e ny"
       by (auto simp: cc_def)
     with wf have "reachable x nx" "reachable ny y"
       by (auto simp: wf_env_def is_subscc_def)
     from w pre have "reachable v w"
       by (auto simp: pre_dfss_def)
     from pre have "reachable (hd (stack e)) v"
       by (auto simp: pre_dfss_def wf_env_def is_subscc_def)
     from pre have "stack e = hd (stack e) # tl (stack e)"
       by (auto simp: pre_dfss_def)
     with nx \<open>stack e = pfx @ (stack e')\<close> \<open>stack e' \<noteq> []\<close>
     have "hd (stack e) \<preceq> nx in stack e"
       by (metis Un_iff Un_insert_right head_precedes list.exhaust_sel list.simps(15) 
                 set_append sup_bot.right_neutral)
     with wf have "reachable nx (hd (stack e))"
       by (auto simp: wf_env_def)
     from \<open>stack e = pfx @ (stack e')\<close> \<open>stack e' \<noteq> []\<close> ny
     have "ny \<preceq> hd (stack e') in stack e" 
       by (metis List.set_insert empty_set insert_Nil list.exhaust_sel set_append split_list_precedes)
     with wf have "reachable (hd (stack e')) ny"
       by (auto simp: wf_env_def is_subscc_def)
     from wf \<open>stack e' \<noteq> []\<close> \<open>w \<in> \<S> e (hd (stack e'))\<close>
     have "reachable w (hd (stack e'))"
       by (auto simp: wf_env_def is_subscc_def)
 
     from \<open>reachable x nx\<close> \<open>reachable nx (hd (stack e))\<close>
          \<open>reachable (hd (stack e)) v\<close> \<open>reachable v w\<close>
          \<open>reachable w (hd (stack e'))\<close> 
          \<open>reachable (hd (stack e')) ny\<close> \<open>reachable ny y\<close>
     show "reachable x y"
       using reachable_trans by meson
   qed
   with S_reflexive[OF wf, of "hd (stack e')"] pfx
   show ?thesis
     by (auto simp: cc_def)
 qed
 
 text \<open>
   The environment returned by function @{text unite} extends the input environment.
 \<close>
 
 lemma unite_sub_env:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   assumes pre: "pre_dfss v e"
         and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
   shows "sub_env e e'"
 proof -
   from pre have wf: "wf_env e"
     by (simp add: pre_dfss_def)
   from assms obtain pfx where
     pfx: "stack e = pfx @ (stack e')" "stack e' \<noteq> []"
          "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
           in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
     by (blast dest: unite_stack[OF wf])
   define cc where "cc \<equiv> \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}"
   have "\<forall>n. \<S> e n \<subseteq> \<S> e' n"
   proof (clarify)
     fix n u
     assume u: "u \<in> \<S> e n"
     show "u \<in> \<S> e' n"
     proof (cases "n \<in> cc")
       case True
       then obtain m where
         m: "m \<in> set pfx \<union> {hd (stack e')}" "n \<in> \<S> e m"
         by (auto simp: cc_def)
       with wf S_reflexive[OF wf, of n] u have "u \<in> \<S> e m"
         by (auto simp: wf_env_def)
       with m pfx show ?thesis 
         by (auto simp: cc_def)
     next
       case False
       with pfx u show ?thesis
         by (auto simp: cc_def)
     qed
   qed
   moreover
   have "root e' = root e \<and> visited e' = visited e
       \<and> explored e' = explored e \<and> vsuccs e' = vsuccs e"
     by (simp add: e'_def unite_def)
   ultimately show ?thesis
     using unite_S_equal[OF wf w]
     by (simp add: e'_def sub_env_def)
 qed
 
 text \<open>
   The environment returned by function @{text unite} is well-formed.
 \<close>
 lemma unite_wf_env:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   assumes pre: "pre_dfss v e"
       and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
   shows "wf_env e'"
 proof -
   from pre have wf: "wf_env e"
     by (simp add: pre_dfss_def)
   from assms obtain pfx where
     pfx: "stack e = pfx @ (stack e')" "stack e' \<noteq> []"
          "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
           in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
     by (blast dest: unite_stack[OF wf])
   define cc where "cc \<equiv> \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}"
 
   from pfx have Se': "\<forall>x. \<S> e' x = (if x \<in> cc then cc else \<S> e x)"
     by (auto simp add: cc_def)
 
   have cc_Un: "cc = \<Union> {\<S> e x | x. x \<in> cc}"
   proof
     from S_reflexive[OF wf]
     show "cc \<subseteq> \<Union> {\<S> e x | x. x \<in> cc}"
       by (auto simp: cc_def)
   next
     {
       fix n x
       assume "x \<in> cc" "n \<in> \<S> e x"
       with wf have "n \<in> cc"
         unfolding wf_env_def cc_def
         by (smt (verit) Union_iff mem_Collect_eq)
     }
     thus "(\<Union> {\<S> e x | x. x \<in> cc}) \<subseteq> cc"
       by blast
   qed
 
   from S_reflexive[OF wf, of "hd (stack e')"]
   have hd_cc: "\<S> e' (hd (stack e')) = cc"
     by (auto simp: cc_def Se')
 
   {
     fix n m
     assume n: "n \<in> set (tl (stack e'))"
        and m: "m \<in> \<S> e n \<inter> cc"
     from m obtain l where
       "l \<in> set pfx \<union> {hd (stack e')}" "m \<in> \<S> e l"
       by (auto simp: cc_def)
     with n m wf \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
     have "False"
       unfolding wf_env_def
       by (metis (no_types, lifting) Int_iff UnCI UnE disjoint_insert(1) distinct.simps(2) 
                 distinct_append emptyE hd_Cons_tl insert_iff list.set_sel(1) list.set_sel(2) 
                 mk_disjoint_insert set_append)
   }
   hence tl_cc: "\<forall>n \<in> set (tl (stack e')). \<S> e n \<inter> cc = {}"
     by blast
 
   from wf 
   have "\<forall>n \<in> visited e'. reachable (root e') n"
        "distinct (cstack e')"
        "explored e' \<subseteq> visited e'"
        "set (cstack e') \<subseteq> visited e'"
        "\<forall>n \<in> explored e'. \<forall>m. reachable n m \<longrightarrow> m \<in> explored e'"
        "\<forall>n. vsuccs e' n \<subseteq> successors n \<inter> visited e'"
        "\<forall>n. n \<notin> visited e' \<longrightarrow> vsuccs e' n = {}"
        "\<forall>n \<in> explored e'. vsuccs e' n = successors n"
        "\<forall>n \<in> visited e' - set (cstack e'). vsuccs e' n = successors n"
        "\<forall>S \<in> sccs e'. is_scc S"
        "\<Union> (sccs e') = explored e'"
     by (auto simp: wf_env_def e'_def unite_def)
 
   moreover
   from wf \<open>stack e = pfx @ stack e'\<close>
   have "distinct (stack e')"
     by (auto simp: wf_env_def)
 
   moreover
   have "\<forall>n m. n \<preceq> m in stack e' \<longrightarrow> n \<preceq> m in cstack e'"
   proof (clarify)
     fix n m
     assume "n \<preceq> m in stack e'"
     with \<open>stack e = pfx @ stack e'\<close> wf
     have "n \<preceq> m in cstack e"
       unfolding wf_env_def
       by (metis precedes_append_left)
     thus "n \<preceq> m in cstack e'"
       by (simp add: e'_def unite_def)
   qed
 
   moreover
   from wf \<open>stack e = pfx @ stack e'\<close>
   have "\<forall>n m. n \<preceq> m in stack e' \<longrightarrow> reachable m n"
     unfolding wf_env_def by (metis precedes_append_left)
 
   moreover
   have "\<forall>n m. m \<in> \<S> e' n \<longleftrightarrow> (\<S> e' n = \<S> e' m)"
   proof (clarify)
     fix n m
     show "m \<in> \<S> e' n \<longleftrightarrow> (\<S> e' n = \<S> e' m)"
     proof
       assume l: "m \<in> \<S> e' n"
       show "\<S> e' n = \<S> e' m"
       proof (cases "n \<in> cc")
         case True
         with l show ?thesis
           by (simp add: Se')
       next
         case False
         with l wf have "\<S> e n = \<S> e m"
           by (simp add: wf_env_def Se')
         with False cc_Un wf have "m \<notin> cc"
           unfolding wf_env_def e'_def
           by (smt (verit, best) Union_iff mem_Collect_eq)
         with \<open>\<S> e n = \<S> e m\<close> False show ?thesis
           by (simp add: Se')
       qed
     next
       assume r: "\<S> e' n = \<S> e' m"
       show "m \<in> \<S> e' n"
       proof (cases "n \<in> cc")
         case True
         with r pfx have "\<S> e' m = cc"
           by (auto simp: cc_def)
         have "m \<in> cc"
         proof (rule ccontr)
           assume "m \<notin> cc"
           with pfx have "\<S> e' m = \<S> e m"
             by (auto simp: cc_def)
           with S_reflexive[OF wf, of m] \<open>\<S> e' m = cc\<close> \<open>m \<notin> cc\<close>
           show "False"
             by simp
         qed
         with pfx True show "m \<in> \<S> e' n"
           by (auto simp: cc_def)
       next
         case False
         hence "\<S> e' n = \<S> e n"
           by (simp add: Se')
         have "m \<notin> cc"
         proof
           assume m: "m \<in> cc"
           with \<open>\<S> e' n = \<S> e n\<close> r have "\<S> e n = cc"
             by (simp add: Se')
           with S_reflexive[OF wf, of n] have "n \<in> cc"
             by simp
           with \<open>n \<notin> cc\<close> show "False" ..
         qed
         with r \<open>\<S> e' n = \<S> e n\<close> have "\<S> e m = \<S> e n"
           by (simp add: Se')
         with S_reflexive[OF wf, of m] have "m \<in> \<S> e n"
           by simp
         with \<open>\<S> e' n = \<S> e n\<close> show ?thesis
           by simp
       qed
     qed
   qed
 
   moreover
   have "\<forall>n. n \<notin> visited e' \<longrightarrow> \<S> e' n = {n}"
   proof (clarify)
     fix n
     assume "n \<notin> visited e'"
     hence "n \<notin> visited e"
       by (simp add: e'_def unite_def)
     moreover have "n \<notin> cc"
     proof
       assume "n \<in> cc"
       then obtain m where "m \<in> set pfx \<union> {hd (stack e')}" "n \<in> \<S> e m"
         by (auto simp: cc_def)
       with \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
       have "m \<in> set (stack e)"
         by auto
       with stack_class[OF wf this \<open>n \<in> \<S> e m\<close>] \<open>n \<notin> visited e\<close>
       show "False"
         by simp
     qed
     ultimately show "\<S> e' n = {n}"
       using wf by (auto simp: wf_env_def Se')
   qed
 
   moreover
   have "\<forall>n \<in> set (stack e'). \<forall>m \<in> set (stack e'). n \<noteq> m \<longrightarrow> \<S> e' n \<inter> \<S> e' m = {}"
   proof (clarify)
     fix n m
     assume "n \<in> set (stack e')" "m \<in> set (stack e')" "n \<noteq> m"
     show "\<S> e' n \<inter> \<S> e' m = {}"
     proof (cases "n = hd (stack e')")
       case True
       with \<open>m \<in> set (stack e')\<close> \<open>n \<noteq> m\<close> \<open>stack e' \<noteq> []\<close>
       have "m \<in> set (tl (stack e'))"
         by (metis hd_Cons_tl set_ConsD)
       with True hd_cc tl_cc unite_S_tl[OF wf w]
       show ?thesis
         by (auto simp: e'_def)
     next
       case False
       with \<open>n \<in> set (stack e')\<close> \<open>stack e' \<noteq> []\<close>
       have "n \<in> set (tl (stack e'))"
         by (metis hd_Cons_tl set_ConsD)
       show ?thesis
       proof (cases "m = hd (stack e')")
         case True
         with \<open>n \<in> set (tl (stack e'))\<close> hd_cc tl_cc unite_S_tl[OF wf w]
         show ?thesis
           by (auto simp: e'_def)
       next
         case False
         with \<open>m \<in> set (stack e')\<close> \<open>stack e' \<noteq> []\<close>
         have "m \<in> set (tl (stack e'))"
           by (metis hd_Cons_tl set_ConsD)
         with \<open>n \<in> set (tl (stack e'))\<close>
         have "\<S> e' m = \<S> e m \<and> \<S> e' n = \<S> e n"
           by (auto simp: e'_def unite_S_tl[OF wf w])
         moreover
         from \<open>m \<in> set (stack e')\<close> \<open>n \<in> set (stack e')\<close> \<open>stack e = pfx @ stack e'\<close>
         have "m \<in> set (stack e) \<and> n \<in> set (stack e)"
           by auto
         ultimately show ?thesis
           using wf \<open>n \<noteq> m\<close> by (auto simp: wf_env_def)
       qed
     qed
   qed
 
   moreover
   {
     from unite_S_equal[OF wf w]
     have "\<Union> {\<S> e' n | n. n \<in> set (stack e')} = \<Union> {\<S> e n | n. n \<in> set (stack e)}"
       by (simp add: e'_def)
     with wf
     have "\<Union> {\<S> e' n | n. n \<in> set (stack e')} = visited e - explored e"
       by (simp add: wf_env_def)
   }
   hence "\<Union> {\<S> e' n | n. n \<in> set (stack e')} = visited e' - explored e'"
     by (simp add: e'_def unite_def)
 
   moreover
   have "\<forall>n \<in> set (stack e'). \<forall>m \<in> \<S> e' n. 
            m \<in> set (cstack e') \<longrightarrow> m \<preceq> n in cstack e'"
   proof (clarify)
     fix n m
     assume "n \<in> set (stack e')" "m \<in> \<S> e' n" "m \<in> set (cstack e')"
     from \<open>m \<in> set (cstack e')\<close> have "m \<in> set (cstack e)"
       by (simp add: e'_def unite_def)
     have "m \<preceq> n in cstack e"
     proof (cases "n = hd (stack e')")
       case True
       with \<open>m \<in> \<S> e' n\<close> have "m \<in> cc"
         by (simp add: hd_cc)
       then obtain l where 
         "l \<in> set pfx \<union> {hd (stack e')}" "m \<in> \<S> e l"
         by (auto simp: cc_def)
       with \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
       have "l \<in> set (stack e)"
         by auto
       with \<open>m \<in> \<S> e l\<close> \<open>m \<in> set (cstack e)\<close> wf
       have "m \<preceq> l in cstack e"
         by (auto simp: wf_env_def)
       moreover
       from \<open>l \<in> set pfx \<union> {hd (stack e')}\<close> True 
            \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
       have "l \<preceq> n in stack e"
         by (metis List.set_insert empty_set hd_Cons_tl insert_Nil set_append split_list_precedes)
       with wf have "l \<preceq> n in cstack e"
         by (auto simp: wf_env_def)
       ultimately show ?thesis
         using wf unfolding wf_env_def
         by (meson precedes_trans)
     next
       case False
       with \<open>n \<in> set (stack e')\<close> \<open>stack e' \<noteq> []\<close>
       have "n \<in> set (tl (stack e'))"
         by (metis list.collapse set_ConsD)
       with unite_S_tl[OF wf w] \<open>m \<in> \<S> e' n\<close>
       have "m \<in> \<S> e n"
         by (simp add: e'_def)
       with \<open>n \<in> set (stack e')\<close> \<open>stack e = pfx @ stack e'\<close>
            \<open>m \<in> set (cstack e)\<close> wf
       show ?thesis
         by (auto simp: wf_env_def)
     qed
     thus "m \<preceq> n in cstack e'"
       by (simp add: e'_def unite_def)
   qed
 
   moreover
   have "\<forall>n m. n \<preceq> m in stack e' \<and> n \<noteq> m \<longrightarrow>
         (\<forall>u \<in> \<S> e' n. \<not> reachable_avoiding u m (unvisited e' n))"
   proof (clarify)
     fix x y u
     assume xy: "x \<preceq> y in stack e'" "x \<noteq> y"
        and u: "u \<in> \<S> e' x" "reachable_avoiding u y (unvisited e' x)"
     show "False"
     proof (cases "x = hd (stack e')")
       case True
       hence "\<S> e' x = cc" 
         by (simp add: hd_cc)
       with \<open>u \<in> \<S> e' x\<close> obtain x' where
         x': "x' \<in> set pfx \<union> {hd (stack e')}" "u \<in> \<S> e x'"
         by (auto simp: cc_def)
       from \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
       have "stack e = pfx @ (hd (stack e') # tl (stack e'))"
         by auto
       with x' True have "x' \<preceq> x in stack e"
         by (simp add: split_list_precedes)
       moreover
       from xy \<open>stack e = pfx @ stack e'\<close> have "x \<preceq> y in stack e"
         by (simp add: precedes_append_left)
       ultimately have "x' \<preceq> y in stack e"
         using wf by (auto simp: wf_env_def elim: precedes_trans)
       from \<open>x' \<preceq> x in stack e\<close> \<open>x \<preceq> y in stack e\<close> wf \<open>x \<noteq> y\<close>
       have "x' \<noteq> y"
         by (auto simp: wf_env_def dest: precedes_antisym)
       let ?unv = "\<Union> {unvisited e y | y. y \<in> set pfx \<union> {hd (stack e')}}"
       from \<open>\<S> e' x = cc\<close> have "?unv = unvisited e' x"
         by (auto simp: unvisited_def cc_def e'_def unite_def)
       with \<open>reachable_avoiding u y (unvisited e' x)\<close>
       have "reachable_avoiding u y ?unv"
         by simp
       with x' have "reachable_avoiding u y (unvisited e x')"
         by (blast intro: ra_mono)
       with \<open>x' \<preceq> y in stack e\<close> \<open>x' \<noteq> y\<close> \<open>u \<in> \<S> e x'\<close> wf
       show ?thesis
         by (auto simp: wf_env_def)
     next
       case False
       with \<open>x \<preceq> y in stack e'\<close> \<open>stack e' \<noteq> []\<close>
       have "x \<in> set (tl (stack e'))"
         by (metis list.exhaust_sel precedes_mem(1) set_ConsD)
       with \<open>u \<in> \<S> e' x\<close> have "u \<in> \<S> e x"
         by (auto simp add: unite_S_tl[OF wf w] e'_def)
       moreover
       from \<open>x \<preceq> y in stack e'\<close> \<open>stack e = pfx @ stack e'\<close>
       have "x \<preceq> y in stack e"
         by (simp add: precedes_append_left)
       moreover
       from unite_S_tl[OF wf w] \<open>x \<in> set (tl (stack e'))\<close>
       have "unvisited e' x = unvisited e x"
         by (auto simp: unvisited_def e'_def unite_def)
       ultimately show ?thesis
         using \<open>x \<noteq> y\<close> \<open>reachable_avoiding u y (unvisited e' x)\<close> wf
         by (auto simp: wf_env_def)
     qed
   qed
 
 
   moreover
   have "\<forall>n. is_subscc (\<S> e' n)"
   proof
     fix n
     show "is_subscc (\<S> e' n)"
     proof (cases "n \<in> cc")
       case True
       hence "\<S> e' n = cc"
         by (simp add: Se')
       with unite_subscc[OF pre w] hd_cc
       show ?thesis
         by (auto simp: e'_def)
     next
       case False
       with wf show ?thesis
         by (simp add: Se' wf_env_def)
     qed
   qed
 
   ultimately show ?thesis
     unfolding wf_env_def by blast
 qed
 
 subsection \<open>Lemmas establishing the pre-conditions\<close>
 
 text \<open>
   The precondition of function @{text dfs} ensures the precondition
   of @{text dfss} at the call of that function.
 \<close>
 lemma pre_dfs_pre_dfss:
   assumes "pre_dfs v e"
   shows "pre_dfss v (e\<lparr>visited := visited e \<union> {v}, 
                        stack := v # stack e, 
                        cstack := v # cstack e\<rparr>)"
         (is "pre_dfss v ?e'")
 proof -
   from assms have wf: "wf_env e"
     by (simp add: pre_dfs_def)
 
   from assms have v: "v \<notin> visited e"
     by (simp add: pre_dfs_def)
 
   from assms stack_visited[OF wf]
   have "\<forall>n \<in> visited ?e'. reachable (root ?e') n"
        "distinct (stack ?e')"
        "distinct (cstack ?e')"
        "explored ?e' \<subseteq> visited ?e'"
        "set (cstack ?e') \<subseteq> visited ?e'"
        "\<forall>n \<in> explored ?e'. \<forall>m. reachable n m \<longrightarrow> m \<in> explored ?e'"
        "\<forall>n. vsuccs ?e' n \<subseteq> successors n"
        "\<forall>n \<in> explored ?e'. vsuccs ?e' n = successors n"
        "\<forall>n \<in> visited ?e' - set(cstack ?e'). vsuccs ?e' n = successors n"
        "\<forall>n. n \<notin> visited ?e' \<longrightarrow> vsuccs ?e' n = {}"
        "(\<forall>n m. m \<in> \<S> ?e' n \<longleftrightarrow> (\<S> ?e' n = \<S> ?e' m))"
        "(\<forall>n. n \<notin> visited ?e' \<longrightarrow> \<S> ?e' n = {n})"
        "\<forall>n. is_subscc (\<S> ?e' n)"
        "\<forall>S \<in> sccs ?e'. is_scc S"
        "\<Union> (sccs ?e') = explored ?e'"
     by (auto simp: pre_dfs_def wf_env_def)
 
   moreover
   have "\<forall>n m. n \<preceq> m in stack ?e' \<longrightarrow> reachable m n"
   proof (clarify)
     fix x y
     assume "x \<preceq> y in stack ?e'"
     show "reachable y x"
     proof (cases "x=v")
       assume "x=v"
       with \<open>x \<preceq> y in stack ?e'\<close> assms show ?thesis
         apply (simp add: pre_dfs_def)
         by (metis insert_iff list.simps(15) precedes_mem(2) reachable_refl)
     next
       assume "x \<noteq> v"
       with \<open>x \<preceq> y in stack ?e'\<close> wf show ?thesis
         by (simp add: pre_dfs_def wf_env_def precedes_in_tail)
     qed
   qed
 
   moreover
   from wf v have "\<forall>n. vsuccs ?e' n \<subseteq> visited ?e'"
     by (auto simp: wf_env_def)
 
   moreover
   from wf v 
   have "(\<forall>n \<in> set (stack ?e'). \<forall> m \<in> set (stack ?e'). n \<noteq> m \<longrightarrow> \<S> ?e' n \<inter> \<S> ?e' m = {})"
     apply (simp add: wf_env_def)
     by (metis singletonD)
 
   moreover
   have "\<Union> {\<S> ?e' v | v . v \<in> set (stack ?e')} = visited ?e' - explored ?e'"
   proof -
     have "\<Union> {\<S> ?e' v | v . v \<in> set (stack ?e')} = 
           (\<Union> {\<S> e v | v . v \<in> set (stack e)}) \<union> \<S> e v"
       by auto
     also from wf v have "\<dots> = visited ?e' - explored ?e'"
       by (auto simp: wf_env_def)
     finally show ?thesis .
   qed
 
   moreover
   have "\<forall>n m. n \<preceq> m in stack ?e' \<and> n \<noteq> m \<longrightarrow>
            (\<forall>u \<in> \<S> ?e' n. \<not> reachable_avoiding u m (unvisited ?e' n))"
   proof (clarify)
     fix x y u
     assume asm: "x \<preceq> y in stack ?e'" "x \<noteq> y" "u \<in> \<S> ?e' x"
                 "reachable_avoiding u y (unvisited ?e' x)"
     show "False"
     proof (cases "x = v")
       case True
       with wf v \<open>u \<in> \<S> ?e' x\<close> have "u = v" "vsuccs ?e' v = {}"
         by (auto simp: wf_env_def)
       with \<open>reachable_avoiding u y (unvisited ?e' x)\<close>[THEN ra_cases]
            True \<open>x \<noteq> y\<close> wf
       show ?thesis
         by (auto simp: wf_env_def unvisited_def)
     next
       case False
       with asm wf show ?thesis
         by (auto simp: precedes_in_tail wf_env_def unvisited_def)
     qed
   qed
 
   moreover 
   have "\<forall>n m. n \<preceq> m in stack ?e' \<longrightarrow> n \<preceq> m in cstack ?e'"
   proof (clarsimp)
     fix n m
     assume "n \<preceq> m in (v # stack e)"
     with assms show "n \<preceq> m in (v # cstack e)"
       unfolding pre_dfs_def wf_env_def
       by (metis head_precedes insertI1 list.simps(15) precedes_in_tail precedes_mem(2) precedes_refl)
   qed
 
   moreover 
   have "\<forall>n \<in> set (stack ?e'). \<forall>m \<in> \<S> ?e' n. m \<in> set (cstack ?e') \<longrightarrow> m \<preceq> n in cstack ?e'"
   proof (clarify)
     fix n m
     assume "n \<in> set (stack ?e')" "m \<in> \<S> ?e' n" "m \<in> set (cstack ?e')"
     show "m \<preceq> n in cstack ?e'"
     proof (cases "n = v")
       case True
       with wf v \<open>m \<in> \<S> ?e' n\<close> show ?thesis
         by (auto simp: wf_env_def)
     next
       case False
       with \<open>n \<in> set (stack ?e')\<close> \<open>m \<in> \<S> ?e' n\<close>
       have "n \<in> set (stack e)" "m \<in> \<S> e n"
         by auto
       with wf v False \<open>m \<in> \<S> e n\<close> \<open>m \<in> set (cstack ?e')\<close>
       show ?thesis
         apply (simp add: wf_env_def)
         by (metis (mono_tags, lifting) precedes_in_tail singletonD)
     qed
   qed
 
   ultimately have "wf_env ?e'"
     unfolding wf_env_def by (meson le_inf_iff)
 
   moreover
   from assms 
   have "\<forall>w \<in> vsuccs ?e' v. w \<in> explored ?e' \<union> \<S> ?e' (hd (stack ?e'))"
     by (simp add: pre_dfs_def)
 
   moreover
   from \<open>\<forall>n m. n \<preceq> m in stack ?e' \<longrightarrow> reachable m n\<close>
   have "\<forall>n \<in> set (stack ?e'). reachable n v"
     by (simp add: head_precedes)
 
   moreover
   from wf v have "\<S> ?e' (hd (stack ?e')) = {v}"
     by (simp add: pre_dfs_def wf_env_def)
 
   ultimately show ?thesis
     by (auto simp: pre_dfss_def)
 qed
 
 text \<open>
   Similarly, we now show that the pre-conditions of the different
   function calls in the body of function @{text dfss} are satisfied.
   First, it is very easy to see that the pre-condition of @{text dfs}
   holds at the call of that function.
 \<close>
 lemma pre_dfss_pre_dfs:
   assumes "pre_dfss v e" and "w \<notin> visited e" and "w \<in> successors v"
   shows "pre_dfs w e" 
   using assms unfolding pre_dfss_def pre_dfs_def wf_env_def
   by (meson succ_reachable)
 
 text \<open>
   The pre-condition of @{text dfss} holds when the successor
   considered in the current iteration has already been explored.
 \<close>
 lemma pre_dfss_explored_pre_dfss:
   fixes e v w
   defines "e'' \<equiv> e\<lparr>vsuccs := (\<lambda>x. if x=v then vsuccs e v \<union> {w} else vsuccs e x)\<rparr>"
   assumes 1: "pre_dfss v e" and 2: "w \<in> successors v" and 3: "w \<in> explored e"
   shows "pre_dfss v e''"
 proof -
   from 1 have v: "v \<in> visited e"
     by (simp add: pre_dfss_def)
   have "wf_env e''"
   proof -
     from 1 have wf: "wf_env e"
       by (simp add: pre_dfss_def)
     hence "\<forall>v \<in> visited e''. reachable (root e'') v"
           "distinct (stack e'')"
           "distinct (cstack e'')"
           "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> n \<preceq> m in cstack e''"
           "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> reachable m n"
           "explored e'' \<subseteq> visited e''"
           "set (cstack e'') \<subseteq> visited e''"
           "\<forall>n \<in> explored e''. \<forall>m. reachable n m \<longrightarrow> m \<in> explored e''"
           "\<forall>n m. m \<in> \<S> e'' n \<longleftrightarrow> (\<S> e'' n = \<S> e'' m)"
           "\<forall>n. n \<notin> visited e'' \<longrightarrow> \<S> e'' n = {n}"
           "\<forall>n \<in> set (stack e''). \<forall> m \<in> set (stack e''). 
                 n \<noteq> m \<longrightarrow> \<S> e'' n \<inter> \<S> e'' m = {}"
           "\<Union> {\<S> e'' n | n. n \<in> set (stack e'')} = visited e'' - explored e''"
           "\<forall>n \<in> set (stack e''). \<forall>m \<in> \<S> e'' n. 
               m \<in> set (cstack e'') \<longrightarrow> m \<preceq> n in cstack e''"
           "\<forall>n. is_subscc (\<S> e'' n)"
           "\<forall>S \<in> sccs e''. is_scc S"
           "\<Union> (sccs e'') = explored e''"
       by (auto simp: wf_env_def e''_def)
     moreover
     from wf 2 3 have "\<forall>v. vsuccs e'' v \<subseteq> successors v \<inter> visited e''"
       by (auto simp: wf_env_def e''_def)
     moreover
     from wf v have "\<forall>n. n \<notin> visited e'' \<longrightarrow> vsuccs e'' n = {}"
       by (auto simp: wf_env_def e''_def)
     moreover
     from wf 2
     have "\<forall>v. v \<in> explored e'' \<longrightarrow> vsuccs e'' v = successors v"
       by (auto simp: wf_env_def e''_def)
     moreover
     have "\<forall>x y. x \<preceq> y in stack e'' \<and> x \<noteq> y \<longrightarrow>
              (\<forall>u \<in> \<S> e'' x. \<not> reachable_avoiding u y (unvisited e'' x))"
     proof (clarify)
       fix x y u
       assume "x \<preceq> y in stack e''" "x \<noteq> y" 
              "u \<in> \<S> e'' x"
              "reachable_avoiding u y (unvisited e'' x)"
       hence prec: "x \<preceq> y in stack e" "u \<in> \<S> e x"
         by (auto simp: e''_def)
       with stack_unexplored[OF wf] have "y \<notin> explored e"
         by (blast dest: precedes_mem)
       have "(unvisited e x = unvisited e'' x)
           \<or> (unvisited e x = unvisited e'' x \<union> {(v,w)})"
         by (auto simp: e''_def unvisited_def split: if_splits)
       thus "False"
       proof
         assume "unvisited e x = unvisited e'' x"
         with prec \<open>x \<noteq> y\<close> \<open>reachable_avoiding u y (unvisited e'' x)\<close> wf
         show ?thesis
           unfolding wf_env_def by metis
       next
         assume "unvisited e x = unvisited e'' x \<union> {(v,w)}"
         with wf \<open>reachable_avoiding u y (unvisited e'' x)\<close>
              \<open>y \<notin> explored e\<close> \<open>w \<in> explored e\<close> prec \<open>x \<noteq> y\<close>
         show ?thesis
           using avoiding_explored[OF wf] unfolding wf_env_def
           by (metis (no_types, lifting))
       qed
     qed
     moreover 
     from wf 2
     have "\<forall>n \<in> visited e'' - set (cstack e''). vsuccs e'' n = successors n"
       by (auto simp: e''_def wf_env_def)
     ultimately show ?thesis
       unfolding wf_env_def by meson
   qed
   with 1 3 show ?thesis
     by (auto simp: pre_dfss_def e''_def)
 qed
 
 text \<open>
   The call to @{text dfs} establishes the pre-condition for the
   recursive call to @{text dfss} in the body of @{text dfss}.
 \<close>
 lemma pre_dfss_post_dfs_pre_dfss:
   fixes e v w
   defines "e' \<equiv> dfs w e"
   defines "e'' \<equiv> e'\<lparr>vsuccs := (\<lambda>x. if x=v then vsuccs e' v \<union> {w} else vsuccs e' x)\<rparr>"
   assumes pre: "pre_dfss v e"
       and w: "w \<in> successors v" "w \<notin> visited e"
       and post: "post_dfs w e e'"
   shows "pre_dfss v e''"
 proof -
   from pre 
   have "wf_env e" "v \<in> visited e" "stack e \<noteq> []" "v \<in> \<S> e (hd (stack e))"
     by (auto simp: pre_dfss_def)
   with post have "stack e' \<noteq> []" "v \<in> \<S> e' (hd (stack e'))"
     by (auto dest: dfs_S_hd_stack)
   
   from post have "w \<in> visited e'"
     by (simp add: post_dfs_def)
 
   have "wf_env e''"
   proof -
     from post have wf': "wf_env e'"
       by (simp add: post_dfs_def)
     hence "\<forall>n \<in> visited e''. reachable (root e'') n"
           "distinct (stack e'')"
           "distinct (cstack e'')"
           "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> n \<preceq> m in cstack e''"
           "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> reachable m n"
           "explored e'' \<subseteq> visited e''"
           "set (cstack e'') \<subseteq> visited e''"
           "\<forall>n \<in> explored e''. \<forall>m. reachable n m \<longrightarrow> m \<in> explored e''"
           "\<forall>n m. m \<in> \<S> e'' n \<longleftrightarrow> (\<S> e'' n = \<S> e'' m)"
           "\<forall>n. n \<notin> visited e'' \<longrightarrow> \<S> e'' n = {n}"
           "\<forall>n \<in> set (stack e''). \<forall> m \<in> set (stack e''). 
               n \<noteq> m \<longrightarrow> \<S> e'' n \<inter> \<S> e'' m = {}"
           "\<Union> {\<S> e'' n | n. n \<in> set (stack e'')} = visited e'' - explored e''"
           "\<forall>n \<in> set (stack e''). \<forall> m \<in> \<S> e'' n. m \<in> set (cstack e'') \<longrightarrow> m \<preceq> n in cstack e''"
           "\<forall>n. is_subscc (\<S> e'' n)"
           "\<forall>S \<in> sccs e''. is_scc S"
           "\<Union> (sccs e'') = explored e''"
       by (auto simp: wf_env_def e''_def)
     moreover
     from wf' w have "\<forall>n. vsuccs e'' n \<subseteq> successors n"
       by (auto simp: wf_env_def e''_def)
     moreover 
     from wf' \<open>w \<in> visited e'\<close> have "\<forall>n. vsuccs e'' n \<subseteq> visited e''"
       by (auto simp: wf_env_def e''_def)
     moreover
     from post \<open>v \<in> visited e\<close>
     have "\<forall>n. n \<notin> visited e'' \<longrightarrow> vsuccs e'' n = {}"
       apply (simp add: post_dfs_def wf_env_def sub_env_def e''_def)
       by (meson subsetD)
     moreover
     from wf' w
     have "\<forall>n \<in> explored e''. vsuccs e'' n = successors n"
       by (auto simp: wf_env_def e''_def)
     moreover
     have "\<forall>n m. n \<preceq> m in stack e'' \<and> n \<noteq> m \<longrightarrow>
              (\<forall>u \<in> \<S> e'' n. \<not> reachable_avoiding u m (unvisited e'' n))"
     proof (clarify)
       fix x y u
       assume "x \<preceq> y in stack e''" "x \<noteq> y"
              "u \<in> \<S> e'' x"
              "reachable_avoiding u y (unvisited e'' x)"
       hence 1: "x \<preceq> y in stack e'" "u \<in> \<S> e' x"
         by (auto simp: e''_def)
       with stack_unexplored[OF wf'] have "y \<notin> explored e'"
         by (auto dest: precedes_mem)
       have "(unvisited e' x = unvisited e'' x)
           \<or> (unvisited e' x = unvisited e'' x \<union> {(v,w)})"
         by (auto simp: e''_def unvisited_def split: if_splits)
       thus "False"
       proof
         assume "unvisited e' x = unvisited e'' x"
         with 1 \<open>x \<noteq> y\<close> \<open>reachable_avoiding u y (unvisited e'' x)\<close> wf'
         show ?thesis
           unfolding wf_env_def by metis
       next
         assume unv: "unvisited e' x = unvisited e'' x \<union> {(v,w)}"
         from post
         have "w \<in> explored e' 
            \<or> (w \<in> \<S> e' (hd (stack e')) \<and> (\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n))"
           by (auto simp: post_dfs_def)
         thus ?thesis
         proof
           assume "w \<in> explored e'"
           with wf' unv \<open>reachable_avoiding u y (unvisited e'' x)\<close>
                \<open>y \<notin> explored e'\<close> 1 \<open>x \<noteq> y\<close>
           show ?thesis
             using avoiding_explored[OF wf'] unfolding wf_env_def
             by (metis (no_types, lifting))
         next
           assume w: "w \<in> \<S> e' (hd (stack e'))
                   \<and> (\<forall>n \<in> set (tl (stack e')). \<S> e' n = \<S> e n)"
           from \<open>reachable_avoiding u y (unvisited e'' x)\<close>[THEN ra_add_edge]
                unv
           have "reachable_avoiding u y (unvisited e' x)
               \<or> reachable_avoiding w y (unvisited e' x)"
             by auto
           thus ?thesis
           proof
             assume "reachable_avoiding u y (unvisited e' x)"
             with \<open>x \<preceq> y in stack e''\<close> \<open>x \<noteq> y\<close> \<open>u \<in> \<S> e'' x\<close> wf'
             show ?thesis
               by (auto simp: e''_def wf_env_def)
           next
             assume "reachable_avoiding w y (unvisited e' x)"
             from unv have "v \<in> \<S> e' x"
               by (auto simp: unvisited_def)
             from \<open>x \<preceq> y in stack e''\<close> have "x \<in> set (stack e')"
               by (simp add: e''_def precedes_mem)
             have "x = hd (stack e')"
             proof (rule ccontr)
               assume "x \<noteq> hd (stack e')"
               with \<open>x \<in> set (stack e')\<close> \<open>stack e' \<noteq> []\<close>
               have "x \<in> set (tl (stack e'))"
                 by (metis hd_Cons_tl set_ConsD)
               with w \<open>v \<in> \<S> e' x\<close> have "v \<in> \<S> e x"
                 by auto
               moreover
               from post \<open>stack e' \<noteq> []\<close> \<open>x \<in> set (stack e')\<close> \<open>x \<in> set (tl (stack e'))\<close>
               have "x \<in> set (tl (stack e))"
                 unfolding post_dfs_def
                 by (metis Un_iff self_append_conv2 set_append tl_append2)
               moreover
               from pre have "wf_env e" "stack e \<noteq> []" "v \<in> \<S> e (hd (stack e))"
                 by (auto simp: pre_dfss_def)
               ultimately show "False"
                 unfolding wf_env_def
                 by (metis (no_types, lifting) distinct.simps(2) hd_Cons_tl insert_disjoint(2) 
                           list.set_sel(1) list.set_sel(2) mk_disjoint_insert)
             qed
             with \<open>reachable_avoiding w y (unvisited e' x)\<close>
                  \<open>x \<preceq> y in stack e''\<close> \<open>x \<noteq> y\<close> w wf'
             show ?thesis
               by (auto simp add: e''_def wf_env_def)
           qed
         qed
       qed
     qed
 
     moreover
     from wf' \<open>\<forall>n. vsuccs e'' n \<subseteq> successors n\<close>
     have "\<forall>n \<in> visited e'' - set (cstack e''). vsuccs e'' n = successors n"
       by (auto simp: wf_env_def e''_def split: if_splits)
     ultimately show ?thesis
       unfolding wf_env_def by (meson le_inf_iff)
   qed
 
   show "pre_dfss v e''"
   proof -
     from pre post
     have "v \<in> visited e''"
       by (auto simp: pre_dfss_def post_dfs_def sub_env_def e''_def)
     moreover
     {
       fix u
       assume u: "u \<in> vsuccs e'' v"
       have "u \<in> explored e'' \<union> \<S> e'' (hd (stack e''))"
       proof (cases "u = w")
         case True
         with post show ?thesis
           by (auto simp: post_dfs_def e''_def)
       next
         case False
         with u pre post
         have "u \<in> explored e \<union> \<S> e (hd (stack e))"
           by (auto simp: pre_dfss_def post_dfs_def e''_def)
         then show ?thesis
         proof
           assume "u \<in> explored e"
           with post show ?thesis
             by (auto simp: post_dfs_def sub_env_def e''_def)
         next
           assume "u \<in> \<S> e (hd (stack e))"
           with \<open>wf_env e\<close> post \<open>stack e \<noteq> []\<close>
           show ?thesis
             by (auto simp: e''_def dest: dfs_S_hd_stack)
         qed
       qed
     }
     moreover
     from pre post
     have "\<forall>n \<in> set (stack e''). reachable n v"
       unfolding pre_dfss_def post_dfs_def
       using e''_def by force
     moreover
     from \<open>stack e' \<noteq> []\<close> have "stack e'' \<noteq> []"
       by (simp add: e''_def)
     moreover
     from \<open>v \<in> \<S> e' (hd (stack e'))\<close> have "v \<in> \<S> e'' (hd (stack e''))"
       by (simp add: e''_def)
     moreover
     from pre post have "\<exists>ns. cstack e'' = v # ns"
       by (auto simp: pre_dfss_def post_dfs_def e''_def)
     ultimately show ?thesis
       using \<open>wf_env e''\<close> unfolding pre_dfss_def by blast
   qed
 qed
 
 text \<open>
   Finally, the pre-condition for the recursive call to @{text dfss}
   at the end of the body of function @{text dfss} also holds if
   @{text unite} was applied.
 \<close>
 
 lemma pre_dfss_unite_pre_dfss:
   fixes e v w
   defines "e' \<equiv> unite v w e"
   defines "e'' \<equiv> e'\<lparr>vsuccs := (\<lambda>x. if x=v then vsuccs e' v \<union> {w} else vsuccs e' x)\<rparr>"
   assumes pre: "pre_dfss v e"
       and w: "w \<in> successors v" "w \<notin> vsuccs e v" "w \<in> visited e" "w \<notin> explored e"
   shows "pre_dfss v e''"
 proof -
   from pre have wf: "wf_env e"
     by (simp add: pre_dfss_def)
   from pre have "v \<in> visited e"
     by (simp add: pre_dfss_def)
   from pre w have "v \<notin> explored e"
     unfolding pre_dfss_def wf_env_def
     by (meson reachable_edge)
 
   from unite_stack[OF wf w] obtain pfx where
     pfx: "stack e = pfx @ stack e'" "stack e' \<noteq> []"
          "let cc = \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}
           in \<S> e' = (\<lambda>x. if x \<in> cc then cc else \<S> e x)"
          "w \<in> \<S> e' (hd (stack e'))"
     by (auto simp: e'_def)
   define cc where "cc \<equiv> \<Union> {\<S> e n |n. n \<in> set pfx \<union> {hd (stack e')}}"
 
   from unite_wf_env[OF pre w] have wf': "wf_env e'"
     by (simp add: e'_def)
 
   from \<open>stack e = pfx @ stack e'\<close> \<open>stack e' \<noteq> []\<close>
   have "hd (stack e) \<in> set pfx \<union> {hd (stack e')}"
     by (simp add: hd_append)
   with pre have "v \<in> cc"
     by (auto simp: pre_dfss_def cc_def)
   from S_reflexive[OF wf, of "hd (stack e')"]
   have "hd (stack e') \<in> cc"
     by (auto simp: cc_def)
   with pfx \<open>v \<in> cc\<close> have "v \<in> \<S> e' (hd (stack e'))"
     by (auto simp: cc_def)
 
   from unite_sub_env[OF pre w] have "sub_env e e'"
     by (simp add: e'_def)
 
   have "wf_env e''"
   proof -
     from wf'
     have "\<forall>n \<in> visited e''. reachable (root e'') n"
          "distinct (stack e'')" 
          "distinct (cstack e'')"
          "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> n \<preceq> m in cstack e''"
          "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> reachable m n"
          "explored e'' \<subseteq> visited e''"
          "set (cstack e'') \<subseteq> visited e''"
          "\<forall>n \<in> explored e''. \<forall>m. reachable n m \<longrightarrow> m \<in> explored e''"
          "\<forall>n m. m \<in> \<S> e'' n \<longleftrightarrow> (\<S> e'' n = \<S> e'' m)"
          "\<forall>n. n \<notin> visited e'' \<longrightarrow> \<S> e'' n = {n}"
          "\<forall>n \<in> set (stack e''). \<forall>m \<in> set (stack e''). 
              n \<noteq> m \<longrightarrow> \<S> e'' n \<inter> \<S> e'' m = {}"
          "\<Union> {\<S> e'' n | n. n \<in> set (stack e'')} = visited e'' - explored e''"
          "\<forall>n \<in> set (stack e''). \<forall>m \<in> \<S> e'' n. 
              m \<in> set (cstack e'') \<longrightarrow> m \<preceq> n in cstack e''"
          "\<forall>n. is_subscc (\<S> e'' n)"
          "\<forall>S \<in> sccs e''. is_scc S"
          "\<Union> (sccs e'') = explored e''"
       by (auto simp: wf_env_def e''_def)
 
     moreover
     from wf' w \<open>sub_env e e'\<close>
     have "\<forall>n. vsuccs e'' n \<subseteq> successors n \<inter> visited e''"
       by (auto simp: wf_env_def sub_env_def e''_def)
 
     moreover
     from wf' \<open>v \<in> visited e\<close> \<open>sub_env e e'\<close>
     have "\<forall>n. n \<notin> visited e'' \<longrightarrow> vsuccs e'' n = {}"
       by (auto simp: wf_env_def sub_env_def e''_def)
 
     moreover
     from wf' \<open>v \<notin> explored e\<close>
     have "\<forall>n \<in> explored e''. vsuccs e'' n = successors n"
       by (auto simp: wf_env_def e''_def e'_def unite_def)
 
     moreover
     from wf' \<open>w \<in> successors v\<close>
     have "\<forall>n \<in> visited e'' - set (cstack e''). vsuccs e'' n = successors n"
       by (auto simp: wf_env_def e''_def e'_def unite_def)
 
     moreover
     have "\<forall>x y. x \<preceq> y in stack e'' \<and> x \<noteq> y \<longrightarrow>
                 (\<forall>u \<in> \<S> e'' x. \<not> reachable_avoiding u y (unvisited e'' x))"
     proof (clarify)
       fix x y u
       assume xy: "x \<preceq> y in stack e''" "x \<noteq> y"
          and u: "u \<in> \<S> e'' x" "reachable_avoiding u y (unvisited e'' x)"
       hence prec: "x \<preceq> y in stack e'" "u \<in> \<S> e' x"
         by (simp add: e''_def)+
       show "False"
       proof (cases "x = hd (stack e')")
         case True
         with \<open>v \<in> \<S> e' (hd (stack e'))\<close>
         have "unvisited e' x = unvisited e'' x
             \<or> (unvisited e' x = unvisited e'' x \<union> {(v,w)})"
           by (auto simp: e''_def unvisited_def split: if_splits)
         thus "False"
         proof
           assume "unvisited e' x = unvisited e'' x"
           with prec \<open>x \<noteq> y\<close> \<open>reachable_avoiding u y (unvisited e'' x)\<close> wf'
           show ?thesis
             unfolding wf_env_def by metis
         next
           assume "unvisited e' x = unvisited e'' x \<union> {(v,w)}"
           with \<open>reachable_avoiding u y (unvisited e'' x)\<close>[THEN ra_add_edge]
           have "reachable_avoiding u y (unvisited e' x)
               \<or> reachable_avoiding w y (unvisited e' x)"
             by auto
           thus ?thesis
           proof
             assume "reachable_avoiding u y (unvisited e' x)"
             with prec \<open>x \<noteq> y\<close> wf' show ?thesis
               by (auto simp: wf_env_def)
           next
             assume "reachable_avoiding w y (unvisited e' x)"
             with \<open>x = hd (stack e')\<close> \<open>w \<in> \<S> e' (hd (stack e'))\<close> 
                  \<open>x \<preceq> y in stack e'\<close> \<open>x \<noteq> y\<close> wf'
             show ?thesis
               by (auto simp: wf_env_def)
           qed
         qed
       next
         case False
         with \<open>x \<preceq> y in stack e'\<close> \<open>stack e' \<noteq> []\<close>
         have "x \<in> set (tl (stack e'))"
           by (metis list.exhaust_sel precedes_mem(1) set_ConsD)
         with unite_S_tl[OF wf w] \<open>u \<in> \<S> e' x\<close>
         have "u \<in> \<S> e x"
           by (simp add: e'_def)
         moreover
         from \<open>x \<preceq> y in stack e'\<close> \<open>stack e = pfx @ stack e'\<close>
         have "x \<preceq> y in stack e"
           by (simp add: precedes_append_left)
         moreover
         from \<open>v \<in> \<S> e' (hd (stack e'))\<close> \<open>x \<in> set (tl (stack e'))\<close>
              \<open>stack e' \<noteq> []\<close> wf'
         have "v \<notin> \<S> e' x"
           unfolding wf_env_def
           by (metis (no_types, lifting) Diff_cancel Diff_triv distinct.simps(2) insert_not_empty 
                     list.exhaust_sel list.set_sel(1) list.set_sel(2) mk_disjoint_insert)
         hence "unvisited e'' x = unvisited e' x"
           by (auto simp: unvisited_def e''_def split: if_splits)
         moreover
         from \<open>x \<in> set (tl (stack e'))\<close> unite_S_tl[OF wf w]
         have "unvisited e' x = unvisited e x"
           by (simp add: unvisited_def e'_def unite_def)
         ultimately show ?thesis
           using \<open>x \<noteq> y\<close> \<open>reachable_avoiding u y (unvisited e'' x)\<close> wf
           by (auto simp: wf_env_def)
       qed
     qed
       
     ultimately show ?thesis
       unfolding wf_env_def by meson
   qed
 
   show "pre_dfss v e''"
   proof -
     from pre have "v \<in> visited e''"
       by (simp add: pre_dfss_def e''_def e'_def unite_def)
 
     moreover
     {
       fix u
       assume u: "u \<in> vsuccs e'' v"
       have "u \<in> explored e'' \<union> \<S> e'' (hd (stack e''))"
       proof (cases "u = w")
         case True
         with \<open>w \<in> \<S> e' (hd (stack e'))\<close> show ?thesis 
           by (simp add: e''_def)
       next
         case False
         with u have "u \<in> vsuccs e v"
           by (simp add: e''_def e'_def unite_def)
         with pre have "u \<in> explored e \<union> \<S> e (hd (stack e))"
           by (auto simp: pre_dfss_def)
         then show ?thesis
         proof
           assume "u \<in> explored e"
           thus ?thesis
             by (simp add: e''_def e'_def unite_def)
         next
           assume "u \<in> \<S> e (hd (stack e))"
           with \<open>hd (stack e) \<in> set pfx \<union> {hd (stack e')}\<close>
           have "u \<in> cc"
             by (auto simp: cc_def)
           moreover
           from S_reflexive[OF wf, of "hd (stack e')"] pfx
           have "\<S> e' (hd (stack e')) = cc"
             by (auto simp: cc_def)
           ultimately show ?thesis
             by (simp add: e''_def)
         qed
       qed
     }
     hence "\<forall>w \<in> vsuccs e'' v. w \<in> explored e'' \<union> \<S> e'' (hd (stack e''))"
       by blast
 
     moreover
     from pre \<open>stack e = pfx @ stack e'\<close>
     have "\<forall>n \<in> set (stack e''). reachable n v"
       by (auto simp: pre_dfss_def e''_def)
 
     moreover
     from \<open>stack e' \<noteq> []\<close> have "stack e'' \<noteq> []"
       by (simp add: e''_def)
 
     moreover
     from \<open>v \<in> \<S> e' (hd (stack e'))\<close> have "v \<in> \<S> e'' (hd (stack e''))"
       by (simp add: e''_def)
 
     moreover
     from pre have "\<exists>ns. cstack e'' = v # ns"
       by (auto simp: pre_dfss_def e''_def e'_def unite_def)
 
     ultimately show ?thesis
       using \<open>wf_env e''\<close> unfolding pre_dfss_def by blast
   qed
 qed
 
 subsection \<open>Lemmas establishing the post-conditions\<close>
 
 text \<open>
   Assuming the pre-condition of function @{text dfs} and the post-condition of
   the call to @{text dfss} in the body of that function, the post-condition of
   @{text dfs} is established.
 \<close>
 lemma pre_dfs_implies_post_dfs:
   fixes v e
   defines "e1 \<equiv> e\<lparr>visited := visited e \<union> {v}, 
                   stack := (v # stack e), 
                   cstack:=(v # cstack e)\<rparr>"
   defines "e' \<equiv> dfss v e1"
   defines "e'' \<equiv> e'\<lparr> cstack := tl(cstack e')\<rparr>"
   assumes 1: "pre_dfs v e"
       and 2: "dfs_dfss_dom (Inl(v, e))"
       and 3: "post_dfss v e1 e'"
   shows "post_dfs v e (dfs v e)"
 proof -
   from 1 have wf: "wf_env e"
     by (simp add: pre_dfs_def)
   from 1 have v: "v \<notin> visited e"
     by (simp add: pre_dfs_def)
   from 3 have wf': "wf_env e'"
     by (simp add: post_dfss_def)
   from 3 have cst': "cstack e' = v # cstack e"
     by (simp add: post_dfss_def e1_def)
   show ?thesis
   proof (cases "v = hd(stack e')")
     case True
     have notempty: "stack e' = v # stack e"
     proof -
       from 3 obtain ns where 
         ns: "stack e1 = ns @ (stack e')" "stack e' \<noteq> []"
         by (auto simp: post_dfss_def)
       have "ns = []"
       proof (rule ccontr)
         assume "ns \<noteq> []"
         with ns have "hd ns = v"
           apply (simp add: e1_def)
           by (metis hd_append2 list.sel(1))
         with True ns \<open>ns \<noteq> []\<close> have "\<not> distinct (stack e1)"
           by (metis disjoint_iff_not_equal distinct_append hd_in_set) 
         with wf v stack_visited[OF wf] show False
           by (auto simp: wf_env_def e1_def)
       qed
       with ns show ?thesis
         by (simp add: e1_def)
     qed
     have e2: "dfs v e = e'\<lparr>sccs := sccs e' \<union> {\<S> e' v}, 
                            explored := explored e' \<union> (\<S> e' v), 
                            stack := tl (stack e'),
                            cstack := tl (cstack e')\<rparr>" (is "_ = ?e2")
       using True 2 dfs.psimps[of v e] unfolding e1_def e'_def 
       by (fastforce simp: e1_def e'_def)
 
     have sub: "sub_env e e1"
       by (auto simp: sub_env_def e1_def)
 
     from notempty have stack2: "stack ?e2 = stack e"
       by (simp add: e1_def)
 
     moreover from 3 have "v \<in> visited ?e2"
       by (auto simp: post_dfss_def sub_env_def e1_def)
 
     moreover
     from sub 3 have "sub_env e e'"
       unfolding post_dfss_def by (auto elim: sub_env_trans)
     with stack2 have subenv: "sub_env e ?e2"
       by (fastforce simp: sub_env_def)
 
     moreover have "wf_env ?e2"
     proof -
       from wf' 
       have "\<forall>n \<in> visited ?e2. reachable (root ?e2) n"
            "distinct (stack ?e2)"
            "\<forall>n. vsuccs ?e2 n \<subseteq> successors n \<inter> visited ?e2"
            "\<forall>n. n \<notin> visited ?e2 \<longrightarrow> vsuccs ?e2 n = {}"
            "\<forall>n m. m \<in> \<S> ?e2 n \<longleftrightarrow> (\<S> ?e2 n = \<S> ?e2 m)"
            "\<forall>n. n \<notin> visited ?e2 \<longrightarrow> \<S> ?e2 n = {n}"
            "\<forall>n. is_subscc (\<S> ?e2 n)"
            "\<Union> (sccs ?e2) = explored ?e2"
         by (auto simp: wf_env_def distinct_tl)
 
       moreover
       from 1 cst' have "distinct (cstack ?e2)"
         by (auto simp: pre_dfs_def wf_env_def)
 
       moreover
       from 1 stack2 have "\<forall>n m. n \<preceq> m in stack ?e2 \<longrightarrow> reachable m n"
         by (auto simp: pre_dfs_def wf_env_def)
 
       moreover
       from 1 stack2 cst'
       have "\<forall>n m. n \<preceq> m in stack ?e2 \<longrightarrow> n \<preceq> m in cstack ?e2"
         by (auto simp: pre_dfs_def wf_env_def)
 
       moreover 
       from notempty wf' have "explored ?e2 \<subseteq> visited ?e2"
         apply (simp add: wf_env_def)
         using stack_class[OF wf']
         by (smt (verit, del_insts) Diff_iff insert_subset list.simps(15) subset_eq)
   
       moreover
       from 3 cst' have "set (cstack ?e2) \<subseteq> visited ?e2"
         by (simp add: post_dfss_def wf_env_def e1_def)
 
       moreover
       {
         fix u
         assume "u \<in> explored ?e2"
         have "vsuccs ?e2 u = successors u"
         proof (cases "u \<in> explored e'")
           case True
           with wf' show ?thesis
             by (auto simp: wf_env_def)
         next
           case False
           with \<open>u \<in> explored ?e2\<close> have "u \<in> \<S> e' v"
             by simp
           show ?thesis
           proof (cases "u = v")
             case True
             with 3 show ?thesis
               by (auto simp: post_dfss_def)
           next
             case False
             have "u \<in> visited e' - set (cstack e')"
             proof
               from notempty \<open>u \<in> \<S> e' v\<close> stack_class[OF wf'] False
               show "u \<in> visited e'"
                 by auto
             next
               show "u \<notin> set (cstack e')"
               proof
                 assume u: "u \<in> set (cstack e')"
                 with notempty \<open>u \<in> \<S> e' v\<close> \<open>wf_env e'\<close> have "u \<preceq> v in cstack e'"
                   by (auto simp: wf_env_def)
                 with cst' u False wf' show "False"
                   unfolding wf_env_def
                   by (metis head_precedes precedes_antisym)
               qed
             qed
             with 3 show ?thesis
               by (auto simp: post_dfss_def wf_env_def)
           qed
         qed
       }
       note explored_vsuccs = this
 
       moreover have "\<forall>n \<in> explored ?e2. \<forall>m. reachable n m \<longrightarrow> m \<in> explored ?e2"
       proof (clarify)
         fix x y
         assume asm: "x \<in> explored ?e2" "reachable x y"
         show "y \<in> explored ?e2"
         proof (cases "x \<in> explored e'")
           case True
           with \<open>wf_env e'\<close> \<open>reachable x y\<close> show ?thesis
             by (simp add: wf_env_def)
         next
           case False
           with asm have "x \<in> \<S> e' v"
              by simp
           with \<open>explored ?e2 \<subseteq> visited ?e2\<close> have "x \<in> visited e'"
             by auto
           from \<open>x \<in> \<S> e' v\<close> wf' have "reachable v x"
             by (auto simp: wf_env_def is_subscc_def)
           have "y \<in> visited e'"
           proof (rule ccontr)
             assume "y \<notin> visited e'"
             with reachable_visited[OF wf' \<open>x \<in> visited e'\<close> \<open>reachable x y\<close>]
             obtain n m where
               "n \<in> visited e'" "m \<in> successors n - vsuccs e' n"
               "reachable x n" "reachable m y"
               by blast
             from wf' \<open>m \<in> successors n - vsuccs e' n\<close>
             have "n \<notin> explored e'"
               by (auto simp: wf_env_def)
             obtain n' where
               "n' \<in> set (stack e')" "n \<in> \<S> e' n'"
               by (rule visited_unexplored[OF wf' \<open>n \<in> visited e'\<close> \<open>n \<notin> explored e'\<close>])
             have "n' = v"
             proof (rule ccontr)
               assume "n' \<noteq> v"
               with \<open>n' \<in> set (stack e')\<close> \<open>v = hd (stack e')\<close>
               have "n' \<in> set (tl (stack e'))"
                 by (metis emptyE hd_Cons_tl set_ConsD set_empty)
               moreover
               from \<open>n \<in> \<S> e' n'\<close> \<open>wf_env e'\<close> have "reachable n n'"
                 by (auto simp: wf_env_def is_subscc_def)
               with \<open>reachable v x\<close> \<open>reachable x n\<close> reachable_trans 
               have "reachable v n'"
                 by blast
               ultimately show "False"
                 using 3 \<open>v = hd (stack e')\<close> 
                 by (auto simp: post_dfss_def)
             qed
             with \<open>n \<in> \<S> e' n'\<close> \<open>m \<in> successors n - vsuccs e' n\<close> explored_vsuccs
             show "False"
               by auto
           qed
           show ?thesis
           proof (cases "y \<in> explored e'")
             case True
             then show ?thesis
               by simp
           next
             case False
             obtain n where ndef: "n \<in> set (stack e')" "(y \<in> \<S> e' n)"
               by (rule visited_unexplored[OF wf' \<open>y \<in> visited e'\<close> False])
             show ?thesis
             proof (cases "n = v")
               case True
               with ndef show ?thesis by simp
             next
               case False
               with ndef notempty have "n \<in> set (tl (stack e'))"
                 by simp
               moreover
               from wf' ndef have "reachable y n"
                 by (auto simp: wf_env_def is_subscc_def)
               with \<open>reachable v x\<close> \<open>reachable x y\<close>
               have "reachable v n"
                 by (meson reachable_trans)
               ultimately show ?thesis
                 using \<open>v = hd (stack e')\<close> 3 
                 by (simp add: post_dfss_def)
             qed
           qed
         qed
       qed
 
       moreover
       from 3 cst'
       have "\<forall>n \<in> visited ?e2 - set (cstack ?e2). vsuccs ?e2 n = successors n"
         apply (simp add: post_dfss_def wf_env_def)
         by (metis (no_types, lifting) Diff_empty Diff_iff empty_set insertE 
                   list.exhaust_sel list.sel(1) list.simps(15))
 
       moreover
       from wf' notempty
       have "\<forall>n m. n \<in> set (stack ?e2) \<and> m \<in> set (stack ?e2) \<and> n \<noteq> m 
                   \<longrightarrow> (\<S> ?e2 n \<inter> \<S> ?e2 m = {})"
         by (simp add: wf_env_def)
 
       moreover 
       have "\<Union> {\<S> ?e2 n | n . n \<in> set (stack ?e2)} = visited ?e2 - explored ?e2"
       proof -
         from wf' notempty
         have "(\<Union> {\<S> ?e2 n | n . n \<in> set (stack ?e2)}) \<inter> \<S> e' v = {}"
           by (auto simp: wf_env_def)
         with notempty
         have "\<Union> {\<S> ?e2 n | n . n \<in> set (stack ?e2)} =
               (\<Union> {\<S> e' n | n . n \<in> set (stack e')}) - \<S> e' v"
           by auto
         also from wf' 
         have "\<dots> = (visited e' - explored e') - \<S> e' v"
           by (simp add: wf_env_def)
         finally show ?thesis
           by auto
       qed
 
       moreover
       have "\<forall>n \<in> set (stack ?e2). \<forall>m \<in> \<S> ?e2 n. m \<in> set (cstack ?e2) \<longrightarrow> m \<preceq> n in cstack ?e2"
       proof (clarsimp simp: cst')
         fix n m
         assume "n \<in> set (tl (stack e'))"
                "m \<in> \<S> e' n" "m \<in> set (cstack e)"
         with 3 have "m \<in> \<S> e n"
           by (auto simp: post_dfss_def e1_def)
         with wf notempty \<open>n \<in> set (tl (stack e'))\<close> \<open>m \<in> set (cstack e)\<close>
         show "m \<preceq> n in cstack e"
           by (auto simp: wf_env_def)
       qed
 
       moreover
       {
         fix x y u
         assume xy: "x \<preceq> y in stack ?e2" "x \<noteq> y"
            and u: "u \<in> \<S> ?e2 x" "reachable_avoiding u y (unvisited ?e2 x)"
         from xy notempty stack2
         have "x \<preceq> y in stack e'"
           by (metis head_precedes insert_iff list.simps(15) precedes_in_tail precedes_mem(2))
         with wf' \<open>x \<noteq> y\<close> u have "False"
           by (auto simp: wf_env_def unvisited_def)
       }
 
       moreover have "\<forall>S \<in> sccs ?e2. is_scc S"
       proof (clarify)
         fix S
         assume asm: "S \<in> sccs ?e2"
         show "is_scc S"
         proof (cases "S = \<S> e' v")
           case True
           with S_reflexive[OF wf'] have "S \<noteq> {}"
             by blast
           from wf' True have subscc: "is_subscc S"
             by (simp add: wf_env_def)
           {
             assume "\<not> is_scc S"
             with \<open>S \<noteq> {}\<close> \<open>is_subscc S\<close> obtain S' where
               S'_def: "S' \<noteq> S" "S \<subseteq> S'" "is_subscc S'" 
               unfolding is_scc_def by blast
             then obtain x where "x \<in> S' \<and> x \<notin> S"
               by blast
             with True S'_def wf'
             have xv: "reachable v x \<and> reachable x v"
               unfolding wf_env_def is_subscc_def by (metis in_mono)
             from \<open>\<forall>v w. w \<in> \<S> ?e2 v \<longleftrightarrow> (\<S> ?e2 v = \<S> ?e2 w)\<close>
             have "v \<in> explored ?e2"
               by auto
             with \<open>\<forall>x \<in> explored ?e2. \<forall>y. reachable x y \<longrightarrow> y \<in> explored ?e2\<close>
                  xv \<open>S = \<S> e' v\<close> \<open>x \<in> S' \<and> x \<notin> S\<close>
             have "x \<in> explored e'"
               by auto
             with wf' xv have "v \<in> explored e'"
               by (auto simp: wf_env_def)
             with notempty have "False"
               by (auto intro: stack_unexplored[OF wf'])
           }
           then show ?thesis
             by blast
         next
           case False
           with asm wf' show ?thesis
             by (auto simp: wf_env_def)
         qed
       qed
 
       ultimately show ?thesis
         unfolding wf_env_def by meson
     qed
 
     moreover 
     from \<open>wf_env ?e2\<close> have "v \<in> explored ?e2"
       by (auto simp: wf_env_def)
 
     moreover
     from 3 have "vsuccs ?e2 v = successors v"
       by (simp add: post_dfss_def)
 
     moreover
     from 1 3 have "\<forall>w \<in> visited e. vsuccs ?e2 w = vsuccs e w"
       by (auto simp: pre_dfs_def post_dfss_def e1_def)
 
     moreover 
     from stack2 1 
     have "\<forall>n \<in> set (stack ?e2). reachable n v"
       by (simp add: pre_dfs_def)
 
     moreover 
     from stack2 have "\<exists>ns. stack e = ns @ (stack ?e2)"
       by auto
 
     moreover
     from 3 have "\<forall>n \<in> set (stack ?e2). \<S> ?e2 n = \<S> e n"
       by (auto simp: post_dfss_def e1_def)
 
     moreover
     from cst' have "cstack ?e2 = cstack e"
       by simp
 
     ultimately show ?thesis
       unfolding post_dfs_def using e2 by simp
   next
     case False
     with 2 have e': "dfs v e = e''"
       by (simp add: dfs.psimps e''_def e'_def e1_def)
 
     moreover have "wf_env e''"
     proof -
       from wf'
       have "\<forall>n \<in> visited e''. reachable (root e'') n"
            "distinct (stack e'')"
            "distinct (cstack e'')"
            "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> reachable m n"
            "explored e'' \<subseteq> visited e''"
            "\<forall>n \<in> explored e''. \<forall>m. reachable n m \<longrightarrow> m \<in> explored e''"
            "\<forall>n. vsuccs e'' n \<subseteq> successors n \<inter> visited e''"
            "\<forall>n. n \<notin> visited e'' \<longrightarrow> vsuccs e'' n = {}"
            "\<forall>n \<in> explored e''. vsuccs e'' n = successors n"
            "\<forall>n m. m \<in> \<S> e'' n \<longleftrightarrow> (\<S> e'' n = \<S> e'' m)"
            "\<forall>n. n \<notin> visited e'' \<longrightarrow> \<S> e'' n = {n}"
            "\<forall>n \<in> set (stack e''). \<forall>m \<in> set (stack e''). 
                n \<noteq> m \<longrightarrow> \<S> e'' n \<inter> \<S> e'' m = {}"
            "\<Union> {\<S> e'' n | n. n \<in> set (stack e'')} = visited e'' - explored e''"
            "\<forall>n. is_subscc (\<S> e'' n)"
            "\<forall>S \<in> sccs e''. is_scc S"
            "\<Union> (sccs e'') = explored e''"
         by (auto simp: e''_def wf_env_def distinct_tl)
 
       moreover have "\<forall>n m. n \<preceq> m in stack e'' \<longrightarrow> n \<preceq> m in cstack e''"
       proof (clarsimp simp add: e''_def)
         fix n m
         assume nm: "n \<preceq> m in stack e'"
         with 3 have "n \<preceq> m in cstack e'"
           unfolding post_dfss_def wf_env_def 
           by meson
         moreover
         have "n \<noteq> v"
         proof
           assume "n = v"
           with nm have "n \<in> set (stack e')"
             by (simp add: precedes_mem)
           with 3 \<open>n = v\<close> have "v = hd (stack e')"
             unfolding post_dfss_def wf_env_def
             by (metis (no_types, opaque_lifting) IntI equals0D list.set_sel(1))
           with \<open>v \<noteq> hd (stack e')\<close> show "False"
             by simp
         qed
         ultimately show "n \<preceq> m in tl (cstack e')"
           by (simp add: cst' precedes_in_tail)
       qed
 
       moreover
       from 3 have "set (cstack e'') \<subseteq> visited e''"
         by (simp add: post_dfss_def wf_env_def e''_def e1_def subset_eq)
 
       moreover 
       from 3
       have "\<forall>n \<in> visited e'' - set (cstack e''). vsuccs e'' n = successors n"
         apply (simp add: post_dfss_def wf_env_def e''_def e1_def)
         by (metis (no_types, opaque_lifting) DiffE DiffI set_ConsD)
 
       moreover 
       have "\<forall>n \<in> set (stack e''). \<forall>m \<in> \<S> e'' n. 
                m \<in> set (cstack e'') \<longrightarrow> m \<preceq> n in cstack e''"
       proof (clarsimp simp: e''_def)
         fix m n
         assume asm: "n \<in> set (stack e')" "m \<in> \<S> e' n" 
                     "m \<in> set (tl (cstack e'))"
         with wf' cst' have "m \<noteq> v" "m \<preceq> n in cstack e'"
           by (auto simp: wf_env_def)
         with cst' show "m \<preceq> n in tl (cstack e')"
           by (simp add: precedes_in_tail)
       qed
 
       moreover
       from wf'
       have "(\<forall>x y. x \<preceq> y in stack e'' \<and> x \<noteq> y \<longrightarrow>
                 (\<forall>u \<in> \<S> e'' x. \<not> reachable_avoiding u y (unvisited e'' x)))"
         by (force simp: e''_def wf_env_def unvisited_def)
 
       ultimately show ?thesis
         unfolding wf_env_def by blast
     qed
 
     moreover
     from 3 have "v \<in> visited e''"
       by (auto simp: post_dfss_def sub_env_def e''_def e1_def)
 
     moreover
     have subenv: "sub_env e e''"
     proof -
       have "sub_env e e1"
         by (auto simp: sub_env_def e1_def)
       with 3 have "sub_env e e'"
         by (auto simp: post_dfss_def elim: sub_env_trans)
       thus ?thesis
         by (auto simp add: sub_env_def e''_def)
     qed
 
     moreover
     from 3 have "vsuccs e'' v = successors v"
       by (simp add: post_dfss_def e''_def)
 
     moreover
     from 1 3 have "\<forall>w \<in> visited e. vsuccs e'' w = vsuccs e w"
       by (auto simp: pre_dfs_def post_dfss_def e1_def e''_def)
 
     moreover 
     from 3 have "\<forall>n \<in> set (stack e''). reachable n v"
       by (auto simp: e''_def post_dfss_def)
 
     moreover 
     from 3 \<open>v \<noteq> hd (stack e')\<close>
     have "\<exists>ns. stack e = ns @ (stack e'')"
       apply (simp add: post_dfss_def e''_def e1_def)
       by (metis append_Nil list.sel(1) list.sel(3) tl_append2)
 
     moreover
     from 3
     have "stack e'' \<noteq> []" "v \<in> \<S> e'' (hd (stack e''))"
          "\<forall>n \<in> set (tl (stack e'')). \<S> e'' n = \<S> e n"
       by (auto simp: post_dfss_def e1_def e''_def)
 
     moreover 
     from cst' have "cstack e'' = cstack e"
       by (simp add: e''_def)
 
     ultimately show ?thesis unfolding post_dfs_def
       by blast
   qed
 qed
 
 text \<open>
   The following lemma is central for proving
   partial correctness: assuming termination (represented by
   the predicate @{text dfs_dfss_dom}) and the pre-condition
   of the functions, both @{text dfs} and @{text dfss}
   establish their post-conditions. The first part of the
   theorem follows directly from the preceding lemma and the
   computational induction rule generated by Isabelle, the
   second part is proved directly, distinguishing the different
   cases in the definition of function @{text dfss}.
 \<close>
 lemma pre_post:
   shows
   "\<lbrakk>dfs_dfss_dom (Inl(v,e)); pre_dfs v e\<rbrakk> \<Longrightarrow> post_dfs v e (dfs v e)"
   "\<lbrakk>dfs_dfss_dom (Inr(v,e)); pre_dfss v e\<rbrakk> \<Longrightarrow> post_dfss v e (dfss v e)"
 proof (induct rule: dfs_dfss.pinduct)
   fix v e
   assume dom: "dfs_dfss_dom (Inl(v,e))"
      and predfs: "pre_dfs v e"
      and prepostdfss: "\<And>e1. \<lbrakk> e1 = e \<lparr>visited := visited e \<union> {v}, stack := v # stack e,
                                       cstack := v # cstack e\<rparr>; pre_dfss v e1 \<rbrakk>
                             \<Longrightarrow> post_dfss v e1 (dfss v e1)"
   then show "post_dfs v e (dfs v e)"
     using pre_dfs_implies_post_dfs pre_dfs_pre_dfss by auto
 next
   fix v e
   assume dom: "dfs_dfss_dom (Inr(v,e))"
      and predfss: "pre_dfss v e"
      and prepostdfs: 
            "\<And>vs w. 
              \<lbrakk> vs = successors v - vsuccs e v; vs \<noteq> {}; w = (SOME x. x \<in> vs); 
                w \<notin> explored e; w \<notin> visited e; pre_dfs w e \<rbrakk>
              \<Longrightarrow> post_dfs w e (dfs w e)"
      and prepostdfss:
            "\<And>vs w e' e''. 
              \<lbrakk> vs = successors v - vsuccs e v; vs \<noteq> {}; w = (SOME x. x \<in> vs); 
                e' = (if w \<in> explored e then e 
                      else if w \<notin> visited e then dfs w e 
                      else unite v w e); 
                e'' = e'\<lparr>vsuccs := \<lambda>x. if x = v then vsuccs e' v \<union> {w} 
                                       else vsuccs e' x\<rparr> ;
                pre_dfss v e'' \<rbrakk>
              \<Longrightarrow> post_dfss v e'' (dfss v e'')"
   show "post_dfss v e (dfss v e)"
   proof -
     let ?vs = "successors v - vsuccs e v"
     from predfss have wf: "wf_env e"
       by (simp add: pre_dfss_def)
     from predfss have "v \<in> visited e"
       by (simp add: pre_dfss_def)
     from predfss have "v \<notin> explored e"
       by (meson DiffD2 list.set_sel(1) pre_dfss_def stack_class)
 
     show ?thesis
     proof (cases "?vs = {}") 
       case True
       with dom have "dfss v e = e" 
         by (simp add: dfss.psimps)
       moreover 
       from True wf have "vsuccs e v = successors v"
         unfolding wf_env_def
         by (meson Diff_eq_empty_iff le_infE subset_antisym)
       moreover 
       have "sub_env e e"
         by (simp add: sub_env_def)
       moreover 
       from predfss \<open>vsuccs e v = successors v\<close>
       have "\<forall>w \<in> successors v. w \<in> explored e \<union> \<S> e (hd (stack e))"
            "\<forall>n \<in> set (stack e). reachable n v"
            "stack e \<noteq> []"
            "v \<in> \<S> e (hd (stack e))"
         by (auto simp: pre_dfss_def)
       moreover have "\<exists>ns. stack e = ns @ (stack e)"
         by simp
       moreover
       {
         fix n
         assume asm: "hd (stack e) = v"
                     "n \<in> set (tl (stack e))"
                     "reachable v n"
         with \<open>stack e \<noteq> []\<close> have "v \<preceq> n in stack e"
           by (metis head_precedes hd_Cons_tl list.set_sel(2))
         moreover
         from wf \<open>stack e \<noteq> []\<close> asm have "v \<noteq> n"
           unfolding wf_env_def
           by (metis distinct.simps(2) list.exhaust_sel)
         moreover
         from wf have "v \<in> \<S> e v"
           by (rule S_reflexive)
         moreover
         {
           fix a b
           assume "a \<in> \<S> e v" "b \<in> successors a - vsuccs e a"
           with \<open>vsuccs e v = successors v\<close> have "a \<noteq> v"
             by auto
           from \<open>stack e \<noteq> []\<close> \<open>hd (stack e) = v\<close> 
           have "v \<in> set (stack e)"
             by auto
           with \<open>a \<noteq> v\<close> \<open>a \<in> \<S> e v\<close> wf have "a \<in> visited e"
             unfolding wf_env_def by (metis singletonD)
           have "False"
           proof (cases "a \<in> set (cstack e)")
             case True
             with \<open>v \<in> set (stack e)\<close> \<open>a \<in> \<S> e v\<close> \<open>wf_env e\<close>
             have "a \<preceq> v in cstack e"
               by (auto simp: wf_env_def)
             moreover
             from predfss obtain ns where "cstack e = v # ns"
               by (auto simp: pre_dfss_def)
             moreover
             from wf have "distinct (cstack e)"
               by (simp add: wf_env_def)
             ultimately have "a = v"
               using tail_not_precedes by force 
             with \<open>a \<noteq> v\<close> show ?thesis ..
           next
             case False
             with \<open>a \<in> visited e\<close> wf have "vsuccs e a = successors a"
               by (auto simp: wf_env_def)
             with \<open>b \<in> successors a - vsuccs e a\<close> show ?thesis
               by simp
           qed
         }
         hence "unvisited e v = {}"
           by (auto simp: unvisited_def)
 
         ultimately have "\<not> reachable_avoiding v n {}"
           using wf unfolding wf_env_def by metis
         with \<open>reachable v n\<close> have "False"
           by (simp add: ra_empty)
       }
       ultimately show ?thesis
         using wf by (auto simp: post_dfss_def)
     next
       case vs_case: False
       define w where "w = (SOME x. x \<in> ?vs)"
       define e' where "e' = (if w \<in> explored e then e 
                              else if w \<notin> visited e then dfs w e 
                              else unite v w e)"
       define e'' where "e'' = (e'\<lparr>vsuccs := \<lambda>x. if x=v then vsuccs e' v \<union> {w} else vsuccs e' x\<rparr>)"
 
       from dom vs_case have dfss: "dfss v e = dfss v e''"
         apply (simp add: dfss.psimps e''_def)
         using e'_def w_def by auto
 
       from vs_case have wvs: "w \<in> ?vs"
         unfolding w_def by (metis some_in_eq)
       show ?thesis
       proof (cases "w \<in> explored e")
         case True
         hence e': "e' = e"
           by (simp add: e'_def)
         with predfss wvs True
         have "pre_dfss v e''"
           by (auto simp: e''_def pre_dfss_explored_pre_dfss)
         with prepostdfss vs_case 
         have post'': "post_dfss v e'' (dfss v e'')"
           by (auto simp: w_def e'_def e''_def)
 
         moreover
         from post''
         have "\<forall>u \<in> visited e - {v}. vsuccs (dfss v e'') u = vsuccs e u"
           by (auto simp: post_dfss_def e' e''_def)
 
         moreover
         have "sub_env e e''"
           by (auto simp: sub_env_def e' e''_def)
         with post'' have "sub_env e (dfss v e'')"
           by (auto simp: post_dfss_def elim: sub_env_trans)
 
         moreover
         from e' have "stack e'' = stack e" "\<S> e'' = \<S> e"
           by (auto simp add: e''_def)
 
         moreover
         have "cstack e'' = cstack e"
           by (simp add: e''_def e')
 
         ultimately show ?thesis
           by (auto simp: dfss post_dfss_def)
       next
         case notexplored: False
         then show ?thesis
         proof (cases "w \<notin> visited e")
           case True
           with e'_def notexplored have "e' = dfs w e"
             by auto
           with True notexplored pre_dfss_pre_dfs predfss 
                prepostdfs vs_case w_def
           have postdfsw: "post_dfs w e e'"
             by (metis DiffD1 some_in_eq)
           with predfss wvs True \<open>e' = dfs w e\<close>
           have "pre_dfss v e''"
             by (auto simp: e''_def pre_dfss_post_dfs_pre_dfss)
           with prepostdfss vs_case 
           have post'': "post_dfss v e'' (dfss v e'')"
             by (auto simp: w_def e'_def e''_def)
 
           moreover
           have "\<forall>u \<in> visited e - {v}. vsuccs (dfss v e'') u = vsuccs e u"
           proof
             fix u
             assume "u \<in> visited e - {v}"
             with postdfsw 
             have u: "vsuccs e' u = vsuccs e u" "u \<in> visited e'' - {v}"
               by (auto simp: post_dfs_def sub_env_def e''_def)
             with post'' have "vsuccs (dfss v e'') u = vsuccs e'' u"
               by (auto simp: post_dfss_def)
             with u show "vsuccs (dfss v e'') u = vsuccs e u"
               by (simp add: e''_def)
           qed
 
           moreover
           have "sub_env e (dfss v e'')"
           proof -
             from postdfsw have "sub_env e e'"
               by (simp add: post_dfs_def)
             moreover
             have "sub_env e' e''"
               by (auto simp: sub_env_def e''_def)
             moreover
             from post'' have "sub_env e'' (dfss v e'')"
               by (simp add: post_dfss_def)
             ultimately show ?thesis
               by (metis sub_env_trans)
           qed
 
           moreover
           from postdfsw post''
           have "\<exists>ns. stack e = ns @ (stack (dfss v e''))"
             by (auto simp: post_dfs_def post_dfss_def e''_def)
 
           moreover
           {
             fix n
             assume n: "n \<in> set (tl (stack (dfss v e'')))"
             with post'' have "\<S> (dfss v e'') n = \<S> e' n"
               by (simp add: post_dfss_def e''_def)
             moreover
             from \<open>pre_dfss v e''\<close> n post'' 
             have "stack e' \<noteq> [] \<and> n \<in> set (tl (stack e''))"
               apply (simp add: pre_dfss_def post_dfss_def e''_def)
               by (metis (no_types, lifting) Un_iff list.set_sel(2) self_append_conv2 set_append tl_append2)
             with postdfsw have "\<S> e' n = \<S> e n"
               apply (simp add: post_dfs_def e''_def)
               by (metis list.set_sel(2))
             ultimately have "\<S> (dfss v e'') n = \<S> e n"
               by simp
           }
 
           moreover
           from postdfsw have "cstack e'' = cstack e"
             by (auto simp: post_dfs_def e''_def)
 
           ultimately show ?thesis
             by (auto simp: dfss post_dfss_def)
 
         next
           case False
           hence e': "e' = unite v w e" using notexplored
             using e'_def by simp
           from False have "w \<in> visited e"
             by simp
           from wf wvs notexplored False obtain pfx where
             pfx: "stack e = pfx @ (stack e')" "stack e' \<noteq> []"
             unfolding e' by (blast dest: unite_stack)
 
           from predfss wvs notexplored False \<open>e' = unite v w e\<close>
           have "pre_dfss v e''"
             by (auto simp: e''_def pre_dfss_unite_pre_dfss)
 
           with prepostdfss vs_case \<open>e' = unite v w e\<close>  \<open>w \<notin> explored e\<close> \<open>w \<in> visited e\<close>
           have post'': "post_dfss v e'' (dfss v e'')"
             by (auto simp: w_def e''_def)
 
           moreover
           from post''
           have "\<forall>u \<in> visited e - {v}. vsuccs (dfss v e'') u = vsuccs e u"
             by (auto simp: post_dfss_def e''_def e' unite_def)
 
           moreover
           have "sub_env e (dfss v e'')"
           proof -
             from predfss wvs \<open>w \<in> visited e\<close> notexplored
             have "sub_env e e'"
               unfolding e' by (blast dest: unite_sub_env)
             moreover
             have "sub_env e' e''"
               by (auto simp: sub_env_def e''_def)
             moreover
             from post'' have "sub_env e'' (dfss v e'')"
               by (simp add: post_dfss_def)
             ultimately show ?thesis
               by (metis sub_env_trans)
           qed
 
           moreover
           from post'' \<open>stack e = pfx @ stack e'\<close>
           have "\<exists>ns. stack e = ns @ (stack (dfss v e''))"
             by (auto simp: post_dfss_def e''_def)
 
           moreover
           {
             fix n
             assume n: "n \<in> set (tl (stack (dfss v e'')))"
             with post'' have "\<S> (dfss v e'') n = \<S> e'' n"
               by (simp add: post_dfss_def)
             moreover
             from n post'' \<open>stack e' \<noteq> []\<close> 
             have "n \<in> set (tl (stack e''))"
               apply (simp add: post_dfss_def e''_def)
               by (metis (no_types, lifting) Un_iff list.set_sel(2) self_append_conv2 set_append tl_append2)
             with wf wvs \<open>w \<in> visited e\<close> notexplored
             have "\<S> e'' n = \<S> e n"
               by (auto simp: e''_def e' dest: unite_S_tl)
             ultimately have "\<S> (dfss v e'') n = \<S> e n"
               by simp
           }
 
           moreover
           from post'' have "cstack (dfss v e'') = cstack e"
             by (simp add: post_dfss_def e''_def e' unite_def)
 
           ultimately show ?thesis
             by (simp add: dfss post_dfss_def)
         qed
       qed
     qed
   qed
 qed
 
 text \<open>
   We can now show partial correctness of the algorithm:
   applied to some node @{text "v"} and the empty environment,
   it computes the set of strongly connected components in
   the subgraph reachable from node @{text "v"}. In particular,
   if @{text "v"} is a root of the graph, the algorithm computes
   the set of SCCs of the graph.
 \<close>
 
 theorem partial_correctness:
   fixes v
   defines "e \<equiv> dfs v (init_env v)"
   assumes "dfs_dfss_dom (Inl (v, init_env v))"
   shows "sccs e = {S . is_scc S \<and> (\<forall>n\<in>S. reachable v n)}"
     (is "_ = ?rhs")
 proof -
   from assms init_env_pre_dfs[of v]
   have post: "post_dfs v (init_env v) e"
     by (auto dest: pre_post)
   hence wf: "wf_env e"
     by (simp add: post_dfs_def)
   from post have "cstack e = []"
     by (auto simp: post_dfs_def init_env_def)
   have "stack e = []"
   proof (rule ccontr)
     assume "stack e \<noteq> []"
     hence "hd (stack e) \<preceq> hd (stack e) in stack e"
       by simp
     with wf \<open>cstack e = []\<close> show "False"
       unfolding wf_env_def
       by (metis empty_iff empty_set precedes_mem(2))
   qed
   with post have vexp: "v \<in> explored e"
     by (simp add: post_dfs_def)
   from wf \<open>stack e = []\<close> have "explored e = visited e"
     by (auto simp: wf_env_def)
   have "sccs e \<subseteq> ?rhs"
   proof
     fix S
     assume S: "S \<in> sccs e"
     with wf have "is_scc S"
       by (simp add: wf_env_def)
     moreover
     from S wf have "S \<subseteq> explored e"
       unfolding wf_env_def
       by blast
     with post \<open>explored e = visited e\<close> have "\<forall>n\<in>S. reachable v n"
       by (auto simp: post_dfs_def wf_env_def sub_env_def init_env_def)
     ultimately show "S \<in> ?rhs"
       by auto
   qed
   moreover
   {
     fix S
     assume "is_scc S" "\<forall>n\<in>S. reachable v n"
     from \<open>\<forall>n\<in>S. reachable v n\<close> vexp wf
     have "S \<subseteq> \<Union> (sccs e)"
       unfolding wf_env_def by (metis subset_eq)
     with \<open>is_scc S\<close> obtain S' where S': "S' \<in> sccs e \<and> S \<inter> S' \<noteq> {}"
       unfolding is_scc_def
       by (metis Union_disjoint inf.absorb_iff2 inf_commute)
     with wf have "is_scc S'"
       by (simp add: wf_env_def)
     with S' \<open>is_scc S\<close> have "S \<in> sccs e"
       by (auto dest: scc_partition)
   }
   ultimately show ?thesis by blast
 qed
 
 section \<open>Proof of termination and total correctness\<close>
 
 text \<open>
   We define a binary relation on the arguments of functions @{text dfs} and @{text dfss},
   and prove that this relation is well-founded and that all calls within
   the function bodies respect the relation, assuming that the pre-conditions
   of the initial function call are satisfied. By well-founded induction,
   we conclude that the pre-conditions of the functions are sufficient to
   ensure termination.
 
   Following the internal representation of the two mutually recursive
   functions in Isabelle as a single function on the disjoint sum of the
   types of arguments, our relation is defined as a set of argument pairs
   injected into the sum type. The left injection @{text Inl} takes
   arguments of function @{text dfs}, the right injection @{text Inr}
   takes arguments of function @{text dfss}.\footnote{Note that the
     types of the arguments of @{text dfs} and @{text dfss} are actually
     identical. We nevertheless use the sum type in order to remember
     the function that was called.}
   The conditions on the arguments in the definition of the relation
   overapproximate the arguments in the actual calls.
 \<close>
 
 definition dfs_dfss_term::"(('v \<times> 'v env + 'v \<times> 'v env) \<times> ('v \<times> 'v env + 'v \<times> 'v env)) set" where
   "dfs_dfss_term \<equiv>
     { (Inr(v, e1), Inl(v, e)) | v e e1. 
       v \<in> vertices - visited e \<and> visited e1 = visited e \<union> {v} }
   \<union> { (Inl(w, e), Inr(v, e)) | v w e. v \<in> vertices}
   \<union> { (Inr(v, e''), Inr(v, e)) | v e e''. 
        v \<in> vertices \<and> sub_env e e'' 
      \<and> (\<exists>w \<in> vertices. w \<notin> vsuccs e v \<and> w \<in> vsuccs e'' v)}"
 
 text \<open>
   Informally, termination is ensured because at each call,
   either a new vertex is visited (hence the complement of
   the set of visited nodes w.r.t. the finite set of vertices
   decreases) or a new successor is added to the set 
   @{text "vsuccs e v"} of some vertex @{text v}.
 
   In order to make this argument formal, we inject the argument
   tuples that appear in our relation into tuples consisting of
   the sets mentioned in the informal argument. However, there is
   one added complication because the call of @{text dfs} from
   @{text dfss} does not immediately add the vertex to the set
   of visited nodes (this happens only at the beginning of
   function @{text dfs}). We therefore add a third component of
   $0$ or $1$ to these tuples, reflecting the fact that there
   can only be one call of @{text dfs} from @{text dfss} for a
   given vertex @{text v}.
 \<close>
 
 fun dfs_dfss_to_tuple where
   "dfs_dfss_to_tuple (Inl(v::'v, e::'v env)) = 
    (vertices - visited e, vertices \<times> vertices - {(u,u') | u u'. u' \<in> vsuccs e u}, 0)"
 | "dfs_dfss_to_tuple (Inr(v::'v, e::'v env)) = 
    (vertices - visited e, vertices \<times> vertices - {(u,u') | u u'. u' \<in> vsuccs e u}, 1::nat)"
 
 
 text \<open>
   The triples defined in this way can be ordered lexicographically
   (with the first two components ordered as finite subsets and the
   third one following the predecessor relation on natural numbers).
   We prove that the injection of the above relation into sets
   of triples respects the lexicographic ordering and conclude that
   our relation is well-founded.
 \<close>
 
 lemma wf_term: "wf dfs_dfss_term"
 proof -
   let ?r = "(finite_psubset :: ('v set \<times> 'v set) set)
             <*lex*> (finite_psubset :: ((('v \<times> 'v) set) \<times> ('v \<times> 'v) set) set)
             <*lex*> pred_nat"
   have "wf (finite_psubset :: ('v set \<times> 'v set) set)"
     by (rule wf_finite_psubset)
   moreover
   have "wf (finite_psubset :: ((('v \<times> 'v) set) \<times> ('v \<times> 'v) set) set)"
     by (rule wf_finite_psubset)
   ultimately have "wf ?r"
     using wf_pred_nat by blast
   moreover
   have "dfs_dfss_term \<subseteq> inv_image ?r dfs_dfss_to_tuple"
   proof (clarify)
     fix a b
     assume "(a,b) \<in> dfs_dfss_term"
     hence "(\<exists>v w e e''. a = Inr(v,e'') \<and> b = Inr(v,e) \<and> v \<in> vertices \<and> sub_env e e''
                       \<and> w \<in> vertices \<and> w \<notin> vsuccs e v \<and> w \<in> vsuccs e'' v)
          \<or> (\<exists>v e e1. a = Inr(v,e1) \<and> b = Inl(v,e) \<and> v \<in> vertices - visited e 
                    \<and> visited e1 = visited e \<union> {v})
          \<or> (\<exists>v w e. a = Inl(w,e) \<and> b = Inr(v,e))"
          (is "?c1 \<or> ?c2 \<or> ?c3")
       by (auto simp: dfs_dfss_term_def)
     then show "(a,b) \<in> inv_image ?r dfs_dfss_to_tuple"
     proof
       assume "?c1"
       then obtain v w e e'' where
         ab: "a = Inr(v, e'')" "b = Inr(v,e)" and
         vw: "v \<in> vertices" "w \<in> vertices" "w \<in> vsuccs e'' v" "w \<notin> vsuccs e v" and
         sub: "sub_env e e''"
         by blast
       from sub have "vertices - visited e'' \<subseteq> vertices - visited e"
         by (auto simp: sub_env_def)
       moreover
       from sub vw
       have "(vertices \<times> vertices - {(u,u') | u u'. u' \<in> vsuccs e'' u})
           \<subset> (vertices \<times> vertices - {(u,u') | u u'. u' \<in> vsuccs e u})"
         by (auto simp: sub_env_def)
       ultimately show ?thesis
         using vfin ab by auto
     next
       assume "?c2 \<or> ?c3"
       with vfin show ?thesis
         by (auto simp: pred_nat_def)
     qed
   qed
   ultimately show ?thesis
     using wf_inv_image wf_subset by blast
 qed
 
 text \<open>
   The following theorem establishes sufficient conditions that ensure
   termination of the two functions @{text dfs} and @{text dfss}. 
   The proof proceeds by well-founded induction using the relation 
   @{text dfs_dfss_term}. Isabelle represents the termination domains
   of the functions by the predicate @{text dfs_dfss_dom} and
   generates a theorem @{text dfs_dfss.domintros} for proving
   membership of arguments in the termination domains. The
   actual formulation is a litte technical because the mutual
   induction must again be encoded in a single induction argument
   over the sum type representing the arguments of both functions.
 \<close>
 
 theorem dfs_dfss_termination:
   "\<lbrakk>v \<in> vertices ; pre_dfs v e\<rbrakk> \<Longrightarrow> dfs_dfss_dom(Inl(v, e))"
   "\<lbrakk>v \<in> vertices ; pre_dfss v e\<rbrakk> \<Longrightarrow> dfs_dfss_dom(Inr(v, e))"
 proof -
   { fix args
     have "(case args
           of Inl(v,e) \<Rightarrow> 
             v \<in> vertices \<and> pre_dfs v e
           |  Inr(v,e) \<Rightarrow> 
              v \<in> vertices \<and> pre_dfss v e)
         \<longrightarrow> dfs_dfss_dom args" (is "?P args \<longrightarrow> ?Q args")
     proof (rule wf_induct[OF wf_term])
       fix arg :: "('v \<times> 'v env) + ('v \<times> 'v env)"
       assume ih: "\<forall> arg'. (arg', arg) \<in> dfs_dfss_term \<longrightarrow> (?P arg' \<longrightarrow> ?Q arg')"
       show "?P arg \<longrightarrow> ?Q arg"
       proof
         assume P: "?P arg"
         show "?Q arg"
         proof (cases arg)
           case (Inl a)
           then obtain v e where a: "arg = Inl(v, e)" 
             using dfs.cases by metis
           with P have pre: "v \<in> vertices \<and> pre_dfs v e"
             by simp
           let ?e1 = "e\<lparr>visited := visited e \<union> {v}, stack := v # stack e, cstack := v # cstack e\<rparr>"
           let ?recarg = "Inr(v, ?e1)"
 
           from a pre
           have "(?recarg, arg) \<in> dfs_dfss_term"
             by (auto simp: pre_dfs_def dfs_dfss_term_def)
           moreover
           from pre have "?P ?recarg"
             by (auto dest: pre_dfs_pre_dfss)
           ultimately have "?Q ?recarg"
             using ih a by auto
           then have "?Q (Inl(v, e))"
             by (auto intro: dfs_dfss.domintros)
           then show ?thesis
             by (simp add: a)
         next
           case (Inr b)
           then obtain v e where b: "arg = Inr(v, e)" 
             using dfs.cases by metis
           with P have pre: "v \<in> vertices \<and> pre_dfss v e"
             by simp
           let ?sw = "SOME w. w \<in> successors v \<and> w \<notin> vsuccs e v"
           have "?Q (Inr(v, e))"
           proof (rule dfs_dfss.domintros)
             fix w
             assume "w \<in> successors v"
                    "?sw \<notin> explored e"
                    "?sw \<notin> visited e"
                    "\<not> dfs_dfss_dom (Inl (?sw, e))"
             show "w \<in> vsuccs e v"
             proof (rule ccontr)
               assume "w \<notin> vsuccs e v"
               with \<open>w \<in> successors v\<close> have sw: "?sw \<in> successors v - vsuccs e v"
                 by (metis (mono_tags, lifting) Diff_iff some_eq_imp)
               with pre \<open>?sw \<notin> visited e\<close> have "pre_dfs ?sw e"
                 by (blast intro: pre_dfss_pre_dfs)
               moreover
               from pre sw sclosed have "?sw \<in> vertices"
                 by blast
               moreover
               from pre have "(Inl(?sw,e), Inr(v,e)) \<in> dfs_dfss_term"
                 by (simp add: dfs_dfss_term_def)
               ultimately have "dfs_dfss_dom (Inl(?sw,e))"
                 using ih b by auto
               with \<open>\<not> dfs_dfss_dom (Inl (?sw, e))\<close> 
               show "False" ..
             qed
           next
             let ?e' = "dfs ?sw e"
             let ?e''= "?e'\<lparr>vsuccs := \<lambda>x. if x = v then vsuccs ?e' v \<union> {?sw} 
                                          else vsuccs ?e' x\<rparr>"
             fix w
             assume asm: "w \<in> successors v" "w \<notin> vsuccs e v"
                         "?sw \<notin> visited e" "?sw \<notin> explored e"
             from \<open>w \<in> successors v\<close> \<open>w \<notin> vsuccs e v\<close>
             have sw: "?sw \<in> successors v - vsuccs e v"
               by (metis (no_types, lifting) Diff_iff some_eq_imp)
             with pre \<open>?sw \<notin> visited e\<close> have "pre_dfs ?sw e"
               by (blast intro: pre_dfss_pre_dfs)
             moreover
             from pre sw sclosed have "?sw \<in> vertices"
               by blast
             moreover
             from pre have "(Inl(?sw, e), Inr(v,e)) \<in> dfs_dfss_term"
               by (simp add: dfs_dfss_term_def)
             ultimately have "dfs_dfss_dom (Inl(?sw, e))"
               using ih b by auto
             from this \<open>pre_dfs ?sw e\<close> have post: "post_dfs ?sw e ?e'"
               by (rule pre_post)
             hence "sub_env e ?e'"
               by (simp add: post_dfs_def)
             moreover
             have "sub_env ?e' ?e''"
               by (auto simp: sub_env_def)
             ultimately have "sub_env e ?e''"
               by (rule sub_env_trans)
             with pre \<open>?sw \<in> vertices\<close> sw
             have "(Inr(v, ?e''), Inr(v, e)) \<in> dfs_dfss_term"
               by (auto simp: dfs_dfss_term_def)
             moreover
             from pre post sw \<open>?sw \<notin> visited e\<close> have "pre_dfss v ?e''"
               by (blast intro: pre_dfss_post_dfs_pre_dfss)
             ultimately show "dfs_dfss_dom(Inr(v, ?e''))"
               using pre ih b by auto
           next
             let ?e'' =  "e\<lparr>vsuccs := \<lambda>x. if x = v then vsuccs e v \<union> {?sw} else vsuccs e x\<rparr>"
             fix w
             assume "w \<in> successors v" "w \<notin> vsuccs e v"
                    "?sw \<notin> visited e" "?sw \<in> explored e"
             with pre have "False"
               unfolding pre_dfss_def wf_env_def
               by (meson subsetD)
             thus "?Q (Inr(v, ?e''))"
               by simp 
           next
             fix w
             assume asm: "w \<in> successors v" "w \<notin> vsuccs e v"
                         "?sw \<in> visited e" "?sw \<in> explored e"
             let ?e'' =  "e\<lparr>vsuccs := \<lambda>x. if x = v then vsuccs e v \<union> {?sw} else vsuccs e x\<rparr>"
             let ?recarg = "Inr(v, ?e'')"
 
             from \<open>w \<in> successors v\<close> \<open>w \<notin> vsuccs e v\<close>
             have sw: "?sw \<in> successors v - vsuccs e v"
               by (metis (no_types, lifting) Diff_iff some_eq_imp)
 
             have "(?recarg, arg) \<in> dfs_dfss_term"
             proof -
               have "sub_env e ?e''"
                 by (auto simp: sub_env_def)
               moreover 
               from sw pre sclosed
               have "\<exists>u \<in> vertices. u \<notin> vsuccs e v \<and> u \<in> vsuccs ?e'' v"
                 by auto
               ultimately show ?thesis
                 using pre b unfolding dfs_dfss_term_def by blast
             qed
             
             moreover 
             from pre sw \<open>?sw \<in> explored e\<close> have "?P ?recarg"
               by (auto dest: pre_dfss_explored_pre_dfss)
 
             ultimately show "?Q ?recarg"
               using ih b by blast
           next
             fix w
             assume asm: "w \<in> successors v" "w \<notin> vsuccs e v"
                         "?sw \<in> visited e" "?sw \<notin> explored e"
             let ?eu = "unite v ?sw e"
             let ?e'' = "?eu\<lparr>vsuccs := \<lambda>x. if x = v then vsuccs ?eu v \<union> {?sw} else vsuccs ?eu x\<rparr>"
             let ?recarg = "Inr(v, ?e'')"
 
             from \<open>w \<in> successors v\<close> \<open>w \<notin> vsuccs e v\<close>
             have sw: "?sw \<in> successors v - vsuccs e v"
               by (metis (no_types, lifting) Diff_iff some_eq_imp)
 
             have "(?recarg, arg) \<in> dfs_dfss_term"
             proof -
               from pre asm sw have "sub_env e ?eu"
                 by (blast dest: unite_sub_env)
               hence "sub_env e ?e''"
                 by (auto simp: sub_env_def)
               moreover 
               from sw pre sclosed
               have "\<exists>u \<in> vertices. u \<notin> vsuccs e v \<and> u \<in> vsuccs ?e'' v"
                 by auto
               ultimately show ?thesis
                 using pre b unfolding dfs_dfss_term_def by blast
             qed
 
             moreover 
             from pre sw \<open>?sw \<in> visited e\<close> \<open>?sw \<notin> explored e\<close> have "?P ?recarg"
               by (auto dest: pre_dfss_unite_pre_dfss)
 
             ultimately show "?Q ?recarg"
               using ih b by auto
           qed
           then show ?thesis
             by (simp add: b)
         qed
       qed
     qed
   }
   note dom=this
   from dom
   show "\<lbrakk> v \<in> vertices ; pre_dfs v e\<rbrakk> \<Longrightarrow> dfs_dfss_dom(Inl(v, e))"
     by auto
   from dom
   show "\<lbrakk> v \<in> vertices ; pre_dfss v e\<rbrakk> \<Longrightarrow> dfs_dfss_dom(Inr(v, e))"
     by auto
 qed
 
 text \<open>
   Putting everything together, we prove the total correctness of
   the algorithm when applied to some (root) vertex.
 \<close>
 theorem correctness:
   assumes "v \<in> vertices"
   shows "sccs (dfs v (init_env v)) = {S . is_scc S \<and> (\<forall>n\<in>S. reachable v n)}"
   using assms init_env_pre_dfs[of v]
   by (simp add: dfs_dfss_termination partial_correctness)
 
 
 end
 end
diff --git a/thys/Stalnaker_Logic/Stalnaker_Logic.thy b/thys/Stalnaker_Logic/Stalnaker_Logic.thy
--- a/thys/Stalnaker_Logic/Stalnaker_Logic.thy
+++ b/thys/Stalnaker_Logic/Stalnaker_Logic.thy
@@ -1,603 +1,603 @@
 (*
   File:      Stalnaker_Logic.thy
   Author:    Laura Gamboa Guzman
 
   This work is a formalization of Stalnaker's epistemic logic
   and its soundness and completeness theorems, as well as the 
   equivalence between the axiomatization of S4 available in the Epistemic 
   Logic theory and the topological one.
   It builds on the Epistemic_Logic theory by A.H. From.
 *)
 
 theory Stalnaker_Logic
   imports "Epistemic_Logic.Epistemic_Logic"
 
 begin
 
 
 section \<open>Utility\<close>
 
 subsection \<open>Some properties of Normal Modal Logics\<close>
 
 lemma duality_taut: \<open>tautology (((K i p) \<^bold>\<longrightarrow> K i (\<^bold>\<not>q))\<^bold>\<longrightarrow> ((L i q) \<^bold>\<longrightarrow> (\<^bold>\<not> K i p)))\<close>
   by force
 
 lemma K_imp_trans: 
   assumes \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close>  \<open>A \<turnstile> (q \<^bold>\<longrightarrow> r)\<close>
   shows  \<open>A \<turnstile> (p \<^bold>\<longrightarrow> r)\<close>
 proof - 
   have \<open>tautology  ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ( (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow>  (p \<^bold>\<longrightarrow> r)))\<close>
     by fastforce
   then show ?thesis
     by (meson A1 R1 assms(1) assms(2))
 qed
 
 lemma K_imp_trans': 
   assumes \<open>A \<turnstile> (q \<^bold>\<longrightarrow> r)\<close>
   shows  \<open>A \<turnstile> ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> r))\<close>
 proof - 
   have \<open>tautology  ((q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> r)))\<close>
     by fastforce
   then show ?thesis 
     using A1 R1 assms by blast
 qed
 
 lemma K_imply_multi:
   assumes \<open>A \<turnstile> (a \<^bold>\<longrightarrow> b)\<close> and \<open>A \<turnstile> (a \<^bold>\<longrightarrow> c)\<close>
   shows \<open>A \<turnstile> (a \<^bold>\<longrightarrow> (b\<^bold>\<and>c))\<close>
 proof -
   have \<open>tautology ((a\<^bold>\<longrightarrow>b)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>c)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>(b\<^bold>\<and>c)))\<close>
     by force
   then have \<open>A \<turnstile> ((a\<^bold>\<longrightarrow>b)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>c)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>(b\<^bold>\<and>c)))\<close>
     using A1 by blast
   then have \<open>A \<turnstile> ((a\<^bold>\<longrightarrow>c)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>(b\<^bold>\<and>c)))\<close>
     using assms(1) R1 by blast
   then show ?thesis 
     using assms(2) R1 by blast
 qed
 
 lemma K_multi_imply:
   assumes \<open>A \<turnstile> (a \<^bold>\<longrightarrow> b \<^bold>\<longrightarrow> c)\<close>
   shows \<open>A \<turnstile> ((a\<^bold>\<and>b) \<^bold>\<longrightarrow> c)\<close>
 proof - 
   have \<open>tautology ((a \<^bold>\<longrightarrow> b \<^bold>\<longrightarrow> c) \<^bold>\<longrightarrow> ((a\<^bold>\<and>b) \<^bold>\<longrightarrow> c))\<close>
     by force
   then have \<open>A \<turnstile> ((a \<^bold>\<longrightarrow> b \<^bold>\<longrightarrow> c) \<^bold>\<longrightarrow> ((a\<^bold>\<and>b) \<^bold>\<longrightarrow> c))\<close>
     using A1 by blast
   then show ?thesis
     using assms R1 by blast 
 qed
 
 lemma K_thm: \<open>A \<turnstile> ((K i p) \<^bold>\<and> (L i q) \<^bold>\<longrightarrow> L i (p \<^bold>\<and> q))\<close>
 proof -
   have \<open>tautology (p \<^bold>\<longrightarrow> (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q)\<close>
     by force
   then have \<open>A \<turnstile> (p \<^bold>\<longrightarrow> (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q)\<close>
     by (simp add: A1)
   then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> K i ((\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q))\<close> 
         and \<open>A \<turnstile> (K i ((\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q) \<^bold>\<longrightarrow> K i (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> K i (\<^bold>\<not> q))\<close>
      apply (simp add: K_map)
     by (meson K_A2')
   then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> K i (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> K i (\<^bold>\<not> q))\<close> 
     using K_imp_trans by blast
   then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> L i (q) \<^bold>\<longrightarrow> L i (p \<^bold>\<and> q))\<close> 
     by (metis AK.simps K_imp_trans duality_taut)
   then show ?thesis
     by (simp add: K_multi_imply)
 qed
 
 primrec conjunct :: \<open>'i fm list \<Rightarrow> 'i fm\<close> where
   \<open>conjunct [] = \<^bold>\<top>\<close>
 | \<open>conjunct (p#ps) = (p \<^bold>\<and> conjunct ps)\<close>
 
 lemma imply_conjunct: \<open>tautology ((imply G p) \<^bold>\<longrightarrow> ((conjunct G) \<^bold>\<longrightarrow> p))\<close>
   apply(induction G) 
   apply simp
   by force
 
 lemma conjunct_imply: \<open>tautology (((conjunct G) \<^bold>\<longrightarrow> p) \<^bold>\<longrightarrow>(imply G p))\<close>
   by (induct G) simp_all
 
 lemma K_imply_conjunct:
   assumes \<open>A \<turnstile> imply G p\<close>
   shows \<open>A \<turnstile> ((conjunct G) \<^bold>\<longrightarrow> p)\<close>
   using A1 R1 assms imply_conjunct by blast
 
 lemma K_conjunct_imply:
   assumes \<open>A \<turnstile> ((conjunct G) \<^bold>\<longrightarrow> p)\<close>
   shows \<open>A \<turnstile> imply G p\<close>
   using A1 R1 assms conjunct_imply by blast
 
 lemma K_conj_imply_factor: 
   fixes A :: \<open>('i fm \<Rightarrow> bool)\<close>  
   shows \<open>A \<turnstile> ((((K i p) \<^bold>\<and> (K i q)) \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> r))\<close>
 proof -
   have *: \<open>A \<turnstile> ((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))\<close>
   proof (rule ccontr) 
     assume \<open>\<not> A \<turnstile> ((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))\<close>
     then have \<open>consistent A {\<^bold>\<not>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))}\<close>
       by (metis imply.simps(1) inconsistent_imply insert_is_Un list.set(1))
     let ?V = \<open>Extend A {\<^bold>\<not>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))}\<close> 
     let ?M = \<open>\<lparr>\<W> = mcss A, \<K> = reach A, \<pi> = pi\<rparr>\<close> 
     have \<open>?V \<in> \<W> ?M \<and> ?M, ?V \<Turnstile> \<^bold>\<not>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))\<close>
       using canonical_model \<open>consistent A {\<^bold>\<not> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> K i p \<^bold>\<and> K i q)}\<close> 
             insert_iff mem_Collect_eq by fastforce
     then have o: \<open>?M, ?V \<Turnstile> ((K i (p \<^bold>\<and> q)) \<^bold>\<and> \<^bold>\<not>((K i p) \<^bold>\<and> (K i q)))\<close>
       by auto
     then have \<open>?M, ?V \<Turnstile> (K i (p \<^bold>\<and> q))\<close> \<open>(?M, ?V \<Turnstile> \<^bold>\<not>(K i p)) \<or> (?M, ?V \<Turnstile> \<^bold>\<not>(K i q))\<close>
       by auto
     then have \<open>\<forall> U \<in> \<W> ?M \<inter> \<K> ?M i ?V. ?M, U \<Turnstile>(p \<^bold>\<and> q)\<close>
               \<open>\<exists> U \<in> \<W> ?M \<inter> \<K> ?M i ?V. ?M, U \<Turnstile> ((\<^bold>\<not>p) \<^bold>\<or> (\<^bold>\<not>q))\<close>
       using o by auto
     then show False 
       by simp
   qed
   then have \<open>A \<turnstile> (((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q))) \<^bold>\<longrightarrow>
                    ((((K i p) \<^bold>\<and> (K i q)) \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> ((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> r)))\<close>
     by (simp add: A1)
   then show ?thesis 
     using "*" R1 by blast
 qed
 
 lemma K_conjunction_in: \<open>A \<turnstile> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> K i q))\<close>
 proof -
   have o1: \<open>A \<turnstile> ((p\<^bold>\<and>q) \<^bold>\<longrightarrow> p)\<close> and o2: \<open>A \<turnstile> ((p\<^bold>\<and>q) \<^bold>\<longrightarrow> q)\<close>
     apply(simp add: A1)
     by (simp add: A1)
   then have c1: \<open>A \<turnstile> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> K i q)\<close> and c2: \<open>A \<turnstile> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> K i p)\<close> 
     apply (simp add: K_map o2)
     by (simp add: K_map o1)
   then show ?thesis
     by (simp add: K_imply_multi)
 qed
 
 lemma K_conjunction_in_mult:  \<open>A \<turnstile> ((K i (conjunct G)) \<^bold>\<longrightarrow> conjunct (map (K i) G))\<close>
 proof (induct G)
   case Nil
   then show ?case
     by (simp add: A1)
   case (Cons a G)
   then have \<open>A \<turnstile> ((K i (conjunct (a#G))) \<^bold>\<longrightarrow> (K i (a \<^bold>\<and> conjunct G)))\<close>
         and  \<open>A \<turnstile> ((K i (a \<^bold>\<and> conjunct G)) \<^bold>\<longrightarrow> ((K i a) \<^bold>\<and> K i (conjunct G)))\<close>
     apply (simp add: A1)
     by (metis K_conjunction_in)
   then have o1: \<open>A \<turnstile> ((K i (conjunct (a#G))) \<^bold>\<longrightarrow> ((K i a) \<^bold>\<and> K i (conjunct G)))\<close>
     using K_imp_trans by blast
   then have \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G)) \<^bold>\<longrightarrow> K i a)\<close> 
         and o2: \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G)) \<^bold>\<longrightarrow> conjunct (map (K i) G))\<close>
     apply (simp add: A1)
     by (metis Cons.hyps K_imply_Cons K_multi_imply imply.simps(1) imply.simps(2))
   then have \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G)) \<^bold>\<longrightarrow> (K i a) \<^bold>\<and> conjunct (map (K i) G))\<close>
     using K_imply_multi by blast
   then show ?case 
     using K_imp_trans o1 by auto
 qed
 
 lemma K_conjunction_out: \<open>A \<turnstile> ((K i p) \<^bold>\<and> (K i q) \<^bold>\<longrightarrow> K i (p \<^bold>\<and> q))\<close>
 proof -
   have \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p\<^bold>\<and>q)\<close>
     by (simp add: A1)
   then have \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p\<^bold>\<and>q)\<close>
     by (simp add: R2)
   then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> K i (q \<^bold>\<longrightarrow> p\<^bold>\<and>q))\<close>
     by (simp add: K_map \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p \<^bold>\<and> q)\<close>)
   then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> (K i q) \<^bold>\<longrightarrow> K i (p\<^bold>\<and>q))\<close>
     by (meson K_A2' K_imp_trans)
   then show ?thesis
     using K_multi_imply by blast
 qed
 
 lemma K_conjunction_out_mult: \<open>A \<turnstile> (conjunct (map (K i) G) \<^bold>\<longrightarrow> (K i (conjunct G)))\<close>
 proof (induct G)
   case Nil
   then show ?case
     by (metis A1 K_imply_conjunct Nil_is_map_conv R2 conjunct.simps(1) eval.simps(5) imply.simps(1))
   case (Cons a G)
   then have \<open>A \<turnstile> ((conjunct (map (K i) (a#G))) \<^bold>\<longrightarrow> ((K i a) \<^bold>\<and> conjunct (map (K i) G)))\<close>
     by (simp add: A1)
   then have *: \<open>A \<turnstile> (((K i a) \<^bold>\<and> conjunct (map (K i) G))\<^bold>\<longrightarrow> (K i a) \<^bold>\<and> K i (conjunct G))\<close>
     by (metis Cons.hyps K_imply_Cons K_imply_head K_imply_multi K_multi_imply imply.simps(1) imply.simps(2))
   then have \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G))\<^bold>\<longrightarrow> K i (conjunct (a#G)))\<close>
     by (simp add: K_conjunction_out)
   then show ?case
     using "*" K_imp_trans by auto
 qed
 
 subsection \<open>More on mcs's properties\<close>
 
 lemma mcs_conjunction: 
   assumes \<open>consistent A V\<close> and \<open>maximal A V\<close> 
   shows \<open>p \<in> V \<and> q \<in> V \<longrightarrow> (p \<^bold>\<and> q) \<in> V\<close>
 proof - 
   have \<open>tautology (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> (p\<^bold>\<and>q))\<close>
     by force  
   then have \<open>(p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> (p\<^bold>\<and>q)) \<in> V\<close>
     using A1 assms(1) assms(2) deriv_in_maximal by blast
   then have \<open>p \<in> V \<longrightarrow> (q \<^bold>\<longrightarrow> (p\<^bold>\<and>q)) \<in> V\<close>
     by (meson assms(1) assms(2) consequent_in_maximal)
   then show ?thesis
     using assms(1) assms(2) consequent_in_maximal by blast
 qed
 
 lemma mcs_conjunction_mult: 
  assumes \<open>consistent A V\<close> and \<open>maximal A V\<close> 
   shows \<open>(set (S :: ('i fm list)) \<subseteq> V \<and> finite (set S)) \<longrightarrow> (conjunct S) \<in> V\<close>
 proof(induct S)
   case Nil
   then show ?case
     by (metis K_Boole assms(1) assms(2) conjunct.simps(1) consistent_def inconsistent_subset maximal_def)
   case (Cons a S)
   then have \<open>set S \<subseteq> set (a#S)\<close>
     by (meson set_subset_Cons)
   then have c1: \<open> set (a # S) \<subseteq> V \<and> finite (set (a # S)) \<longrightarrow> conjunct (S) \<in> V \<and> a \<in> V\<close>
     using Cons by fastforce
   then have \<open> conjunct (S) \<in> V \<and> a \<in> V \<longrightarrow> (conjunct (a#S)) \<in> V \<close>
     using assms(1) assms(2) mcs_conjunction by auto
   then show ?case
     using c1 by fastforce
 qed
 
 lemma reach_dualK: 
   assumes \<open>consistent A V\<close> \<open>maximal A V\<close>
     and \<open>consistent A W\<close> \<open>maximal A W\<close> \<open>W \<in> reach A i V\<close>
   shows \<open>\<forall>p. p \<in> W \<longrightarrow> (L i p) \<in> V\<close>
 proof (rule ccontr)
   assume \<open>\<not> (\<forall>p. p \<in> W \<longrightarrow> (L i p) \<in> V)\<close>
   then obtain p' where *: \<open>p' \<in> W \<and> (L i p') \<notin> V\<close>
     by presburger
   then have \<open>(\<^bold>\<not> L i p') \<in> V\<close>
     using assms(1) assms(2) assms(3) assms(4) assms(5) exactly_one_in_maximal by blast
   then have \<open>K i (\<^bold>\<not> p') \<in> V\<close>
     using assms(1) assms(2) exactly_one_in_maximal by blast
   then have \<open>(\<^bold>\<not> p') \<in> W\<close>
     using assms(5) by blast
   then show False
     by (meson "*" assms(3) assms(4) exactly_one_in_maximal)
 qed 
 
 lemma dual_reach: 
   assumes \<open>consistent A V\<close> \<open>maximal A V\<close> 
   shows \<open>(L i p) \<in> V \<longrightarrow> (\<exists> W. W \<in> reach A i V \<and> p \<in> W)\<close>
 proof -
   have \<open>(\<nexists>W. W \<in> {W. known V i \<subseteq> W} \<and> p \<in> W) \<longrightarrow> (\<forall>W. W \<in> {W. known V i \<subseteq> W} \<longrightarrow> (\<^bold>\<not>p) \<in> W)\<close>
     by blast
   then have \<open>(\<forall>W. W \<in> {W. known V i \<subseteq> W} \<longrightarrow> (\<^bold>\<not>p) \<in> W) \<longrightarrow> (\<forall> W. W \<in> reach A i V \<longrightarrow> (\<^bold>\<not>p) \<in> W)\<close>
     by fastforce
   then have \<open>(\<forall> W. W \<in> reach A i V \<longrightarrow> (\<^bold>\<not>p) \<in> W) \<longrightarrow> ((K i (\<^bold>\<not>p)) \<in> V)\<close>
     by blast
   then have \<open>((K i (\<^bold>\<not>p)) \<in> V) \<longrightarrow> (\<not>((L i p) \<in> V))\<close>
     using assms(1) assms(2) exactly_one_in_maximal by blast
   then have \<open>(\<nexists>W. W \<in> {W. known V i \<subseteq> W} \<and> p \<in> W) \<longrightarrow> \<not>((L i p) \<in> V)\<close> 
     by blast
   then show ?thesis
     by blast
 qed
 
 
 section  \<open>Ax.2\<close>
 
 definition weakly_directed :: \<open>('i, 's) kripke \<Rightarrow> bool\<close> where
   \<open>weakly_directed M \<equiv> \<forall>i. \<forall>s \<in> \<W> M. \<forall>t \<in> \<W> M. \<forall>r \<in> \<W> M.
      (r \<in> \<K> M i s \<and> t \<in> \<K> M i s)\<longrightarrow>(\<exists> u \<in> \<W> M. (u \<in> \<K> M i r \<and> u \<in> \<K> M i t))\<close>
 
 inductive Ax_2 :: \<open>'i fm \<Rightarrow> bool\<close> where 
   \<open>Ax_2 (\<^bold>\<not> K i (\<^bold>\<not> K i p) \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i (\<^bold>\<not> p)))\<close> 
 
 subsection \<open>Soundness\<close>
 
 theorem weakly_directed:
   assumes \<open>weakly_directed M\<close> \<open>w \<in> \<W> M\<close>
   shows \<open>M, w \<Turnstile> (L i (K i p) \<^bold>\<longrightarrow> K i (L i p))\<close>
 proof 
   assume \<open>M, w \<Turnstile> (L i (K i p))\<close>
   then have \<open>\<exists>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> K i p\<close> 
     by simp
   then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. \<exists>u \<in> \<W> M \<inter> \<K> M i v. M, u \<Turnstile> p\<close>
     using \<open>weakly_directed M\<close> \<open>w \<in> \<W> M\<close> unfolding weakly_directed_def
     by (metis IntE IntI semantics.simps(6)) 
   then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> L i p\<close>
     by simp
   then show \<open>M, w \<Turnstile> K i (L i p)\<close>
     by simp
 qed
 
 lemma soundness_Ax_2: \<open>Ax_2 p \<Longrightarrow> weakly_directed M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
   by (induct p rule: Ax_2.induct) (meson weakly_directed)
 
 subsection \<open>Imply completeness\<close>
 
 lemma Ax_2_weakly_directed:
   fixes A :: \<open>'i fm \<Rightarrow> bool\<close>
   assumes \<open>\<forall>p. Ax_2 p \<longrightarrow> A p\<close> \<open>consistent A V\<close> \<open>maximal A V\<close>
     and \<open>consistent A W\<close> \<open>maximal A W\<close> \<open>consistent A U\<close> \<open>maximal A U\<close>
     and \<open>W \<in> reach A i V\<close> \<open>U \<in> reach A i V\<close>
   shows \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> X \<in> (reach A i W) \<inter> (reach A i U)\<close>
 proof (rule ccontr)
   assume \<open>\<not> ?thesis\<close>
   let ?S = \<open>(known W i) \<union> (known U i)\<close>
   have \<open>\<not> consistent A ?S\<close> 
     by (smt (verit, best) Int_Collect \<open>\<nexists>X. consistent A X \<and> maximal A X \<and> X \<in> {Wa. known W i \<subseteq> Wa} \<inter> {W. known U i \<subseteq> W}\<close> maximal_extension mem_Collect_eq sup.bounded_iff)
   then obtain S' where *: \<open>A \<turnstile> imply S' \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> ?S\<close> \<open>finite (set S')\<close>
     unfolding consistent_def by blast 
   let ?U = \<open>filter (\<lambda>p. p \<in> (known U i)) S'\<close>
   let ?W = \<open>filter (\<lambda>p. p \<in> (known W i)) S'\<close>
   let ?p = \<open>conjunct ?U\<close> and ?q = \<open>conjunct ?W\<close>
   have \<open>(set ?U) \<union> (set ?W) = (set S')\<close>
     using * by auto
   then have \<open>A \<turnstile> imply ?U (imply ?W \<^bold>\<bottom>)\<close>
     using K_imply_weaken imply_append  
     by (metis (mono_tags, lifting) "*"(1) set_append subset_refl) 
   then have \<open>A \<turnstile> (?p \<^bold>\<longrightarrow> (imply ?W \<^bold>\<bottom>))\<close>
     using K_imply_conjunct by blast
   then have \<open>tautology ((imply ?W \<^bold>\<bottom>) \<^bold>\<longrightarrow> (?q \<^bold>\<longrightarrow> \<^bold>\<bottom>))\<close>
     using imply_conjunct by blast
   then have \<open>A \<turnstile> ((imply ?W \<^bold>\<bottom>) \<^bold>\<longrightarrow> (?q \<^bold>\<longrightarrow> \<^bold>\<bottom>))\<close>
     using A1 by blast
   then have \<open>A \<turnstile> (?p \<^bold>\<longrightarrow> (?q \<^bold>\<longrightarrow> \<^bold>\<bottom>))\<close>
     using K_imp_trans \<open>A \<turnstile> (conjunct (filter (\<lambda>p. p \<in> known U i) S') \<^bold>\<longrightarrow> imply (filter (\<lambda>p. p \<in> known W i) S') \<^bold>\<bottom>)\<close>
     by blast 
   then have o1: \<open>A \<turnstile> ((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>)\<close>
     by (meson K_multi_imply)
   moreover have \<open>set ?U \<subseteq> (known U i)\<close> and \<open>set ?W \<subseteq> (known W i)\<close> 
                 and \<open>\<forall> p. p \<in> set ?U \<longrightarrow> (K i p) \<in> U\<close> and \<open>\<forall> p. p \<in> set ?W \<longrightarrow> (K i p) \<in> W\<close> 
     by auto
   then have \<open>set (map (K i) ?U) \<subseteq> U\<close> and c1: \<open>set (map (K i) ?W) \<subseteq> W\<close>
      apply (metis (mono_tags, lifting) imageE set_map subsetI) 
     by auto
   then have c2: \<open>conjunct (map (K i) ?U) \<in> U\<close> and c2': \<open>conjunct (map (K i) ?W) \<in> W\<close>
     using assms(6) assms(7) mcs_conjunction_mult apply blast
     using assms(4) assms(5) c1 mcs_conjunction_mult by blast
   then have \<open>((conjunct (map (K i) ?U)) \<^bold>\<longrightarrow> (K i ?p)) \<in> U\<close> 
         and c3: \<open>((conjunct (map (K i) ?W)) \<^bold>\<longrightarrow> (K i ?q)) \<in> W\<close> 
     apply (meson K_conjunction_out_mult assms(6) assms(7) deriv_in_maximal)
     by (meson K_conjunction_out_mult assms(4) assms(5) deriv_in_maximal)
   then have c4: \<open>(K i ?p) \<in> U\<close> and c4': \<open>(K i ?q) \<in> W\<close>
     using assms(6) assms(7) c2 consequent_in_maximal apply blast
     using assms(4) assms(5) c2' c3 consequent_in_maximal by blast
   then have \<open>(L i (K i ?p)) \<in> V\<close> and c5: \<open>(L i (K i ?q)) \<in> V\<close> 
     using assms(2) assms(3) assms(6) assms(7) assms(9) exactly_one_in_maximal apply blast
     using assms(2) assms(3) assms(4) assms(5) assms(8) c4' exactly_one_in_maximal by blast
   then have \<open>(K i (L i ?p)) \<in> V\<close>
     by (meson Ax_2.intros assms(1) assms(2) assms(3) ax_in_maximal consequent_in_maximal)
   then have \<open>((K i (L i ?p)) \<^bold>\<and> (L i (K i ?q))) \<in> V\<close>
     using assms(2) assms(3) c5 mcs_conjunction by blast
   then have \<open>(L i ((L i ?p) \<^bold>\<and> K i ?q)) \<in> V\<close>
     by (meson K_thm assms(2) assms(3) consequent_in_maximal deriv_in_maximal)
   then have \<open>(L i ((K i ?q) \<^bold>\<and> L i ?p)) \<in> V\<close>
-    by (smt (z3) \<open>K i (L i (conjunct (filter (\<lambda>p. p \<in> known U i) S'))) \<in> V\<close> assms(2) assms(3) assms(4) assms(5) assms(8) c4' exactly_one_in_maximal mcs_conjunction mem_Collect_eq subset_iff)
+    by (smt (verit) \<open>K i (L i (conjunct (filter (\<lambda>p. p \<in> known U i) S'))) \<in> V\<close> assms(2) assms(3) assms(4) assms(5) assms(8) c4' exactly_one_in_maximal mcs_conjunction mem_Collect_eq subset_iff)
   then obtain Z' where z1:\<open>(consistent A Z') \<and> (maximal A Z')\<close> and z2:\<open>Z' \<in> (reach A i V)\<close> 
                   and z3: \<open>((K i ?q) \<^bold>\<and> L i ?p) \<in> Z'\<close>
     using \<open>K i (L i (conjunct (filter (\<lambda>p. p \<in> known U i) S'))) \<in> V\<close> assms(4) assms(5) assms(8) c4' mcs_conjunction by blast
   then have z4: \<open>(L i (?q \<^bold>\<and> ?p)) \<in> Z'\<close>
     by (metis K_thm consequent_in_maximal deriv_in_maximal)
   then have o2:\<open>(L i (L i (?q \<^bold>\<and> ?p))) \<in> V\<close>
     using assms(2) assms(3) mcs_properties(2) z1 z2 by blast
   then have \<open>A \<turnstile> K i (K i (((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>)))\<close> 
     by (metis R2 o1)
   then have o3:\<open>K i (K i (((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>))) \<in> V\<close>
     using assms(2) assms(3) deriv_in_maximal by blast
   then obtain X1 where x1:\<open>(consistent A X1) \<and> (maximal A X1)\<close> and x2:\<open>X1 \<in> (reach A i V)\<close> 
                   and x3: \<open>(L i (?q \<^bold>\<and> ?p)) \<in> X1\<close>
     using z1 z2 z4 by blast
   then have x4:\<open>(K i (((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>))) \<in> X1\<close>
     using o3 by blast
   then have t:\<open>\<forall>x. \<forall>y. tautology (((x\<^bold>\<and>y)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow>\<^bold>\<not>(y\<^bold>\<and>x))\<close>
     by (metis eval.simps(4) eval.simps(5))
   then have \<open>(((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow>\<^bold>\<not>(?q\<^bold>\<and>?p)) \<in> X1\<close>
     using A1 deriv_in_maximal x1 by blast
   then have \<open>K i (((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow>\<^bold>\<not>(?q\<^bold>\<and>?p)) \<in> X1\<close>
     by (meson A1 R2 deriv_in_maximal t x1)
   then have \<open>(K i ((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow> K i (\<^bold>\<not>(?q\<^bold>\<and>?p))) \<in> X1\<close>
     by (meson K_A2' consequent_in_maximal deriv_in_maximal x1)
   then have \<open>(K i ((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow> (\<^bold>\<not> L i(?q\<^bold>\<and>?p))) \<in> X1\<close>
     using consequent_in_maximal exactly_one_in_maximal x1 x3 x4 by blast
   then have \<open>(\<^bold>\<not> L i(?q\<^bold>\<and>?p)) \<in> X1 \<and> (L i(?q\<^bold>\<and>?p)) \<in> X1\<close>
     using consequent_in_maximal x1 x4 x3 by blast
   then show False
     using exactly_one_in_maximal x1 by blast
 qed
 
 lemma mcs\<^sub>_\<^sub>2_weakly_directed:
   fixes A :: \<open>'i fm \<Rightarrow> bool\<close>
   assumes \<open>\<forall>p. Ax_2 p \<longrightarrow> A p\<close>
   shows \<open>weakly_directed \<lparr>\<W> = mcss A, \<K> = reach A, \<pi> = pi\<rparr>\<close>
   unfolding weakly_directed_def
 proof (intro allI ballI, auto)
   fix i V U W
   assume \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A U\<close> \<open>maximal A U\<close> \<open>consistent A W\<close> 
       \<open>maximal A W\<close> \<open>known V i \<subseteq> U\<close> \<open>known V i \<subseteq> W\<close>
   then have \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> X \<in> (reach A i W) \<inter> (reach A i U)\<close>
     using Ax_2_weakly_directed [where A=A and V=V and W=W and U=U] assms IntD2 
       by simp
   then have \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> X \<in> (reach A i W) \<and> X \<in> (reach A i U)\<close>
     by simp
   then show \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> known W i \<subseteq> X \<and> known U i \<subseteq> X\<close>
     by auto
 qed
 
 lemma imply_completeness_K_2:
   assumes valid: \<open>\<forall>(M :: ('i, 'i fm set) kripke). \<forall>w \<in> \<W> M.
     weakly_directed M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
   shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (Ax_2 \<turnstile> imply qs p)\<close>
 proof (rule ccontr)
 assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> Ax_2 \<turnstile> imply qs p\<close>
   then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> Ax_2 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
     using K_Boole by blast
 
   let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
   let ?V = \<open>Extend Ax_2 ?S\<close>
   let ?M = \<open>\<lparr>\<W> = mcss Ax_2, \<K> = reach Ax_2, \<pi> = pi\<rparr>\<close>
 
   have \<open>consistent Ax_2 ?S\<close>
     using * by (metis K_imply_Cons consistent_def inconsistent_subset)
   then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close> \<open>consistent Ax_2 ?V\<close> \<open>maximal Ax_2 ?V\<close>
     using canonical_model unfolding list_all_def by fastforce+
   moreover have \<open>weakly_directed ?M\<close>
     using mcs\<^sub>_\<^sub>2_weakly_directed [where A=Ax_2] by fast
   ultimately have \<open>?M, ?V \<Turnstile> p\<close>
     using valid by auto
   then show False
     using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
 qed
 
 
 section \<open>System S4.2\<close>
 
 abbreviation SystemS4_2 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>S\<^sub>4\<^sub>2 _" [50] 50) where
   \<open>\<turnstile>\<^sub>S\<^sub>4\<^sub>2 p \<equiv> AxT \<oplus> Ax4 \<oplus> Ax_2 \<turnstile> p\<close>
 
 abbreviation AxS4_2 :: \<open>'i fm \<Rightarrow> bool\<close> where
   \<open>AxS4_2 \<equiv> AxT \<oplus> Ax4 \<oplus> Ax_2\<close>
 
 subsection \<open>Soundness\<close>
 
 abbreviation w_directed_preorder :: \<open>('i, 'w) kripke \<Rightarrow> bool\<close> where
   \<open>w_directed_preorder M \<equiv> reflexive M \<and> transitive M \<and> weakly_directed M\<close>
 
 lemma soundness_AxS4_2: \<open>AxS4_2 p \<Longrightarrow> w_directed_preorder M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
   using soundness_AxT soundness_Ax4 soundness_Ax_2 by metis
 
 lemma soundness\<^sub>S\<^sub>4\<^sub>2: \<open>\<turnstile>\<^sub>S\<^sub>4\<^sub>2 p \<Longrightarrow> w_directed_preorder M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
   using soundness soundness_AxS4_2 .
 
 subsection \<open>Completeness\<close>
 
 lemma imply_completeness_S4_2:
   assumes valid: \<open>\<forall>(M :: ('i, 'i fm set) kripke). \<forall>w \<in> \<W> M.
     w_directed_preorder M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
   shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (AxS4_2 \<turnstile> imply qs p)\<close>
 proof (rule ccontr)
   assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> AxS4_2 \<turnstile> imply qs p\<close>
   then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> AxS4_2 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
     using K_Boole by blast
 
   let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
   let ?V = \<open>Extend AxS4_2 ?S\<close>
   let ?M = \<open>\<lparr>\<W> = mcss AxS4_2, \<K> = reach AxS4_2, \<pi> = pi\<rparr>\<close>
 
   have \<open>consistent AxS4_2 ?S\<close>
     using * by (metis (no_types, lifting) K_imply_Cons consistent_def inconsistent_subset)
   then have
     \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close>
     \<open>consistent AxS4_2 ?V\<close> \<open>maximal AxS4_2 ?V\<close>
     using canonical_model unfolding list_all_def by fastforce+
   moreover have \<open>w_directed_preorder ?M\<close>
     using reflexive\<^sub>T[of AxS4_2] mcs\<^sub>_\<^sub>2_weakly_directed[of AxS4_2] transitive\<^sub>K\<^sub>4[of AxS4_2] by auto
   ultimately have \<open>?M, ?V \<Turnstile> p\<close>
     using valid by auto
   then show False
     using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
 qed
 
 lemma completeness\<^sub>S\<^sub>4\<^sub>2:
   assumes \<open>\<forall>(M :: ('i, 'i fm set) kripke). \<forall>w \<in> \<W> M. w_directed_preorder M \<longrightarrow> M, w \<Turnstile> p\<close>
   shows \<open>\<turnstile>\<^sub>S\<^sub>4\<^sub>2 p\<close>
   using assms imply_completeness_S4_2[where G=\<open>{}\<close>] by auto
 
 abbreviation \<open>valid\<^sub>S\<^sub>4\<^sub>2 p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. w_directed_preorder M \<longrightarrow> M, w \<Turnstile> p\<close>
 
 theorem main\<^sub>S\<^sub>4\<^sub>2: \<open>valid\<^sub>S\<^sub>4\<^sub>2 p \<longleftrightarrow> \<turnstile>\<^sub>S\<^sub>4\<^sub>2 p\<close>
   using soundness\<^sub>S\<^sub>4\<^sub>2 completeness\<^sub>S\<^sub>4\<^sub>2 by fast
 
 corollary
   assumes \<open>w_directed_preorder M\<close> \<open>w \<in> \<W> M\<close>
   shows \<open>valid\<^sub>S\<^sub>4\<^sub>2 p \<longrightarrow> M, w \<Turnstile> p\<close>
   using assms soundness\<^sub>S\<^sub>4\<^sub>2 completeness\<^sub>S\<^sub>4\<^sub>2 by fast
 
 
 section \<open>Topological S4 axioms\<close>
 
 abbreviation DoubleImp (infixr "\<^bold>\<longleftrightarrow>" 25) where
   \<open>(p\<^bold>\<longleftrightarrow>q) \<equiv> ((p \<^bold>\<longrightarrow> q) \<^bold>\<and> (q \<^bold>\<longrightarrow> p))\<close>
 
 inductive System_topoS4 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>T\<^sub>o\<^sub>p _" [50] 50) where
   A1': \<open>tautology p \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p p\<close>
 | AR: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p ((K i (p \<^bold>\<and> q)) \<^bold>\<longleftrightarrow> ((K i p) \<^bold>\<and> K i q))\<close>
 | AT': \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<longrightarrow> p)\<close>
 | A4': \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<longrightarrow> K i (K i p))\<close>
 | AN: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p K i \<^bold>\<top>\<close>
 | R1': \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p p \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p q\<close>
 | RM: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p ((K i p) \<^bold>\<longrightarrow> K i q)\<close>
 
 lemma topoS4_trans: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
   by (simp add: A1')
 
 lemma topoS4_conjElim: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (p \<^bold>\<and> q \<^bold>\<longrightarrow> q)\<close>
   by (simp add: A1')
 
 lemma topoS4_AxK: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q)\<close>
 proof -
   have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p ((p \<^bold>\<and> (p \<^bold>\<longrightarrow> q)) \<^bold>\<longrightarrow> q)\<close>
     using A1' by force
   then have *: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i (p \<^bold>\<and> (p \<^bold>\<longrightarrow> q)) \<^bold>\<longrightarrow> K i q)\<close>
     using RM by fastforce
   then have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i (p \<^bold>\<and> (p \<^bold>\<longrightarrow> q)))\<close>
     using AR topoS4_conjElim System_topoS4.simps by fast
   then show ?thesis
     by (meson "*" System_topoS4.R1' topoS4_trans)
 qed
 
 lemma topoS4_NecR:
   assumes \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p p\<close>
   shows\<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p K i p\<close>
 proof -
   have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (\<^bold>\<top> \<^bold>\<longrightarrow> p)\<close>
     using assms by (metis System_topoS4.A1' System_topoS4.R1' conjunct.simps(1) imply.simps(1) imply_conjunct)
   then have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i \<^bold>\<top> \<^bold>\<longrightarrow> K i p)\<close>
     using RM by force
   then show ?thesis
     by (meson AN System_topoS4.R1')
 qed
 
 lemma empty_S4: "{} \<turnstile>\<^sub>S\<^sub>4 p \<longleftrightarrow> AxT \<oplus> Ax4 \<turnstile> p"
   by simp
 
 lemma S4_topoS4: \<open>{} \<turnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p p\<close>
   unfolding empty_S4
 proof (induct p rule: AK.induct)
   case (A2 i p q)
   then show ?case using topoS4_AxK .
 next 
   case (Ax p)
     then show ?case 
       using AT' A4' by (metis AxT.cases Ax4.cases)
 next
   case (R2 p)
   then show ?case 
     by (simp add: topoS4_NecR)
 qed (meson System_topoS4.intros)+
 
 lemma topoS4_S4:
   fixes p :: \<open>'i fm\<close>
   shows \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p p \<Longrightarrow> {} \<turnstile>\<^sub>S\<^sub>4 p\<close>
   unfolding empty_S4
 proof (induct p rule: System_topoS4.induct)
   case (AT' i p)
   then show ?case
     by (simp add: Ax AxT.intros)
 next
   case (A4' i p)
   then show ?case
     by (simp add: Ax Ax4.intros)
 next
   case (AR i p q)
     then show ?case
       by (meson K_conj_imply_factor K_conjunction_in K_conjunction_out K_imp_trans' K_imply_multi R1)
 next
   case (AN i) 
   then have *: \<open>AxT \<oplus> Ax4 \<turnstile> \<^bold>\<top>\<close>
     by (simp add: A1)
   then show ?case 
     by (simp add: * R2)
 next
   case (RM p q i)
   then have \<open>AxT \<oplus> Ax4 \<turnstile> K i (p \<^bold>\<longrightarrow> q)\<close>
     by (simp add: R2)
   then show ?case
     by (simp add: K_map RM.hyps(2))
 qed (meson AK.intros)+
 
 theorem main\<^sub>S\<^sub>4': \<open>{} \<TTurnstile>\<^sub>S\<^sub>4 p \<longleftrightarrow> (\<turnstile>\<^sub>T\<^sub>o\<^sub>p p)\<close>
   using main\<^sub>S\<^sub>4[of "{}"] S4_topoS4 topoS4_S4 by fast
 
 end
diff --git a/thys/Sturm_Tarski/Pseudo_Remainder_Sequence.thy b/thys/Sturm_Tarski/Pseudo_Remainder_Sequence.thy
--- a/thys/Sturm_Tarski/Pseudo_Remainder_Sequence.thy
+++ b/thys/Sturm_Tarski/Pseudo_Remainder_Sequence.thy
@@ -1,566 +1,566 @@
 (*
   File:    Pseudo_Remainder_Sequence.thy
   Author:  Wenda Li
 *)
 
 section \<open>An implementation for calculating pseudo remainder sequences\<close>
 
 theory Pseudo_Remainder_Sequence
   imports Sturm_Tarski
     "HOL-Computational_Algebra.Computational_Algebra"
     
     (*TODO: we should consider to move this to the standard library*)
     "Polynomial_Interpolation.Ring_Hom_Poly"
 begin
 
 subsection \<open>Misc\<close>
 
 function spmods :: "'a::idom poly \<Rightarrow> 'a poly \<Rightarrow> ('a poly) list" where
   "spmods p q= (if p=0 then [] else 
       let 
         m=(if even(degree p+1-degree q) then -1 else -lead_coeff q) 
       in     
         Cons p (spmods q (smult m (pseudo_mod p q))))"
 by auto
 termination
  apply (relation "measure (\<lambda>(p,q).if p=0 then 0 else if q=0 then 1 else 2+degree q)")
  by (simp_all add: degree_pseudo_mod_less)
 
 declare spmods.simps[simp del]
 
 lemma spmods_0[simp]:
   "spmods 0 q = []"
   "spmods p 0 = (if p=0 then [] else [p])"
 by (auto simp:spmods.simps)
 
 lemma spmods_nil_eq:"spmods p q = [] \<longleftrightarrow> (p=0)"
   by (metis list.distinct(1) spmods.elims)
 
 lemma changes_poly_at_alternative: 
   "changes_poly_at ps a= changes (map (\<lambda>p. sign(poly p a)) ps)" 
   "changes_poly_at ps a= changes (map (\<lambda>p. sgn(poly p a)) ps)" 
   unfolding changes_poly_at_def
   subgoal by (subst changes_map_sign_eq) (auto simp add:comp_def) 
   subgoal by (subst changes_map_sgn_eq) (auto simp add:comp_def)
   done
 
 lemma smods_smult_length: 
   assumes "a\<noteq>0" "b\<noteq>0"
   shows "length (smods p q) = length (smods (smult a p) (smult b q))" using assms
 proof (induct "smods p q"  arbitrary:p q a b )
   case Nil
   thus ?case by (simp split:if_splits)
 next
   case (Cons x xs)
   hence "p\<noteq>0" by auto
   define r where "r\<equiv>- (p mod q)"
   have "smods q r = xs" using Cons.hyps(2) `p\<noteq>0` unfolding r_def by auto
   hence "length (smods q r) = length (smods (smult b q) (smult a r))"
     using Cons.hyps(1)[of q r b a] Cons by auto
   moreover have "smult a p\<noteq>0" using `a\<noteq>0` `p\<noteq>0` by auto
   moreover have "-((smult a p) mod (smult b q)) = (smult a r)" 
     by (simp add: Cons.prems(2) mod_smult_left mod_smult_right r_def)
   ultimately show ?case
     unfolding r_def by auto
 qed
 
 lemma smods_smult_nth[rule_format]:
   fixes p q::"real poly"
   assumes "a\<noteq>0" "b\<noteq>0"
   defines "xs\<equiv>smods p q" and "ys\<equiv>smods (smult a p) (smult b q)"
   shows "\<forall>n<length xs. ys!n = (if even n then smult a (xs!n)  else smult b (xs!n))" using assms
 proof (induct "smods p q"  arbitrary:p q a b xs ys)
   case Nil
   thus ?case by (simp split:if_splits)
 next
   case (Cons x xs)
   hence "p\<noteq>0" by auto
   define r where "r\<equiv>- (p mod q)"
   have xs:"xs=smods q r" "p#xs=smods p q" using Cons.hyps(2) `p\<noteq>0` unfolding r_def by auto
   define ys where "ys\<equiv>smods (smult b q) (smult a r)"
   have "- ((smult a p) mod (smult b q)) = smult a r"
     by (simp add: Cons.hyps(4) mod_smult_left mod_smult_right r_def)
   hence ys:"smult a p # ys = smods (smult a p) (smult b q)" using `p\<noteq>0` `a\<noteq>0` 
     unfolding ys_def r_def by auto
   have hyps:"\<And>n. n<length xs \<Longrightarrow> ys ! n = (if even n then smult b (xs ! n) else smult a (xs ! n))"
     using Cons.hyps(1)[of q r b a,folded xs ys_def] `a\<noteq>0` `b\<noteq>0` by auto
   thus ?case
     apply (fold xs ys)
     apply auto
     by (case_tac n,auto)+
 qed
 
 lemma smods_smult_sgn_map_eq:
   fixes x::real
   assumes "m>0"
   defines "f\<equiv>\<lambda>p. sgn(poly p x)"
   shows "map f (smods p (smult m q)) = map f (smods p q)"
         "map sgn_pos_inf (smods p (smult m q)) = map sgn_pos_inf (smods p q)"
         "map sgn_neg_inf (smods p (smult m q)) = map sgn_neg_inf (smods p q)"
 proof -
   define xs ys where "xs\<equiv>smods p q" and "ys\<equiv>smods p (smult m q)" 
   have "m\<noteq>0" using `m>0` by simp
   have len_eq:"length xs =length ys"
     using smods_smult_length[of 1 m] `m>0` unfolding xs_def ys_def by auto
   moreover have 
     "(map f xs) ! i = (map f ys) ! i"
     "(map sgn_pos_inf xs) ! i = (map sgn_pos_inf ys) ! i"
     "(map sgn_neg_inf xs) ! i = (map sgn_neg_inf ys) ! i"
      when "i<length xs" for i
   proof -
     note nth_eq=smods_smult_nth[OF one_neq_zero `m\<noteq>0`,of _ p q,unfolded smult_1_left, 
         folded xs_def ys_def,OF `i<length xs` ]
     then show "map f xs ! i = map f ys ! i"
           "(map sgn_pos_inf xs) ! i = (map sgn_pos_inf ys) ! i"
           "(map sgn_neg_inf xs) ! i = (map sgn_neg_inf ys) ! i"
       using that
       unfolding f_def using len_eq `m>0`
       by (auto simp add:sgn_mult sgn_pos_inf_def sgn_neg_inf_def lead_coeff_smult)  
   qed
   ultimately show "map f (smods p (smult m q)) = map f (smods p q)"
     "map sgn_pos_inf (smods p (smult m q)) = map sgn_pos_inf (smods p q)"
     "map sgn_neg_inf (smods p (smult m q)) = map sgn_neg_inf (smods p q)"
     apply (fold xs_def ys_def)
     by (auto intro: nth_equalityI)
 qed
 
 lemma changes_poly_at_smods_smult:
   assumes "m>0"  
   shows "changes_poly_at (smods p (smult m q)) x =changes_poly_at (smods p q) x "
   using smods_smult_sgn_map_eq[OF `m>0`]
   by (metis changes_poly_at_alternative(2))
 
 lemma spmods_smods_sgn_map_eq:
   fixes p q::"real poly" and x::real
   defines "f\<equiv>\<lambda>p. sgn (poly p x)"
   shows "map f (smods p q) = map f (spmods p q)" 
         "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
         "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
 proof (induct "spmods p q" arbitrary:p q)
   case Nil
   hence "p=0" using spmods_nil_eq by metis
   thus "map f (smods p q) = map f (spmods p q)" 
        "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
        "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
     by auto
 next
   case (Cons p' xs)
   hence "p\<noteq>0" by auto
   define r where "r\<equiv>- (p mod q)"
   define exp where " exp\<equiv>degree p +1 - degree q"
   define m where "m\<equiv>(if even exp then 1 else lead_coeff q) 
       * (lead_coeff q ^ exp)"
   have xs1:"p#xs=spmods p q"  
     by (metis (no_types) Cons.hyps(4) list.distinct(1) list.inject  spmods.simps)
   have xs2:"xs=spmods q (smult m r)" when "q\<noteq>0" 
   proof -
     define m' where  "m'\<equiv>if even exp then - 1 else - lead_coeff q"
     have "smult m' (pseudo_mod p q) = smult m r" 
       unfolding m_def m'_def r_def 
       apply (subst pseudo_mod_mod[symmetric])
       using that exp_def by auto    
     thus ?thesis using `p\<noteq>0` xs1 unfolding r_def 
       by (simp add:spmods.simps[of p q,folded exp_def, folded m'_def] del:spmods.simps)
   qed
   define ys where "ys\<equiv>smods q r"
   have ys:"p#ys=smods p q" using `p\<noteq>0` unfolding ys_def r_def by auto
   have qm:"q\<noteq>0 \<Longrightarrow> m>0" 
     using `p\<noteq>0` unfolding m_def
     apply auto  
     subgoal by (simp add: zero_less_power_eq)
     subgoal using zero_less_power_eq by fastforce
     done
   show "map f (smods p q) = map f (spmods p q)"
   proof (cases "q\<noteq>0")
     case True
     then have "map f (spmods q (smult m r)) = map f (smods q r)"
       using smods_smult_sgn_map_eq(1)[of m x q r,folded f_def] qm 
         Cons.hyps(1)[OF xs2,folded f_def] 
       by simp  
     thus ?thesis
       apply (fold xs1 xs2[OF True] ys ys_def)
       by auto
   next
     case False
     thus ?thesis by auto
   qed
   show "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
   proof (cases "q\<noteq>0")
     case True
     then have "map sgn_pos_inf (spmods q (smult m r)) = map sgn_pos_inf (smods q r)"
       using Cons.hyps(2)[OF xs2,folded f_def] qm[OF True] 
         smods_smult_sgn_map_eq(2)[of m  q r,folded f_def] by auto
     thus ?thesis
       apply (fold xs1 xs2[OF True] ys ys_def)
       by (simp add:f_def)
   next
     case False
     thus ?thesis by auto
   qed 
   show "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
   proof (cases "q\<noteq>0")
     case True
     then have "map sgn_neg_inf (spmods q (smult m r)) = map sgn_neg_inf (smods q r)"
       using Cons.hyps(3)[OF xs2,folded f_def] qm[OF True] 
         smods_smult_sgn_map_eq(3)[of m  q r,folded f_def] by auto
     thus ?thesis
       apply (fold xs1 xs2[OF True] ys ys_def)  
       by (simp add:f_def)
   next
     case False
     thus ?thesis by auto
   qed 
 qed
 
 subsection \<open>Converting @{typ "rat poly"} to @{typ "int poly"} by clearing the denominators\<close>
 
 definition int_of_rat::"rat \<Rightarrow> int" where
   "int_of_rat = inv of_int"
 
 lemma of_rat_inj[simp]: "inj of_rat"
 by (simp add: linorder_injI)
 
 lemma (in ring_char_0) of_int_inj[simp]: "inj of_int"
   by (simp add: inj_on_def)
 
 lemma int_of_rat_id: "int_of_rat o of_int = id" 
   unfolding int_of_rat_def
   by auto
 
 lemma int_of_rat_0[simp]:"int_of_rat 0 = 0" 
   by (metis id_apply int_of_rat_id o_def of_int_0)
 
 lemma int_of_rat_inv:"r\<in>\<int> \<Longrightarrow> of_int (int_of_rat r) = r"
 unfolding int_of_rat_def
 by (simp add: Ints_def f_inv_into_f)
 
 lemma int_of_rat_0_iff:"x\<in>\<int> \<Longrightarrow> int_of_rat x = 0 \<longleftrightarrow> x = 0" 
 using int_of_rat_inv by force
 
 lemma [code]:"int_of_rat r = (let (a,b) = quotient_of r in 
           if b=1 then a else Code.abort (STR ''Failed to convert rat to int'') 
           (\<lambda>_. int_of_rat r))"
   apply (auto simp add:split_beta int_of_rat_def)
   by (metis Fract_of_int_quotient inv_f_eq of_int_inj of_int_rat quotient_of_div surjective_pairing)  
 
 definition de_lcm::"rat poly \<Rightarrow> int" where
   "de_lcm p = Lcm(set(map (\<lambda>x. snd (quotient_of x)) (coeffs p)))"
 
 lemma de_lcm_pCons:"de_lcm (pCons a p) = lcm (snd (quotient_of a)) (de_lcm p)"
   unfolding de_lcm_def
   by (cases "a=0\<and>p=0",auto)
 
 lemma de_lcm_0[simp]:"de_lcm 0 = 1" unfolding de_lcm_def by auto
 
 lemma de_lcm_pos[simp]:"de_lcm p > 0"
   apply (induct p)
   apply (auto simp add:de_lcm_pCons)
   by (metis lcm_pos_int less_numeral_extra(3) quotient_of_denom_pos')+  
 
 lemma de_lcm_ints: 
   fixes x::rat
   shows "x\<in>set (coeffs p) \<Longrightarrow> rat_of_int (de_lcm p) * x \<in> \<int>"
 proof (induct p)
   case 0
   then show ?case by auto
 next
   case (pCons a p)
   define a1 a2 where "a1\<equiv>fst (quotient_of a)" and "a2\<equiv>snd (quotient_of a)"
   have a:"a=(rat_of_int a1)/(rat_of_int a2)" and "a2>0" 
     using quotient_of_denom_pos'[of a] unfolding a1_def a2_def
     by (auto simp add: quotient_of_div)
   define mp1 where "mp1\<equiv>a2 div gcd (de_lcm p) a2"
   define mp2 where "mp2\<equiv>de_lcm p div gcd a2 (de_lcm p) "
   have lcm_times1:"lcm a2 (de_lcm p) = de_lcm p * mp1"
     using lcm_altdef_int[of "de_lcm p" a2,folded mp1_def] `a2>0` 
     unfolding mp1_def 
     apply (subst div_mult_swap)
     by (auto simp add: abs_of_pos gcd.commute lcm_altdef_int mult.commute)
   have lcm_times2:"lcm a2 (de_lcm p) = a2 * mp2"
     using lcm_altdef_int[of a2 "de_lcm p",folded mp1_def] `a2>0` 
     unfolding mp2_def by (subst div_mult_swap, auto simp add:abs_of_pos)
   show ?case
   proof (cases "x \<in> set (coeffs p)")    
     case True
     show ?thesis using pCons(2)[OF True]
-      by (smt Ints_mult Ints_of_int a2_def de_lcm_pCons lcm_times1 
+      by (smt (verit) Ints_mult Ints_of_int a2_def de_lcm_pCons lcm_times1 
             mult.assoc mult.commute of_int_mult)
   next
     case False
     then have "x=a" 
       using pCons cCons_not_0_eq coeffs_pCons_eq_cCons insert_iff list.set(2) not_0_cCons_eq 
       by fastforce
     show ?thesis unfolding `x=a` de_lcm_pCons
       apply (fold a2_def,unfold a)
       by (simp add: de_lcm_pCons lcm_times2 of_rat_divide)
   qed
 qed
 
 definition clear_de::"rat poly \<Rightarrow> int poly" where
   "clear_de p = (SOME q. (map_poly of_int q) = smult (of_int (de_lcm p)) p)"
 
 lemma clear_de:"of_int_poly(clear_de p) = smult (of_int (de_lcm p)) p"
 proof -
   have "\<exists>q. (of_int_poly q) = smult (of_int (de_lcm p)) p" 
   proof (induct p)
     case 0
     show ?case by (metis map_poly_0 smult_0_right)
   next
     case (pCons a p)
     then obtain q1::"int poly" where q1:"of_int_poly q1 = smult (rat_of_int (de_lcm p)) p"
       by auto
     define a1 a2 where "a1\<equiv>fst (quotient_of a)" and "a2\<equiv>snd (quotient_of a)"
     have a:"a=(rat_of_int a1)/ (rat_of_int a2)" and "a2>0" 
         using quotient_of_denom_pos' quotient_of_div 
         unfolding a1_def a2_def by auto 
     define mp1 where "mp1\<equiv>a2 div gcd (de_lcm p) a2"
     define mp2 where "mp2\<equiv>de_lcm p div gcd a2 (de_lcm p) "
     have lcm_times1:"lcm a2 (de_lcm p) = de_lcm p * mp1"
       using lcm_altdef_int[of "de_lcm p" a2,folded mp1_def] `a2>0` 
       unfolding mp1_def 
       by (subst div_mult_swap, auto simp add: abs_of_pos gcd.commute lcm_altdef_int mult.commute)
     have lcm_times2:"lcm a2 (de_lcm p) = a2 * mp2"
       using lcm_altdef_int[of a2 "de_lcm p",folded mp1_def] `a2>0` 
       unfolding mp2_def by (subst div_mult_swap, auto simp add:abs_of_pos)
     define q2 where "q2\<equiv>pCons (mp2 * a1) (smult mp1 q1)"
     have "of_int_poly q2 = smult (rat_of_int (de_lcm (pCons a p))) (pCons a p)" using `a2>0`  
       apply (simp add:de_lcm_pCons )
       apply (fold a2_def)
       apply (unfold a)
       apply (subst lcm_times2,subst lcm_times1)
       by (simp add: Polynomial.map_poly_pCons mult.commute of_int_hom.map_poly_hom_smult q1 q2_def)
     then show ?case by auto
   qed
   then show ?thesis unfolding clear_de_def  by (meson someI_ex)
 qed
 
 lemma clear_de_0[simp]:"clear_de 0 = 0" 
   using clear_de[of 0] by auto
 
 lemma [code abstract]: "coeffs (clear_de p) = 
     (let lcm = de_lcm p in map (\<lambda>x. int_of_rat (of_int lcm * x)) (coeffs p))"
 proof -
   define mul where "mul\<equiv>rat_of_int (de_lcm p)"
   have "map_poly int_of_rat (of_int_poly q) = q" for q
     apply (subst map_poly_map_poly) 
     by (auto simp add:int_of_rat_id)
   then have clear_eq:"clear_de p = map_poly int_of_rat (smult (of_int (de_lcm p)) p)"
     using arg_cong[where f="map_poly int_of_rat",OF clear_de] 
     by auto
   show ?thesis
   proof (cases "p=0")
     case True
     then show ?thesis by auto
   next
     case False
     define g where "g\<equiv>(\<lambda>x. int_of_rat (rat_of_int (de_lcm p) * x))"
     have "de_lcm p \<noteq> 0" using de_lcm_pos by (metis less_irrefl)
     moreover have "last (coeffs p) \<noteq>0" 
       by (simp add: False last_coeffs_eq_coeff_degree)
     have False when asm:"last (map g (coeffs p)) =0" 
     proof -
       have "coeffs p \<noteq>[]" using False by auto
       hence "g (last (coeffs p)) = 0" using asm last_map[of "coeffs p" g] by auto
       hence "last (coeffs p) = 0"
         unfolding g_def using `coeffs p \<noteq>[]` `de_lcm p \<noteq> 0`
         apply (subst (asm) int_of_rat_0_iff)
         by (auto intro!: de_lcm_ints )
       thus False using `last (coeffs p) \<noteq>0` by simp
     qed
     ultimately show ?thesis
       apply (auto simp add: coeffs_smult clear_eq comp_def smult_conv_map_poly map_poly_map_poly coeffs_map_poly)  
       apply (fold g_def)
       by (metis False Ring_Hom_Poly.coeffs_map_poly coeffs_eq_Nil last_coeffs_eq_coeff_degree 
           last_map)
     qed
 qed
 
 
 subsection \<open>Sign variations for pseudo-remainder sequences\<close>
 
 locale order_hom =
   fixes hom :: "'a :: ord \<Rightarrow> 'b :: ord"
   assumes hom_less: "x < y \<longleftrightarrow> hom x < hom y"
    and hom_less_eq: "x \<le> y \<longleftrightarrow> hom x \<le> hom y"
 
 locale linordered_idom_hom = order_hom hom + inj_idom_hom hom 
   for hom :: "'a :: linordered_idom \<Rightarrow> 'b :: linordered_idom" 
 begin
 
 lemma sgn_sign:"sgn (hom x) = of_int (sign x)"
   by (simp add: sign_def hom_less sgn_if)
 
 end
              
 locale hom_pseudo_smods= comm_semiring_hom hom 
     + r1:linordered_idom_hom R\<^sub>1 + r2:linordered_idom_hom R\<^sub>2
   for hom::"'a::linordered_idom \<Rightarrow> 'b::{comm_semiring_1,linordered_idom}"
     and R\<^sub>1::"'a \<Rightarrow> real" 
     and R\<^sub>2::"'b \<Rightarrow> real" +
   assumes R_hom:"R\<^sub>1 x = R\<^sub>2 (hom x)"
 begin
 
 (*
   hom    R2
 
 'a \<rightarrow> 'b \<rightarrow> real
       rat/float
 int
 p
       x
 *)
 
 lemma map_poly_R_hom_commute:
   "poly (map_poly R\<^sub>1 p) (R\<^sub>2 x) = R\<^sub>2 (poly (map_poly hom p) x)"
 apply (induct p)
 using r2.hom_add r2.hom_mult R_hom by auto
 
 definition changes_hpoly_at::"'a poly list \<Rightarrow> 'b \<Rightarrow> int" where
   "changes_hpoly_at ps a= changes (map (\<lambda>p. eval_poly hom p a) ps)" 
 
 lemma changes_hpoly_at_Nil[simp]: "changes_hpoly_at [] a = 0"
   unfolding changes_hpoly_at_def by simp
 
 definition changes_itv_spmods:: "'b \<Rightarrow> 'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
   "changes_itv_spmods a b p q= (let ps = spmods p q in 
         changes_hpoly_at ps a - changes_hpoly_at ps b)"
 
 definition changes_gt_spmods:: "'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
   "changes_gt_spmods a p q= (let ps = spmods p q in 
         changes_hpoly_at ps a - changes_poly_pos_inf ps)"
 
 definition changes_le_spmods:: "'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
   "changes_le_spmods b p q= (let ps = spmods p q in 
         changes_poly_neg_inf ps - changes_hpoly_at ps b)"
 
 definition changes_R_spmods:: "'a poly \<Rightarrow> 'a poly \<Rightarrow>  int" where
   "changes_R_spmods p q= (let ps= spmods p q in changes_poly_neg_inf ps 
       - changes_poly_pos_inf ps)"
 
 lemma changes_spmods_smods:
   shows "changes_itv_spmods a b p q 
     = changes_itv_smods (R\<^sub>2 a) (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
   and "changes_R_spmods p q = changes_R_smods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
   and "changes_gt_spmods a p q = changes_gt_smods (R\<^sub>2 a) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
   and "changes_le_spmods b p q = changes_le_smods (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
 proof -
   define pp qq where "pp = map_poly R\<^sub>1 p" and "qq = map_poly R\<^sub>1 q"
 
   have spmods_eq:"spmods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q) = map (map_poly R\<^sub>1) (spmods p q)" 
   proof (induct "spmods p q" arbitrary:p q )
     case Nil
     thus ?case by (metis list.simps(8) map_poly_0 spmods_nil_eq)
   next
     case (Cons p' xs)
     hence "p\<noteq>0" by auto
     define m where "m\<equiv>(if even (degree p + 1 - degree q) then - 1 else - lead_coeff q)"
     define r where "r\<equiv>smult m (pseudo_mod p q)"
     have xs1:"p#xs=spmods p q"  
       by (metis (no_types) Cons.hyps(2) list.distinct(1) list.inject  spmods.simps)
     have xs2:"xs=spmods q r" using xs1 \<open>p\<noteq>0\<close> r_def
       by (auto simp add:spmods.simps[of p q,folded exp_def,folded m_def])
     define ys where "ys\<equiv>spmods (map_poly R\<^sub>1 q) (map_poly R\<^sub>1 r)"
     have ys:"(map_poly R\<^sub>1 p)#ys=spmods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)" 
       using \<open>p\<noteq>0\<close> unfolding ys_def r_def 
       apply (subst (2) spmods.simps)
       unfolding m_def by (auto simp:r1.pseudo_mod_hom hom_distribs)
     show ?case using Cons.hyps(1)[OF xs2] 
       apply (fold xs1 xs2 ys ys_def)
       by auto
   qed
 
   have changes_eq_at:"changes_poly_at (smods pp qq) (R\<^sub>2 x) = changes_hpoly_at (spmods p q) x" 
     (is "?L=?R")
     for x
   proof -
     define ff where "ff = (\<lambda>p. sgn (poly p (R\<^sub>2 x)))"
     have "?L = changes (map ff (smods pp qq))"  
       using changes_poly_at_alternative unfolding ff_def by blast
     also have "... = changes (map ff (spmods pp qq))" 
       unfolding ff_def using spmods_smods_sgn_map_eq by simp
     also have "... = changes (map ff (map (map_poly R\<^sub>1) (spmods p q)))" 
       unfolding pp_def qq_def using spmods_eq by simp
     also have "... = ?R"
     proof -
       have "ff \<circ> map_poly R\<^sub>1 = sign \<circ> (\<lambda>p. eval_poly hom p x)" 
         unfolding ff_def comp_def
         by (simp add: map_poly_R_hom_commute poly_map_poly_eval_poly  r2.sgn_sign)
       then show ?thesis
         unfolding changes_hpoly_at_def
         apply (subst (2) changes_map_sign_of_int_eq)
         by (simp add:comp_def)
     qed
     finally show ?thesis .
   qed
 
   have changes_eq_neg_inf:
     "changes_poly_neg_inf (smods pp qq) = changes_poly_neg_inf (spmods p q)"
     (is "?L=?R")
   proof -
     have "?L = changes (map sgn_neg_inf (map (map_poly R\<^sub>1) (spmods p q)))"
       unfolding changes_poly_neg_inf_def spmods_smods_sgn_map_eq
       by (simp add: spmods_eq[folded pp_def qq_def])
     also have "... = changes (map (sgn_neg_inf \<circ> (map_poly R\<^sub>1)) (spmods p q))"
       using map_map by simp
     also have "... = changes (map ((sign:: _ \<Rightarrow> real) \<circ> sgn_neg_inf) (spmods p q))"
     proof - 
       have "(sgn_neg_inf \<circ> (map_poly R\<^sub>1)) = of_int o sign \<circ> sgn_neg_inf" 
         unfolding sgn_neg_inf_def comp_def
         by (auto simp:r1.sgn_sign)
       then show ?thesis by (simp add:comp_def)
     qed
     also have "... = changes (map sgn_neg_inf (spmods p q))"
       apply (subst (2) changes_map_sign_of_int_eq) 
       by (simp add:comp_def)
     also have "... = ?R"
       unfolding changes_poly_neg_inf_def by simp
     finally show ?thesis .
   qed
 
   have changes_eq_pos_inf:
     "changes_poly_pos_inf (smods pp qq) = changes_poly_pos_inf (spmods p q)"
     (is "?L=?R")
   proof -
     have "?L = changes (map sgn_pos_inf (map (map_poly R\<^sub>1) (spmods p q)))"
       unfolding changes_poly_pos_inf_def spmods_smods_sgn_map_eq
       by (simp add: spmods_eq[folded pp_def qq_def])
     also have "... = changes (map (sgn_pos_inf \<circ> (map_poly R\<^sub>1)) (spmods p q))"
       using map_map by simp
     also have "... = changes (map ((sign:: _ \<Rightarrow> real) \<circ> sgn_pos_inf) (spmods p q))"
     proof - 
       have "(sgn_pos_inf \<circ> (map_poly R\<^sub>1)) = of_int o sign \<circ> sgn_pos_inf" 
         unfolding sgn_pos_inf_def comp_def
         by (auto simp:r1.sgn_sign)
       then show ?thesis by (auto simp:comp_def)
     qed
     also have "... = changes (map sgn_pos_inf (spmods p q))"
       apply (subst (2) changes_map_sign_of_int_eq)
       by (simp add:comp_def)
     also have "... = ?R"
       unfolding changes_poly_pos_inf_def by simp
     finally show ?thesis .
   qed
 
   show "changes_itv_spmods a b p q 
           = changes_itv_smods (R\<^sub>2 a) (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
     unfolding changes_itv_spmods_def changes_itv_smods_def
     using changes_eq_at by (simp add: Let_def pp_def qq_def)
   show "changes_R_spmods p q = changes_R_smods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
     unfolding changes_R_spmods_def changes_R_smods_def Let_def
     using changes_eq_neg_inf changes_eq_pos_inf 
     by (simp add: pp_def qq_def)
   show "changes_gt_spmods a p q = changes_gt_smods 
                 (R\<^sub>2 a) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
     unfolding changes_gt_spmods_def changes_gt_smods_def Let_def
     using changes_eq_at changes_eq_pos_inf
     by (simp add: pp_def qq_def)
   show "changes_le_spmods b p q = changes_le_smods 
                 (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
     unfolding changes_le_spmods_def changes_le_smods_def Let_def
     using changes_eq_at changes_eq_neg_inf
     by (simp add: pp_def qq_def)
 qed
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Van_der_Waerden/Van_der_Waerden.thy b/thys/Van_der_Waerden/Van_der_Waerden.thy
--- a/thys/Van_der_Waerden/Van_der_Waerden.thy
+++ b/thys/Van_der_Waerden/Van_der_Waerden.thy
@@ -1,943 +1,943 @@
 theory Van_der_Waerden
   imports Main "HOL-Library.FuncSet" Digits
 begin
 
 section \<open>Van der Waerden's Theorem\<close>
 
 text \<open>In combinatorics, Van der Waerden's Theorem is about arithmetic progressions of a certain
 length of the same colour in a colouring of an interval. In order to state the theorem and to
 prove it, we need to formally introduce arithmetic progressions. We will express $k$-colourings as
 functions mapping an integer interval to the set $\{0,\dots , k-1 \}$ of colours.\<close>
 
 subsection \<open>Arithmetic progressions\<close>
 
 text \<open>A sequence of integer numbers with the same step size is called an arithmetic progression.
  We say an  $m$-fold arithmetic progression is an arithmetic progression with multiple step 
 lengths.\<close>
 
 text \<open> Arithmetic progressions are defined in the following using the variables:
 
 \begin{tabular}{lcp{8cm}}
 $start$:& \<open>int\<close>& starting value\\
 $step$:&  \<open>nat\<close>& positive integer for step length\\
 $i$:&     \<open>nat\<close>& $i$-th value in the arithmetic progression \\
 \end{tabular}\<close>
 
 definition arith_prog :: "int \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> int"
   where "arith_prog start step i = start + int (i * step)"
 
 text \<open> An $m$-fold arithmetic progression (which we will also call a multi-arithmetic progression)
 is defined in the following using the variables:
 
 \begin{tabular}{lcp{8cm}}
 $dims$:&   \<open>nat\<close>& number of dimensions/step directions of $m$-fold arithmetic progression\\
 $start$:&  \<open>int\<close>& starting value\\
 $steps$:&  \<open>nat \<Rightarrow> nat\<close>& function of steps, returns step in $i$-th dimension for $i\in[0..<dims]$\\
 $c$:&      \<open>nat \<Rightarrow> nat\<close>& function of coefficients, returns coefficient in $i$-th dimension for 
            $i\in[0..<dims]$ \\
 \end{tabular}\<close>
 
 definition multi_arith_prog :: 
     "nat \<Rightarrow> int \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> int"
   where "multi_arith_prog dims start steps c = 
            start + int (\<Sum>i<dims. c i * steps i)"
 
 text \<open>An $m$-fold arithmetic progression of dimension $1$ is also an arithmetic progression and 
   vice versa. This is shown in the following lemmas.\<close>
 lemma multi_to_arith_prog: 
   "multi_arith_prog 1 start steps c = 
     arith_prog start (steps 0) (c 0)"
   unfolding multi_arith_prog_def arith_prog_def by auto
 
 lemma arith_prog_to_multi: 
   "arith_prog start step c = 
     multi_arith_prog 1 start (\<lambda>_. step) (\<lambda>_. c)"
   unfolding multi_arith_prog_def arith_prog_def by auto
 
 text \<open>To show that an arithmetic progression is well-defined, we introduce the following predicate.
 It assures that \<open>arith_prog start step ` [0..<l]\<close> is contained in the integer interval $[a..b]$.\<close>
 definition is_arith_prog_on :: 
     "nat \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" 
   where "is_arith_prog_on l start step a b \<longleftrightarrow>
     (start \<ge> a \<and> arith_prog start step (l-1) \<le> b)"
 
 text \<open>Furthermore, we have monotonicity for arithmetic progressions.\<close>
 lemma arith_prog_mono: 
   assumes "c \<le> c'"
   shows   "arith_prog start step c \<le> arith_prog start step c'"
   using assms unfolding arith_prog_def by (auto intro: mult_mono)
 
 text \<open>Now, we state the well-definedness of an arithmetic progression of length $l$ in an integer
 interval $[a..b]$. 
 Indeed, \<open>is_arith_prog_on\<close> guarantees that every element of \<open>arith_prog start step\<close> of length $l$ 
   lies in $[a..b]$.\<close>
 lemma is_arith_prog_onD:
   assumes "is_arith_prog_on l start step a b"
   assumes "c \<in> {0..<l}"
   shows   "arith_prog start step c \<in> {a..b}"
 proof -
   have "arith_prog start step 0 \<le> arith_prog start step c"
     by (rule arith_prog_mono) auto
   hence "arith_prog start step c \<ge> a"
     using assms by (simp add: arith_prog_def is_arith_prog_on_def 
                       add_increasing2)
   moreover have "arith_prog start step (l-1) \<ge> 
                    arith_prog start step c"
     by (rule arith_prog_mono) (use assms(2) in auto)
   hence "arith_prog start step c \<le> b"
     using assms unfolding arith_prog_def is_arith_prog_on_def 
     by linarith
   ultimately show ?thesis
     by auto
 qed
 
 text \<open>We also need a predicate for an $m$-fold arithmetic progression to be well-defined. 
 It assures that \<open>multi_arith_prog start step ` [0..<l]^m\<close> is contained in $[a..b]$.\<close>
 definition is_multi_arith_prog_on :: 
     "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" 
   where "is_multi_arith_prog_on l m start steps a b \<longleftrightarrow>
      (start \<ge> a \<and> multi_arith_prog m start steps (\<lambda>_. l-1) \<le> b)"
 
 text \<open>Moreover, we have monotonicity for $m$-fold arithmetic progressions as well.\<close>
 lemma multi_arith_prog_mono:
   assumes "\<And>i. i < m \<Longrightarrow> c i \<le> c' i"
   shows   "multi_arith_prog m start steps c \<le> 
             multi_arith_prog m start steps c'"
   using assms unfolding multi_arith_prog_def 
   by (auto intro!: sum_mono intro: mult_right_mono)
 
 text \<open>Finally, we get the well-definedness for $m$-fold arithmetic progressions of length $l$.
 Here, \<open>is_multi_arith_prog_on\<close> guarantees that every element of \<open>multi_arith_prog start step\<close> 
   of length $l$ lies in $[a..b]$.\<close>
 lemma is_multi_arith_prog_onD:
   assumes "is_multi_arith_prog_on l m start steps a b"
   assumes "c \<in> {0..<m} \<rightarrow> {0..<l}"
   shows   "multi_arith_prog m start steps c \<in> {a..b}"
 proof -
   have "multi_arith_prog m start steps (\<lambda>_. 0) \<le> 
           multi_arith_prog m start steps c"
     by (rule multi_arith_prog_mono) auto
   hence "multi_arith_prog m start steps c \<ge> a"
     using assms by (simp add: multi_arith_prog_def 
        is_multi_arith_prog_on_def)
   moreover have "multi_arith_prog m start steps (\<lambda>_. l-1) \<ge> 
                    multi_arith_prog m start steps c"
     by (rule multi_arith_prog_mono) (use assms in force)
   hence "multi_arith_prog m start steps c \<le> b"
     using assms by (simp add: multi_arith_prog_def 
         is_multi_arith_prog_on_def)
   ultimately show ?thesis
     by auto
 qed
 
 
 subsection \<open>Van der Waerden's Theorem\<close>
 
 text \<open>The property for a number $n$ to fulfill Van der Waerden's theorem is the following:\\
 For a $k$-colouring col of $[a..b]$ there exist
 \begin{itemize}
 \item $start$: starting value of an arithmetic progression
 \item $step$:  step length of an arithmetic progression
 \item $j$: colour 
 \end{itemize}
 such that \<open>arith_prog start step\<close> is a valid arithmetic progression of length $l$ lying 
 in $[a..b]$ of the same colour $j$.
 
 The following variables will be used:\\
 \begin{tabular}{lcp{8cm}}
 $k$:& \<open>nat\<close>& number of colours in segment colouring on $[a..b]$\\
 $l$:& \<open>nat\<close>& length of arithmetic progression\\
 $n$:& \<open>nat\<close>& number fulfilling Van der Waerden's Theorem\\
 \end{tabular}
 \<close>
 definition vdw :: 
     "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" 
   where "vdw k l n \<longleftrightarrow>
      (\<forall>a b col. b + 1 \<ge> a + int n \<and> col \<in> {a..b} \<rightarrow> {..<k} \<longrightarrow>
        (\<exists>j start step. j < k \<and> step > 0 \<and> 
         is_arith_prog_on l start step a b \<and>
         arith_prog start step ` {..<l} \<subseteq> col -` {j} \<inter> {a..b}))"
 
 text \<open>To better work with the property of Van der Waerden's theorem, we introduce an 
   elimination rule.\<close>
 lemma vdwE:
   assumes "vdw k l n"
           "b + 1 \<ge> a + int n" 
           "col \<in> {a..b} \<rightarrow> {..<k}"
   obtains j start step where
     "j < k" "step > 0" 
     "is_arith_prog_on l start step a b"
     "arith_prog start step ` {..<l} \<subseteq> col -` {j} \<inter> {a..b}"
   using assms that unfolding vdw_def by metis
 
 text \<open>Van der Waerden's theorem implies that the number fulfilling it is positive. This is show 
 in the following lemma.\<close>
 lemma vdw_imp_pos:
   assumes "vdw k l n" 
           "l > 0"
   shows "n > 0"
 proof (rule Nat.gr0I)
   assume [simp]: "n = 0"
   show False
     using assms 
     by (elim vdwE[where a = 1 and b = 0 and col = "\<lambda>_. 0"]) 
        (auto simp: lessThan_empty_iff)
 qed
 
 text \<open>Van der Waerden's Theorem is trivial for a non-existent colouring. 
 It also makes no sense for arithmetic progressions of length 0.\<close>
 lemma vdw_0_left [simp, intro]: "n>0 \<Longrightarrow> vdw 0 l n"
   by (auto simp: vdw_def)
 
 text \<open>In the case of $k=1$, Van der Waerden's Theorem holds. Then every number has the same colour,
 hence also the arithmetic progression. A possible choice for the number fulfilling Van der 
 Waerden Theorem is $l$.\<close>
 lemma vdw_1_left: 
   assumes "l>0" 
   shows "vdw 1 l l"
 unfolding vdw_def
 proof (safe, goal_cases)
   case (1 a b col)
   have "arith_prog a 1 ` {..<l} \<subseteq> {a..b}"
     using 1(1) by (auto simp: arith_prog_def)
   also have "{a..b} = col -` {0} \<inter> {a..b}"
     using 1(2) by auto
   finally have "arith_prog a 1 ` {..<l} \<subseteq> col -` {0} \<inter> {a..b}"
     by auto
   moreover have "is_arith_prog_on l a 1 a b" 
     unfolding is_arith_prog_on_def arith_prog_def using 1 assms 
     by auto
   ultimately show "\<exists>j start step. j < 1 \<and> 0 < step \<and> 
         is_arith_prog_on l start step a b \<and>
         arith_prog start step ` {..<l} \<subseteq> col -` {j} \<inter> {a..b}"
     by auto
 qed
 
 text \<open>In the case $l=1$, Van der Waerden's Theorem holds. As the length of the arithmetic 
 progression is $1$, it consists of just one element. Thus every nonempty integer interval fulfills 
 the Van der Waerden property. We can prove $N_{k,1}$ to be $1$.\<close>
 lemma vdw_1_right: "vdw k 1 1"
 unfolding vdw_def 
 proof safe
   fix a b :: int and col :: "int \<Rightarrow> nat"
   assume *: "a + int 1 \<le> b + 1" "col \<in> {a..b} \<rightarrow> {..<k}"
   have "col a < k" using * by auto
   have "arith_prog a 1 ` {..<1} = {a}"
     using *(1) by (auto simp: arith_prog_def)
   also have "{a} \<subseteq> col -` {col a} \<inter> {a..b}"
     using * by auto
   finally have "arith_prog a 1 ` {..<1} \<subseteq> col -` {col a} \<inter> {a..b}"
     by auto
   moreover have "is_arith_prog_on 1 a 1 a b" 
     unfolding is_arith_prog_on_def arith_prog_def
     using * by auto
   ultimately show  "\<exists>j start step.
           j < k \<and> 0 < step \<and> is_arith_prog_on 1 start step a b \<and>
           arith_prog start step ` {..<1} \<subseteq> col -` {j} \<inter> {a..b}"
     using \<open>col a <k\<close> by blast
 qed
 
 text \<open>In the case $l=2$, Van der Waerden's Theorem holds as well. Here, any two distinct numbers 
 form an arithmetic progression of length $2$. Thus we only have to find two numbers with the same 
 colour.
 Using the pigeonhole principle on $k+1$ values, we can find two integers with the same colour.\<close>
 lemma vdw_2_right: "vdw k 2 (k+1)"
 unfolding vdw_def 
 proof safe
   fix a b :: int and col :: "int \<Rightarrow> nat"
   assume *: "a + int (k + 1) \<le> b + 1" "col \<in> {a..b} \<rightarrow> {..<k}"
 
   have "col ` {a..b} \<subseteq> {..<k}" using *(2) by auto
   moreover have "k+1 \<le> card {a..b}" using *(1) by auto
   ultimately have "card (col ` {a..b}) < card {a..b}" using * 
     by (metis card_lessThan card_mono finite_lessThan le_less_trans 
         less_add_one not_le)
   then have "\<not> inj_on col {a..b}" using pigeonhole[of col "{a..b}"]
     by auto
   then obtain start start_step 
     where pigeon: "col start = col start_step" 
       "start < start_step"
       "start \<in> {a..b}" 
       "start_step \<in> {a..b}" 
     using inj_onI[of "{a..b}" col] 
     by (metis not_less_iff_gr_or_eq)
 
   define step where "step = nat (start_step - start)"
   define j where "j = col start"
 
   have "j < k" unfolding j_def using *(2) pigeon(3) by auto 
   moreover have "0 < step" unfolding step_def using pigeon(2) by auto
   moreover have "is_arith_prog_on 2 start step a b" 
     unfolding is_arith_prog_on_def arith_prog_def step_def 
     using pigeon by auto
   moreover {
   have "arith_prog start step i \<in> {start, start_step}" if "i<2" for i
     using that arith_prog_def step_def by (auto simp: less_2_cases_iff)
   also have "\<dots> \<subseteq> col -` {j} \<inter> {a..b}" 
     using pigeon unfolding j_def by auto
   finally have "arith_prog start step ` {..<2} \<subseteq> col -` {j} \<inter> {a..b}" 
     by auto
   }
   ultimately show "\<exists>j start step.
           j < k \<and>
           0 < step \<and>
           is_arith_prog_on 2 start step a b \<and>
           arith_prog start step ` {..<2} \<subseteq> col -` {j} \<inter> {a..b}" by blast
 qed
 
 text \<open>In order to prove Van der Waerden's Theorem, we first prove a slightly different lemma.
 The statement goes as follows:\\
 For a $k$-colouring $col$ on $[a..b]$ there exist
 \begin{itemize}
 \item  $start$: starting value of an arithmetic progression
 \item  $steps$: step length of an arithmetic progression
 \end{itemize}
 such that \<open>f = multi_arith_prog m start step\<close> is a valid $m$-fold arithmetic progression of 
 length $l$ lying in $[a..b]$ such that for every $s<m$ have: if $c j < l$ for all $j\leq s$ then
 $f(c_0, c_1, \dots, c_{m-1})$ and $f(0,\dots,0, c_{s+1},\dots, c_{m-1})$ have the same colour.
 
 The property of the lemma uses the following variables:\\
 \begin{tabular}{lcp{8cm}}
 $k$:& \<open>nat\<close>& number of colours in segment colouring of $[a..b]$\\
 $m$:& \<open>nat\<close>& dimension of $m$-fold arithmetic progression\\
 $l$:& \<open>nat\<close>& $l+1$ is length of $m$-fold arithmetic progression\\
 $n$:& \<open>nat\<close>& number fulfilling \<open>vdw_lemma\<close>\\
 \end{tabular}
 \<close>
 definition vdw_lemma :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
   "vdw_lemma k m l n \<longleftrightarrow>
      (\<forall>a b col. b + 1 \<ge> a + int n \<and> col \<in> {a..b} \<rightarrow> {..<k} \<longrightarrow>
        (\<exists>start steps. (\<forall>i<m. steps i > 0) \<and> 
         is_multi_arith_prog_on (l+1) m start steps a b \<and> (
            let f = multi_arith_prog m start steps
            in  (\<forall>c \<in> {0..<m} \<rightarrow> {0..l}. \<forall>s<m. (\<forall> j \<le> s. c j < l) \<longrightarrow>
                   col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))))))"
 
 text \<open>To better work with this property, we introduce an elimination rule for \<open>vdw_lemma\<close>.\<close>
 lemma vdw_lemmaE:
   fixes a b :: int
   assumes "vdw_lemma k m l n"
     "b + 1 \<ge> a + int n" "col \<in> {a..b} \<rightarrow> {..<k}"
   obtains start steps where
     "\<And>i. i < m \<Longrightarrow> steps i > 0"
     "is_multi_arith_prog_on (l+1) m start steps a b"
     "let f = multi_arith_prog m start steps
      in  \<forall>c \<in> {0..<m} \<rightarrow> {0..l}. \<forall>s<m. (\<forall> j \<le> s. c j < l) \<longrightarrow>
             col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
   using assms that unfolding vdw_lemma_def by blast
 
 text \<open>To simplify the following proof, we show the following formula.\<close>
 lemma sum_mod_poly: 
   assumes "(k::nat)>0" 
   shows "(k - 1) * (\<Sum> n\<in>{..<q}. k^n) < k^q "
 proof -
   have "int ((k - 1) * (\<Sum>n<q. k ^ n)) = 
         (int k - 1) * (\<Sum>n<q. int k ^ n)"
     using assms by (simp add: of_nat_diff)
   also have "\<dots> = int k ^ q - 1"
     by (induction q) (auto simp: algebra_simps)
   also have "\<dots> < int (k ^ q)"
     by simp
   finally show ?thesis by linarith
 qed
 
 text \<open>The proof of Van der Waerden's Theorem now proceeds in three steps:\\
 \begin{itemize}
 \item Firstly, we show that the \<open>vdw\<close> property for all $k$ proves the \<open>vdw_lemma\<close> for fixed $l$ but 
 arbitrary $k$ and $m$. This is done by induction over $m$.
 \item Secondly, we show that \<open>vdw_lemma\<close> implies the induction step of \<open>vdw\<close> using the pigeonhole 
 principle.
 \item Lastly, we combine the previous steps in an induction over $l$ to show Van der Waerden's 
 Theorem in the general setting.
 \end{itemize}\<close>
 
 text \<open>Firstly, we need to show that \<open>vdw\<close> for arbitrary $k$ implies \<open>vdw_lemma\<close> for fixed $l$.
 As mentioned earlier, we use induction over $m$.\<close>
 lemma vdw_imp_vdw_lemma:
   fixes l
   assumes vdw_assms: "\<And>k'. k'>0 \<Longrightarrow> \<exists>n_k'. vdw k' l n_k'"
     and "l \<ge> 2"
     and "m > 0"
     and "k > 0"
   shows   "\<exists>N. vdw_lemma k m l N"
 using \<open>m>0\<close> \<open>k>0\<close> proof (induction m rule: less_induct)
   case (less m)
   consider  "m=1" | "m>1" using less.prems by linarith
   then show ?case 
   proof cases
     text \<open> Case $m=1$: Show \<open>vdw_lemma\<close> for arithmetic progression, Induction start. \<close>
     assume "m = 1"
 
     obtain n where vdw: "vdw k l n" using vdw_assms \<open>k>0\<close> by blast
     define N where "N = 2*n"
     have "l>0" and "l>1" using \<open>l\<ge>2\<close> by auto
 
     have "vdw_lemma k m l N"
       unfolding vdw_lemma_def
     proof (safe, goal_cases)
       case (1 a b col)
       text \<open> Divide $[a..b]$ in two intervals $I_1$, $I_2$ of same length and obtain arithmetic 
         progression of length $l$ in $I_1$. \<close>
       have col_restr: "col \<in> {a..a + int n - 1} \<rightarrow> {..<k}"
         using 1 by (auto simp: N_def)
       then obtain j start step where prog:
         "j < k" "step > 0" 
         "is_arith_prog_on l start step a (a + int n -1)"
         "arith_prog start step ` {..<l} \<subseteq> 
           col -` {j} \<inter> {a..a + int n - 1}"
         using vdw 1 unfolding N_def by (elim vdwE)(auto simp:is_arith_prog_on_def)
       have range_prog_lessThan_l: 
         "arith_prog start step i \<in> {a..a + int n -1}" if "i < l" for i
         using that prog by auto
 
       have "{a..a + int n-1}\<subseteq>{a..b}" using N_def "1"(1) by auto 
       then have "a + 2* int n - 1 \<le> b" using 1(1) unfolding N_def 
         by auto
 
       text \<open> Show that \<open>arith_prog start step\<close> is an arithmetic progression of length $l+1$
          in $[a..b]$. \<close>
       have prog_in_ivl: "arith_prog start step i \<in> {a..b}" 
         if "i \<le> l" for i
       proof (cases "i=l")
         case False
         have "i<l" using that False by auto
         then show ?thesis 
           using range_prog_lessThan_l \<open>{a..a + int n-1}\<subseteq>{a..b}\<close> by force
       next
         case True
         text \<open> Show $\<open>step\<close>\leq |I_1|$ then have \<open>arith_prog start step (l+1)\<in>[a..b]\<close> as 
            \<open>arith_prog start step (l+1) = arith_prog start step l + step\<close> \<close>
         have "start \<in> {a..a + int n -1}" 
           using range_prog_lessThan_l[of 0] 
           unfolding arith_prog_def by (simp add: \<open>0 < l\<close>)
         moreover have "start + int step \<in> {a..a + int n -1}" 
           using range_prog_lessThan_l[of 1] 
           unfolding arith_prog_def by (metis \<open>1 < l\<close> mult.left_neutral)
         ultimately have "step \<le> n" by auto
         have "arith_prog start step (l-1) \<in> {a..a + int n -1}" 
           using range_prog_lessThan_l[of "l-1"] unfolding arith_prog_def
           using \<open>0 < l\<close> diff_less less_numeral_extra(1) by blast
         moreover have "arith_prog start step l = 
                         arith_prog start step (l-1) + int step"
           unfolding arith_prog_def using \<open>0 < l\<close> mult_eq_if by force
         ultimately have "arith_prog start step l \<in> {a..b}" 
           using \<open>step\<le>n\<close> N_def \<open>a + 2* int n -1 \<le> b\<close> by auto
         then show ?thesis using range_prog_lessThan_l using True 
           by force
       qed
 
       have col_prog_eq: "col (arith_prog start step k) = j" 
         if "k < l" for k
         using prog that by blast
       
       define steps :: "nat \<Rightarrow> nat" where steps_def: "steps = (\<lambda>i. step)"
       define f where "f = multi_arith_prog 1 start steps"
       
       have rel_prop_1: 
         "col (f c) = col (f (\<lambda>i. if i < s then 0 else c i))"
         if "c \<in> {0..<1} \<rightarrow> {0..l}" "s<1" "\<forall>j\<le>s. c j < l" for c s 
         using that by auto
 
       have arith_prog_on: 
         "is_multi_arith_prog_on (l+1) m start steps a b"
         using prog(3) unfolding is_arith_prog_on_def is_multi_arith_prog_on_def
         using \<open>m=1\<close> arith_prog_to_multi steps_def prog_in_ivl by auto
       
       show ?case
         by (rule exI[of _ start], rule exI[of _ steps])
            (use rel_prop_1 \<open>step > 0\<close> \<open>m = 1\<close> arith_prog_on col_prog_eq
              multi_to_arith_prog in \<open>auto simp: f_def Let_def steps_def\<close>)
     qed
     then show ?case ..
 
   next
     text \<open> Case $m>1$: Show \<open>vdw_lemma\<close> for $m$-fold arithmetic progression, 
           Induction step $(m-1) \longrightarrow m$. \<close>
     assume "m>1"
 
     obtain q where vdw_lemma_IH:"vdw_lemma k (m-1) l q" 
       using \<open>1 < m\<close> less by force
     have "k^q>0" using \<open>k>0\<close> by auto
     obtain n_kq where vdw: "vdw (k^q) l n_kq" 
       using vdw_assms \<open>k^q>0\<close> by blast
     define N where "N = q + 2 * n_kq"
 
     text \<open>Idea: $[a..b] = I_1 \cup I_2$ where $|I_1| = 2*n_{k,q}$ and $|I_2| = q$.
                 Divide $I_1$ into blocks of length $q$ and define a new colouring on the set of 
                 $q$-blocks where the colour of the block is the $k$-basis representation where 
                 the $i$-th digit corresponds to the colour of the $i$-th element in the block. 
                 Get an arithmetic progression of $q$-blocks of length $l+1$ in $I_1$, such that
                 the first $l$ $q$-blocks have the same colour. 
                 The step of the block-arithmetic progression is going to be the additional 
                 step in the induction over $m$. \<close>
 
     have "vdw_lemma k m l N"
       unfolding vdw_lemma_def
     proof (safe, goal_cases)
       case (1 a b col)
       have "n_kq>0" using vdw_imp_pos vdw \<open>l\<ge>2\<close> by auto
       then have "N>0" by (simp add:N_def)
       then have "a\<le>b" using 1 by auto
       then have "k>0" using 1 by (intro Nat.gr0I) force
       have "l>0" and "l>1" using \<open>l\<ge>2\<close> by auto
       interpret digits k by (simp add: \<open>0 < k\<close> digits_def)
       define col1 where "col1 = (\<lambda> x. from_digits q (\<lambda>y. col (x + y)))" 
       have range_col1: "col1\<in>{a..a + int n_kq - 1} \<rightarrow> {..<k^q}" 
       unfolding Pi_def
       proof safe
         fix x assume "x\<in>{a..a + int n_kq - 1}"
         then have col_xn:"col (x + int n)\<in>{..<k}" if "n<q" for n :: nat
           using that 1 PiE N_def by auto
         have col_xn_upper_bound:"col (x + int n) \<le> k - 1" 
           if "n<q" for n ::nat
           using that col_xn[of n] \<open>k>0\<close> by (auto)
         have "(\<Sum>n<q. col (x + int n) * k ^ n)\<le> 
                (\<Sum>n<q. (k-1) *  k ^ n)"
           using col_xn_upper_bound by (intro sum_mono mult_right_mono) 
             auto
         also have "\<dots> = (k-1) * (\<Sum>n<q. k ^ n)"
           by (rule sum_distrib_left[symmetric])
         also have "\<dots> < k^q" using sum_mod_poly \<open>k>0\<close> by auto        
         finally show "col1 x <k^q" unfolding col1_def from_digits_altdef 
           by auto 
       qed
 
       obtain j start step where prog:
         "j < k^q" "step > 0" 
         "is_arith_prog_on l start step a (a + int n_kq - 1)"
         "arith_prog start step ` {..<l} \<subseteq> 
           col1 -` {j} \<inter> {a..a + int n_kq -1}"
         using vdw range_col1 by (elim vdwE) (auto simp: \<open>k>0\<close>) 
 
       have range_prog_lessThan_l: 
         "arith_prog start step i \<in> {a..a + int n_kq -1}" 
         if "i < l" for i
         using that prog by auto
 
       have prog_in_ivl: 
         "arith_prog start step i \<in> {a..a + 2 * int n_kq -1}" 
         if "i \<le> l" for i
       proof (cases "i=l")
         case False
         then have "i<l" using that by auto
         then show ?thesis using prog by auto
       next
         case True
         have "start \<in> {a..a + int n_kq -1}" 
           using range_prog_lessThan_l[of 0] unfolding arith_prog_def 
           by (simp add: \<open>0 < l\<close>)
         moreover have "start + step \<in> {a..a + int n_kq -1}" 
           using range_prog_lessThan_l[of 1] unfolding arith_prog_def 
           by (metis \<open>1 < l\<close> mult.left_neutral)
         ultimately have "step \<le> n_kq" by auto
         have "arith_prog start step (l-1) \<in> {a..a + int n_kq -1}" 
           using range_prog_lessThan_l[of "l-1"] unfolding arith_prog_def
           using \<open>0 < l\<close> diff_less less_numeral_extra(1) by blast
         moreover have "arith_prog start step l = 
             arith_prog start step (l-1) + step"
           unfolding arith_prog_def using \<open>0 < l\<close> mult_eq_if by force
         ultimately have "arith_prog start step l \<in> 
             {a..a + 2 * int n_kq - 1}" 
           using \<open>step\<le>n_kq\<close> by auto
         then show ?thesis using range_prog_lessThan_l using True 
           by force
       qed
 
       have col_prog_eq: "col1 (arith_prog start step k) = j" 
         if "k < l" for k
         using prog that by blast
 
       have digit_col1:"digit (col1 x) y = col (x+int y)" 
         if "x\<in>{a..<a + 2*int n_kq}" "y\<in>{..<q}" 
         for x::int and y::nat unfolding col1_def using that
       proof -
         have "\<And>j'. j'<q \<Longrightarrow> x+j'\<in>{a..b}" 
           using "1"(1) N_def that(1) by force
         then have "\<And>j'. j'<q \<Longrightarrow> (\<lambda>y. col (x+int y)) j' < k" 
           using 1 that by auto
         then show "digit (from_digits q (\<lambda>xa. col (x + int xa))) y = 
                     col (x + int y)" 
           using digit_from_digits that 1 by auto
       qed
 
       text \<open> Impact on the colour when taking the block-step. \<close>
       have one_step_more:
         "col (arith_prog start' step i) = digit j (nat (start'-start))" 
         if "start'\<in>{start..<start+q}" "i\<in>{..<l}" for start' i
       proof -
         have "start \<le> start'" using that by simp
         have shift_arith_prog:
           "arith_prog start step i + (start' - start) = 
             arith_prog start' step i" 
           unfolding arith_prog_def by simp
         define diff where "diff = nat (start'-start)"
         have "diff \<in>{..<q}" using that unfolding diff_def by auto
         have "col (arith_prog start step i + int diff) = digit j diff"
         proof -
           have "col1 (arith_prog start step i) = j" 
             using col1_def prog that by blast
           moreover have " arith_prog start step i\<in>{a..a + 2 * int n_kq-1}"
             using prog(4) that by auto
           ultimately show ?thesis 
             using digit_col1[where x = "arith_prog start step i" 
                 and y = "diff"] 
               prog 1 \<open>diff \<in>{..<q}\<close> by auto
         qed
         then show ?thesis unfolding diff_def 1
           by (auto simp: \<open>start\<le>start'\<close> shift_arith_prog) 
       qed
 
       have one_step_more': "col (arith_prog start' step i) =
         col (arith_prog start' step 0)"
         if "start'\<in>{start..<start+q}" "i\<in>{..<l}" for start' i
         using that one_step_more[of start' 0] 
           one_step_more[of start' i] by auto
 
       have start_q: "start + int q \<le> start + int q - 1 + 1" by linarith
       have "{start..start + int q-1} \<subseteq> {a..b}"
         using prog N_def 1(1) by (force simp: arith_prog_def is_arith_prog_on_def)  
       then have col': "col \<in> {start..start + int q-1} \<rightarrow> {..<k}"
         using 1 prog(4) by auto
 
       text \<open> Obtain an $(m-1)$-fold arithmetic progression in the starting $q$-bolck of the 
              block arithmetic progression. \<close>
       obtain start_m steps_m where
         step_m_pos: "\<And>i. i < m - 1 \<Longrightarrow> 0 < steps_m i" and
         is_multi_arith_prog: "is_multi_arith_prog_on (l+1) (m - 1) 
           start_m steps_m start (start + int q - 1)" and
         g_aux: "let g = multi_arith_prog (m - 1) start_m steps_m
           in  \<forall>c\<in>{0..<m - 1} \<rightarrow> {0..l}. \<forall>s<m - 1. (\<forall>j\<le>s. c j < l) \<longrightarrow>
           col (g c) = col (g (\<lambda>i. if i \<le> s then 0 else c i))"
         by (rule vdw_lemmaE[OF vdw_lemma_IH start_q col']) blast
         
       define g where "g = multi_arith_prog (m-1) start_m steps_m"
       have g: "col (g c) = col (g (\<lambda>i. if i \<le> s then 0 else c i))"
         if "c \<in> {0..<(m-1)} \<rightarrow> {0..l}" "s < m - 1" "\<forall>j \<le> s. c j < l"
         for c s using g_aux that unfolding g_def Let_def by blast
 
       have range_g: "g c \<in> {start..start + int q - 1}"
         if "c \<in> {0..<m - 1} \<rightarrow> {0..<(l+1)}" for c
         using is_multi_arith_prog_onD[OF is_multi_arith_prog that] 
         by (auto simp: g_def)
 
       text \<open>Obtain an $m$-fold arithmetic progression by adding the block-step.\<close>
       define steps :: "nat \<Rightarrow> nat" where steps_def: 
         "steps = (\<lambda>i.  (if i=0 then step else steps_m (i-1)))"
       define f where "f = multi_arith_prog m start_m steps"
       have f_step_g: "f c = int (c 0*step) + g (c \<circ> Suc)" for c
       proof -
         have "f c = start_m + int (\<Sum>i<Suc (m-1). c i * steps i)"
           using f_def unfolding multi_arith_prog_def 
           using less.prems by auto 
         also have "\<dots> = start_m + int (c 0 * steps 0) + 
                        int (\<Sum>i<m-1. c (Suc i) * steps (Suc i))"
           using sum.lessThan_Suc_shift[where n = "m-1"] by auto
         also have "\<dots> = start_m + int (c 0 * step) + 
                        int (\<Sum>i<m-1. c (Suc i) * steps_m i)"
           using steps_def by (auto split:if_splits)
         finally show ?thesis unfolding multi_arith_prog_def g_def 
           by simp
       qed
 
       text \<open> Show that this $m$-fold arithmetic progression fulfills all needed properties. \<close>
       have steps_gr_0: "\<forall>i<m. 0 < steps i" 
         unfolding steps_def using step_m_pos prog by auto
 
       have is_multi_on_f: 
         "is_multi_arith_prog_on (l+1) m start_m steps a b"
       proof -
         have "a \<le> start_m" using is_multi_arith_prog 
           unfolding is_multi_arith_prog_on_def
           using is_arith_prog_on_def prog(3) by force
         moreover {
           have "f (\<lambda>_. l) = arith_prog (g ((\<lambda>_. l) \<circ> Suc)) step l" 
             using f_step_g unfolding arith_prog_def by auto
           also have "g ((\<lambda>_. l) \<circ> Suc) \<le> start + q" 
             using range_g[of "(\<lambda>_. l) \<circ> Suc"] by auto
           then have "arith_prog (g ((\<lambda>_. l) \<circ> Suc)) step l \<le> 
             arith_prog start step l + q"
             unfolding arith_prog_def by auto
           also have "\<dots>\<le> b" using prog_in_ivl[of l]
             using is_multi_arith_prog unfolding is_multi_arith_prog_on_def
             using "1"(1) N_def by auto
           finally have "f (\<lambda>_. l) \<le> b" by auto
          }
          ultimately show ?thesis 
            unfolding is_multi_arith_prog_on_def f_def by auto
       qed
 
       text \<open> Show the relational property for all $s$. \<close>
       have rel_prop_1: 
         "col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
         if "c \<in> {0..<m} \<rightarrow> {0..l}" "s<m" "\<forall>j\<le>s. c j < l" for c s 
       proof (cases "s = 0")
         case True
         have "c 0 < l" using that(3) True by auto
         have range_c_Suc: "c \<circ> Suc \<in> {0..<m-1} \<rightarrow> {0..l}" 
           using that(1) by auto
         have "f c = arith_prog (g (c \<circ> Suc)) step (c 0)" 
           using f_step_g unfolding arith_prog_def by auto
         then have "col (f c) = col (arith_prog (g (c \<circ> Suc)) step 0)"
           using one_step_more'[of "g (c \<circ> Suc)" "c 0"] \<open>c 0 < l\<close>
             range_g[of "c \<circ> Suc"] range_c_Suc 
             atLeastLessThanSuc_atLeastAtMost by auto
         also {
           have "(\<Sum>x<m - 1. int (c (Suc x)) * int (steps_m x)) =
                    (\<Sum>x=1..<m. int(c x) * int (steps x))"
             by(rule sum.reindex_bij_witness[of _ "(\<lambda>x. x-1)" "Suc"]) 
               (auto simp: steps_def split:if_splits) 
           also have "\<dots> = (\<Sum>x<m. int (if x = 0 then 0 else c x) * 
             int (steps x))" 
             by (rule sum.mono_neutral_cong_left) auto
           finally have "arith_prog (g (c \<circ> Suc)) step 0 = 
             f (\<lambda>i. if i \<le> s then 0 else c i)" 
             unfolding f_def g_def multi_arith_prog_def arith_prog_def
             using True by auto
       }
         finally show ?thesis by auto
       next 
         case False
         hence s_greater_0: "s > 0" by auto
         have range_c_Suc: "c \<circ> Suc \<in> {0..<m-1} \<rightarrow> {0..l}" 
           using that(1) by auto
         have "c 0 < l" using \<open>s>0\<close> that by auto
         have g_IH:
           "col (g c') = col (g (\<lambda>i. if i \<le> s' then 0 else c' i))" 
           if "c' \<in> {0..<m-1} \<rightarrow> {0..l}" "s'<m-1" "\<forall>j\<le>s'. c' j < l" 
           for c' s' 
           using g_aux that unfolding multi_arith_prog_def g_def
           by (auto simp: Let_def)
         have g_shift_IH: "col (g (c \<circ> Suc)) = 
           col (g ((\<lambda>i. if i\<in>{1..t} then 0 else c i) \<circ> Suc))" 
           if "c \<in> {1..<m} \<rightarrow> {0..l}" "t\<in>{1..<m}" "\<forall>j\<in>{1..t}. c j < l"
           for c t
         proof -
           have "(\<lambda>i. (if i \<le> t - 1 then 0 else (c \<circ> Suc) i)) =
                 (\<lambda>i. (if i \<in> {1..t} then 0 else c i)) \<circ> Suc"
             using that by (auto split: if_splits simp:fun_eq_iff)
           then have right: 
             "g (\<lambda>i. if i \<le> (t-1) then 0 else (c \<circ> Suc) i) = 
              g ((\<lambda>i. if i\<in>{1..t} then 0 else c i) \<circ> Suc)" by auto
           have "(c \<circ> Suc)\<in> {0..<m-1} \<rightarrow> {0..l}" using that(1) by auto
           moreover have "t-1<m-1" using that(2) by auto
           moreover have"\<forall>j\<le>t-1. (c \<circ> Suc) j < l" using that by auto
           ultimately have "col (g (c \<circ> Suc)) = 
             col (g (\<lambda>i. (if i \<le> t-1 then 0 else (c \<circ> Suc) i)))"
             using g_IH[of "(c \<circ> Suc)" "t-1"] by auto
           with right show ?thesis by auto
         qed
 
         have "col (f c) = col (int (c 0 * step) + g (c \<circ> Suc))" 
           using f_step_g by simp
         also have "int (c 0 * step) + g (c \<circ> Suc) = 
           arith_prog (g (c \<circ> Suc)) step (c 0)"
           by (simp add: arith_prog_def)
         also have "col \<dots> = col (arith_prog (g (c \<circ> Suc)) step 0)" 
           using one_step_more'[of "g (c \<circ> Suc)" "c 0"] \<open>c 0 < l\<close> 
             range_g[of "c \<circ> Suc"] range_c_Suc 
             atLeastLessThanSuc_atLeastAtMost by auto
         also have "\<dots> = col (g (c \<circ> Suc))"
           unfolding arith_prog_def by auto
         also have "\<dots> = col (g ((\<lambda>i. if  i\<in>{1..s} then 0 else c i) \<circ>
           Suc))" using g_shift_IH[of "c" s] \<open>s>0\<close> that by force
         also have "\<dots> = col ((\<lambda>c. int (c 0 * step) + 
           g (c \<circ> Suc))(\<lambda>i. if i\<le>s then 0 else c i))" 
           by (auto simp: g_def multi_arith_prog_def)
         also have "\<dots> = col (f (\<lambda>i. if i \<le> s then 0 else c i))" 
           unfolding f_step_g by auto
         finally show ?thesis by simp
       qed
 
       show ?case
         by (rule exI[of _ start_m], rule exI[of _ steps])
            (use steps_gr_0 is_multi_on_f rel_prop_1 in 
              \<open>auto simp: f_def Let_def steps_def\<close>)
     qed
     then show ?case ..
   qed
 qed
 
 
 
 
 text \<open> Secondly, we show that \<open>vdw_lemma\<close> implies the induction step of Van der Waerden's Theorem
 using the pigeonhole principle. \<close>
 lemma vdw_lemma_imp_vdw:
   assumes "vdw_lemma k k l N"
   shows   "vdw k (Suc l) N"
 unfolding vdw_def proof (safe, goal_cases)
 text \<open>Idea: Proof uses pigeonhole principle to guarantee the existence of an arithmetic 
             progression of length $l+1$ with the same colour. \<close>
   case (1 a b col)
   obtain start steps where prog:
     "\<And>i. i < k \<Longrightarrow> steps i > 0"
     "is_multi_arith_prog_on (l+1) k start steps a b"
     "let f = multi_arith_prog k start steps
      in  \<forall>c \<in> {0..<k} \<rightarrow> {0..l}. \<forall>s<k. (\<forall> j \<le> s. c j < l) \<longrightarrow>
             col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
     using assms 1 
     by (elim vdw_lemmaE[where a=a and b=b and col=col and m=k 
           and k=k and l=l and n=N]) auto
 
   text \<open> Obtain a $k$-fold arithmetic progression $f$ of length $l$ from assumptions. \<close>
   define f where "f = multi_arith_prog k start steps" 
   have rel_propE: "col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
     if "c \<in> {0..<k} \<rightarrow> {0..l}" "s<k" "\<forall> j \<le> s. c j < l"
     for c s
     using prog(3) that unfolding f_def Let_def by auto
 
   text \<open>There are $k+1$ values $a_r = f(0,\dots,0,l,\dots,l)$ with $0\leq r\leq k$ zeros.\<close>
   define a_r where "a_r = (\<lambda>r. f (\<lambda>i. (if i<r then 0 else l)))"
   have range_col_a_r: "col (a_r x) < k" if "x < k+1" for x 
   proof -
     have "a_r x \<in> {a..b}" unfolding a_r_def f_def 
       by (intro is_multi_arith_prog_onD[OF prog(2)]) auto
     thus ?thesis using 1 by blast
   qed
   then have "(col \<circ> a_r) ` {..<k + 1} \<subseteq> {..<k}" using 1(2) by auto
   then have "card ((col \<circ> a_r) ` {..<k + 1}) \<le> card {..<k}"
     by (intro card_mono) auto
   then have "\<not> inj_on (col \<circ> a_r) {..<k+1}" 
     using pigeonhole[of "col \<circ> a_r" "{..<k+1}"] by auto
   text \<open>Using the pigeonhole principle get $r_1$ and $r_2$ where $a_{r_1}$ and $a_{r_2}$ have the 
     same colour.\<close>
   then obtain r1 r2 where pigeon_cols:
       "r1\<in>{..<k+1}" 
       "r2\<in>{..<k+1}" 
       "r1 < r2" 
       "(col \<circ> a_r) r1 = (col \<circ> a_r) r2"
     by (metis (mono_tags, lifting) linear linorder_inj_onI)
   text \<open> Show that the following function $h$ is an arithmetic progression which fulfills all
          properties for Van der Waerden's Theorem. \<close>
   define h where 
     "h = (\<lambda>x. f (\<lambda>i. (if i<r1 then 0 else (if i<r2 then x else l))))"
   have "h 0 = a_r r2" unfolding h_def a_r_def using \<open>r1<r2\<close> 
     by (intro arg_cong[where f = f]) auto
   moreover have "h l = a_r r1"  unfolding h_def a_r_def using \<open>r1<r2\<close>
     by (metis le_eq_less_or_eq less_le_trans)
   ultimately have "col (h 0) = col (h l)" using pigeon_cols(4) by auto
   have h_col: "col (h 0) = col (h i)" if "i\<in>{..<l+1}" for i
   proof (cases "i=l")
     case True
     then show ?thesis using \<open>col (h 0) = col (h l)\<close> by auto
   next
     case False
     then have "i<l" using that by auto
     let ?c = "(\<lambda>idx. if idx < r1 then 0 else if idx < r2 then i else l)"
     have "?c\<in>{0..<k} \<rightarrow> {0..l}" 
       using that by auto
     moreover have "(\<forall>j\<le>r2-1. ?c j < l)" 
       using \<open>i<l\<close> pigeon_cols(3) by force
     ultimately have "col (f ?c) = 
       col (f (\<lambda>i. if i \<le> r2-1 then 0 else ?c i))"
       using rel_propE[of ?c "r2-1"] pigeon_cols by simp
     then show ?thesis unfolding h_def f_def 
-      by (smt (z3) Nat.lessE One_nat_def add_diff_cancel_left' 
+      by (smt (verit) Nat.lessE One_nat_def add_diff_cancel_left' 
           le_less less_Suc_eq_le multi_arith_prog_mono plus_1_eq_Suc)
   qed
 
   define h_start where "h_start = start + l*(\<Sum>i\<in>{r2..<k}. steps i)"
   define h_step where "h_step = (\<Sum>i\<in>{r1..<r2}. steps i)"
   have h_arith_prog: "h = arith_prog h_start h_step" 
   proof -
     have "(\<Sum>x<k. int (if x < r1 then 0 else if x < r2 then y else l)
         * int (steps x)) =
       int l * (\<Sum>x = r2..<k. int (steps x)) + 
         int y * (\<Sum>x = r1..<r2. int (steps x))"
       for y 
     proof (cases "r2 = k")
       case True
       then have "r1<k" using pigeon_cols by auto
       with True have 
         "(\<Sum>x<k. int (if x < r1 then 0 else if x < r2 then y else l)
            * int (steps x)) =
          (\<Sum>x<k. int (if x < r1 then 0 else y) * int (steps x))"
         by (intro sum.cong) auto
       also have "\<dots> = (\<Sum>x<r1. int (if x < r1 then 0 else y) *
           int (steps x)) + (\<Sum>x=r1..<k. int (if x < r1 then 0 else y)
           * int (steps x))"
         using split_sum_mid_less[of r1 k 
             "(\<lambda>x. int (if x < r1 then 0 else y) * int (steps x))"] 
             \<open>r1<k\<close> by auto
       also have "\<dots> = (\<Sum>x=r1..<k. int y * int (steps x))" by auto
       also have "\<dots> = int y * (\<Sum>x=r1..<k. int (steps x))" 
         by (auto simp: sum_distrib_left[of "int y"])
       finally show ?thesis using True by auto
     next
       case False
       then have "r2<k" using pigeon_cols by auto
       define aux_left where "aux_left = 
         (\<lambda>x. int (if x < r1 then 0 else if x < r2 then y else l)
           * int (steps x))"
       have "(\<Sum>x<k. aux_left x) = (\<Sum>x=r1..<k. aux_left x)"
         by (intro sum.mono_neutral_right) (auto simp: aux_left_def)
       also have "{r1..<k} = {r1..<r2} \<union> {r2..<k}"
         using \<open>r1 < r2\<close> \<open>r2 < k\<close> by auto
       also have "(\<Sum>x\<in>\<dots>. aux_left x) = (\<Sum>x=r1..<r2. aux_left x) + 
         (\<Sum>x=r2..<k. aux_left x)"
         by (intro sum.union_disjoint) auto
       also have "(\<Sum>x=r1..<r2. aux_left x) =
         (\<Sum>x=r1..<r2. int y * int (steps x))"
         by (intro sum.cong) (auto simp: aux_left_def)
       also have "(\<Sum>x=r2..<k. aux_left x) = 
         (\<Sum>x=r2..<k. int l * int (steps x))"
         using \<open>r1 < r2\<close> by (intro sum.cong) (auto simp: aux_left_def)
       finally show ?thesis
         by (simp add: aux_left_def sum_distrib_left)
     qed
     then show ?thesis
       unfolding arith_prog_def h_start_def h_step_def h_def f_def
         multi_arith_prog_def by (auto split:if_splits)
   qed
 
   define j where "j = col (h 0)"
   have case_j: "j<k" using 1 range_col_a_r \<open>col (h 0) = col (h l)\<close> 
       \<open>h l = a_r r1\<close> j_def pigeon_cols(1) by auto
   have case_step: "h_step > 0" unfolding h_step_def
     using pigeon_cols by (intro sum_pos prog(1)) auto
 
   have range_h: "h i \<in> {a..b}" if "i < l + 1" for i
     unfolding h_def f_def by (rule is_multi_arith_prog_onD[OF prog(2)])
       (use that in auto)
 
   have case_on: "is_arith_prog_on (l+1) h_start h_step a b"
     unfolding is_arith_prog_on_def h_arith_prog 
     using range_h[of 0] range_h[of l]
     by (auto simp: Max_ge[of "{a..b}"] Min_le[of "{a..b}"] 
         h_arith_prog arith_prog_def)
 
   have case_col: "h ` {..<Suc l} \<subseteq> col -` {j} \<inter> {a..b}" 
     using h_col range_h unfolding j_def by auto
 
   show ?case using case_j case_step case_on case_col 
     by (auto simp: h_arith_prog) 
 qed
 
 text \<open> Lastly, we assemble all lemmas to finally prove Van der Waerden's Theorem by induction on 
 $l$. The cases $l=1$ and the induction start $l=2$ are treated separately and have been shown 
 earlier.\<close>
 theorem van_der_Waerden: assumes "l>0" "k>0" shows "\<exists>n. vdw k l n"
 using assms proof (induction l arbitrary: k rule: less_induct)
   case (less l)
   consider  "l=1" | "l=2" | "l>2" using less.prems by linarith
   then show ?case
   proof (cases)
     assume "l=1"
     then show ?thesis using vdw_1_right by auto
   next
     assume "l=2"
     then show ?thesis using vdw_2_right by auto
   next
     assume "l > 2"
     then have "2\<le>l-1" by auto
     from less.IH[of "l-1"] \<open>l>2\<close> 
     have "\<And>k'. k'>0 \<Longrightarrow> \<exists>n. vdw k' (l-1) n" by auto
     with vdw_imp_vdw_lemma[of "l-1" k k] \<open>l-1\<ge>2\<close> \<open>k>0\<close> 
       obtain N where "vdw_lemma k k (l-1) N" by auto
     then have "vdw k l N" using vdw_lemma_imp_vdw[of k "l-1" N]
       by (simp add: less.prems(1))
     then show ?thesis by auto
   qed
 qed
 
 end